cl-mcclim-0.9.6.dfsg.cvs20100315.orig/0000755000175000017500000000000011347764420015007 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/input-editing.lisp0000644000175000017500000012734211345155771020472 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2001 by ;;; Tim Moore (moore@bricoworks.com) ;;; (c) copyright 2006-2008 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; This file provides definitions of every part of input-editing that ;;; can be defined without actually having loaded the input ;;; editor. This is so more input-editor using code can be loaded ;;; before loading Drei. (in-package :clim-internals) (defvar *use-goatee* nil "If true, use the Goatee editing component instead of Drei. The Goatee component is faster and more mature than Drei.") (defvar *activation-gestures* nil "The set of currently active activation gestures. The global value of this must be NIL. The exact format of `*activation-gestures*' is unspecified. `*activation-gestures*' and the elements in it may have dynamic extent.") (defvar *standard-activation-gestures* '(:newline :return) "The default set of activation gestures. The exact set of standard activation is unspecified, but must include the gesture that corresponds to the #\Newline character. ") (defvar *delimiter-gestures* nil "The set of currently active delimiter gestures. The global value of this must be NIL. The exact format of `*delimiter-gestures*' is unspecified. `*delimiter-gestures*' and the elements in it may have dynamic extent.") (with-system-redefinition-allowed (when (and (fboundp 'interactive-stream-p) (not (typep (fdefinition 'interactive-stream-p) 'generic-function))) (fmakunbound 'interactive-stream-p)) (defgeneric interactive-stream-p (stream) (:method (stream) (cl:interactive-stream-p stream)))) (defclass standard-input-editing-mixin () ((%typeout-record :accessor typeout-record :initform nil :documentation "The output record (if any) that is the typeout information for this input-editing-stream. `With-input-editor-typeout' manages this output record.")) (:documentation "A mixin implementing some useful standard behavior for input-editing streams.")) (defmethod typeout-record :around ((stream standard-input-editing-mixin)) ;; Can't do this in an initform, since we need to proper position... (or (call-next-method) (let ((record (make-instance 'standard-sequence-output-record :x-position 0 :y-position (bounding-rectangle-min-y (input-editing-stream-output-record stream))))) (stream-add-output-record (encapsulating-stream-stream stream) record) (setf (typeout-record stream) record)))) ;;; These helper functions take the arguments of ACCEPT so that they ;;; can be used directly by ACCEPT. (defun make-activation-gestures (&key (activation-gestures nil activation-gestures-p) (additional-activation-gestures nil additional-activations-p) (existing-activation-gestures *activation-gestures*) &allow-other-keys) (cond (additional-activations-p (append additional-activation-gestures existing-activation-gestures)) (activation-gestures-p activation-gestures) (t (or existing-activation-gestures *standard-activation-gestures*)))) (defun make-delimiter-gestures (&key (delimiter-gestures nil delimiter-gestures-p) (additional-delimiter-gestures nil additional-delimiters-p) (existing-delimiter-gestures *delimiter-gestures*) &allow-other-keys) (cond (additional-delimiters-p (append additional-delimiter-gestures existing-delimiter-gestures)) (delimiter-gestures-p delimiter-gestures) (t existing-delimiter-gestures))) (defmacro with-activation-gestures ((gestures &key override) &body body) "Specifies a list of gestures that terminate input during the execution of `body'. `Body' may have zero or more declarations as its first forms. `Gestures' must be either a single gesture name or a form that evaluates to a list of gesture names. If the boolean `override' is true, then `gestures' will override the current activation gestures. If it is false (the default), then gestures will be added to the existing set of activation gestures. `with-activation-gestures' must bind `*activation-gestures*' to the new set of activation gestures. See also the `:activation-gestures' and `:additional-activation-gestures' options to `accept'." ;; XXX Guess this implies that gestures need to be defined at ;; compile time. Sigh. We permit both CLIM 2.0-style gesture names ;; and CLIM 2.2 style characters. (let ((gesture-form (cond ((or (and (symbolp gestures) (gethash gestures *gesture-names*)) (characterp gestures)) `(list ',gestures)) (t gestures))) (gestures (gensym)) (override-var (gensym))) `(let* ((,gestures ,gesture-form) ;Preserve evaluation order of arguments (,override-var ,override) (*activation-gestures* (apply #'make-activation-gestures (if ,override-var :activation-gestures :additional-activation-gestures) (list ,gestures)))) ,@body))) (defmacro with-delimiter-gestures ((gestures &key override) &body body) "Specifies a list of gestures that terminate an individual token, but not the entire input, during the execution of `body'. `Body' may have zero or more declarations as its first forms. `Gestures' must be either a single gesture name or a form that evaluates to a list of gesture names. If the boolean `override' is true, then `gestures' will override the current delimiter gestures. If it is false (the default), then gestures will be added to the existing set of delimiter gestures. `With-delimiter-gestures' must bind `*delimiter-gestures*' to the new set of delimiter gestures. See also the `:delimiter-gestures' and `:additional-delimiter-gestures' options to `accept'." ;; XXX Guess this implies that gestures need to be defined at ;; compile time. Sigh. We permit both CLIM 2.0-style gesture names ;; and CLIM 2.2 style characters. (let ((gesture-form (cond ((or (and (symbolp gestures) (gethash gestures *gesture-names*)) (characterp gestures)) `(list ',gestures)) (t gestures))) (gestures (gensym)) (override-var (gensym))) `(let* ((,gestures ,gesture-form) ;Preserve evaluation order of arguments (,override-var ,override) (*delimiter-gestures* (make-delimiter-gestures (if ,override-var :delimiter-gestures :additional-delimiter-gestures) ,gestures))) ,@body))) (defun activation-gesture-p (gesture) "Returns true if the gesture object `gesture' is an activation gesture, otherwise returns false." (loop for gesture-name in *activation-gestures* when (gesture-matches-spec-p gesture gesture-name) do (return t) finally (return nil))) (defun delimiter-gesture-p (gesture) "Returns true if the gesture object `gesture' is a delimiter gesture, otherwise returns false." (loop for gesture-name in *delimiter-gestures* when (gesture-matches-spec-p gesture gesture-name) do (return t) finally (return nil))) (defmacro with-input-editor-typeout ((&optional (stream t) &rest args &key erase) &body body) "Clear space above the input-editing stream `stream' and evaluate `body', capturing output done to `stream'. Place will be obtained above the input-editing area and the output put there. Nothing will be displayed until `body' finishes. `Stream' is not evaluated and must be a symbol. If T (the default), `*standard-input*' will be used. `Stream' will be bound to an `extended-output-stream' while `body' is being evaluated." (declare (ignore erase)) (check-type stream symbol) (let ((stream (if (eq stream t) '*standard-output* stream))) `(invoke-with-input-editor-typeout ,stream #'(lambda (,stream) ,@body) ,@args))) (defgeneric invoke-with-input-editor-typeout (stream continuation &key erase) (:documentation "Call `continuation' with a single argument, a stream to do input-editor-typeout on.")) (defun sheet-move-output-vertically (sheet y delta-y) "Move the output records of `sheet', starting at vertical device unit offset `y' or below, down by `delta-y' device units, then repaint `sheet'." (unless (zerop delta-y) (with-bounding-rectangle* (sheet-x1 sheet-y1 sheet-x2 sheet-y2) sheet (declare (ignore sheet-x1 sheet-y1)) (map-over-output-records-overlapping-region #'(lambda (record) (multiple-value-bind (record-x record-y) (output-record-position record) (when (> (+ record-y (bounding-rectangle-height record)) y) (setf (output-record-position record) (values record-x (+ record-y delta-y)))))) (stream-output-history sheet) (make-bounding-rectangle 0 y sheet-x2 sheet-y2)) ;; Only repaint within the visible region... (with-bounding-rectangle* (viewport-x1 viewport-y1 viewport-x2 viewport-y2) (or (pane-viewport-region sheet) sheet) (declare (ignore viewport-y1)) (repaint-sheet sheet (make-bounding-rectangle viewport-x1 (- y (abs delta-y)) viewport-x2 viewport-y2)))))) (defmethod invoke-with-input-editor-typeout ((editing-stream standard-input-editing-mixin) (continuation function) &key erase) (with-accessors ((stream-typeout-record typeout-record)) editing-stream ;; Can't do this in an initform, as we need to set the proper ;; output record position. (let* ((encapsulated-stream (encapsulating-stream-stream editing-stream)) (old-min-y (bounding-rectangle-min-y stream-typeout-record)) (old-height (bounding-rectangle-height stream-typeout-record)) (new-typeout-record (with-output-to-output-record (encapsulated-stream 'standard-sequence-output-record record) (unless erase ;; Steal the children of the old typeout record. (map nil #'(lambda (child) (setf (output-record-parent child) nil (output-record-position child) (values 0 0)) (add-output-record child record)) (output-record-children stream-typeout-record)) ;; Make sure new output is done ;; after the stolen children. (stream-increment-cursor-position encapsulated-stream 0 old-height)) (funcall continuation encapsulated-stream)))) (with-sheet-medium (medium encapsulated-stream) (setf (output-record-position new-typeout-record) (values 0 old-min-y)) ;; Calculate the height difference between the old typeout and the new. (let ((delta-y (- (bounding-rectangle-height new-typeout-record) old-height))) (multiple-value-bind (typeout-x typeout-y) (output-record-position new-typeout-record) (declare (ignore typeout-x)) ;; Clear the old typeout... (clear-output-record stream-typeout-record) ;; Move stuff for the new typeout record... (sheet-move-output-vertically encapsulated-stream typeout-y delta-y) ;; Reuse the old stream-typeout-record... (add-output-record new-typeout-record stream-typeout-record) ;; Now, let there be light! (repaint-sheet encapsulated-stream stream-typeout-record))))))) (defun clear-typeout (&optional (stream t)) "Blank out the input-editor typeout displayed on `stream', defaulting to T for `*standard-output*'." (with-input-editor-typeout (stream :erase t) (declare (ignore stream)))) (defmacro with-input-editing ((&optional (stream t) &rest args &key input-sensitizer (initial-contents "") (class ''standard-input-editing-stream class-provided-p)) &body body) "Establishes a context in which the user can edit the input typed in on the interactive stream `stream'. `Body' is then executed in this context, and the values returned by `body' are returned as the values of `with-input-editing'. `Body' may have zero or more declarations as its first forms. The stream argument is not evaluated, and must be a symbol that is bound to an input stream. If stream is T (the default), `*standard-input*' is used. If stream is a stream that is not an interactive stream, then `with-input-editing' is equivalent to progn. `input-sensitizer', if supplied, is a function of two arguments, a stream and a continuation function; the function has dynamic extent. The continuation, supplied by CLIM, is responsible for displaying output corresponding to the user's input on the stream. The input-sensitizer function will typically call `with-output-as-presentation' in order to make the output produced by the continuation sensitive. If `initial-contents' is supplied, it must be either a string or a list of two elements, an object and a presentation type. If it is a string, the string will be inserted into the input buffer using `replace-input'. If it is a list, the printed representation of the object will be inserted into the input buffer using `presentation-replace-input'." (setq stream (stream-designator-symbol stream '*standard-input*)) (with-keywords-removed (args (:input-sensitizer :initial-contents :class)) `(invoke-with-input-editing ,stream #'(lambda (,stream) ,@body) ,input-sensitizer ,initial-contents ,(if class-provided-p class `(if *use-goatee* 'goatee-input-editing-stream ,class)) ,@args))) (defmacro with-input-position ((stream) &body body) (let ((stream-var (gensym "STREAM"))) `(let* ((,stream-var ,stream) (*current-input-stream* (and (typep ,stream-var 'input-editing-stream) ,stream-var)) (*current-input-position* (and *current-input-stream* (stream-scan-pointer ,stream-var)))) ,@body))) (defun input-editing-rescan-loop (editing-stream continuation) (let ((start-scan-pointer (stream-scan-pointer editing-stream))) (loop (block rescan (handler-bind ((rescan-condition #'(lambda (c) (declare (ignore c)) (reset-scan-pointer editing-stream start-scan-pointer) ;; Input-editing contexts above may be interested... (return-from rescan nil)))) (return-from input-editing-rescan-loop (funcall continuation editing-stream))))))) (defgeneric finalize (editing-stream input-sensitizer) (:documentation "Do any cleanup on an editing stream that is no longer supposed to be used for editing, like turning off the cursor, etc.")) (defmethod finalize ((stream input-editing-stream) input-sensitizer) (clear-typeout stream) (redraw-input-buffer stream)) (defgeneric invoke-with-input-editing (stream continuation input-sensitizer initial-contents class) (:documentation "Implements `with-input-editing'. `Class' is the class of the input-editing stream to create, if necessary.")) (defmethod invoke-with-input-editing (stream continuation input-sensitizer initial-contents class) (declare (ignore input-sensitizer initial-contents class)) (funcall continuation stream)) (defmethod invoke-with-input-editing ((stream input-editing-stream) continuation input-sensitizer initial-contents class) (unless (stream-rescanning-p stream) (if (stringp initial-contents) (replace-input stream initial-contents) (presentation-replace-input stream (first initial-contents) (second initial-contents) (stream-default-view stream)))) (call-next-method)) (defmethod invoke-with-input-editing :around ((stream extended-output-stream) continuation input-sensitizer initial-contents class) (declare (ignore continuation input-sensitizer initial-contents class)) (letf (((cursor-visibility (stream-text-cursor stream)) nil)) (call-next-method))) (defmethod invoke-with-input-editing :around (stream continuation input-sensitizer initial-contents class) (declare (ignore continuation input-sensitizer initial-contents class)) (with-activation-gestures (*standard-activation-gestures*) (call-next-method))) (defgeneric input-editing-stream-output-record (stream) (:documentation "Return the output record showing the display of the input-editing stream `stream' values. This function does not appear in the spec but is used by the command processing code for layout and to implement a general with-input-editor-typeout.")) (defmethod input-editor-format ((stream t) format-string &rest format-args) (unless (and (typep stream '#.*string-input-stream-class*) (input-stream-p stream)) (apply #'format stream format-string format-args))) (defun make-room (buffer pos n) (let ((fill (fill-pointer buffer))) (when (> (+ fill n) (array-dimension buffer 0)) (adjust-array buffer (list (+ fill n)))) (incf (fill-pointer buffer) n) (replace buffer buffer :start1 (+ pos n) :start2 pos :end2 fill))) ;;; Defaults for replace-input and presentation-replace-input. (defvar *current-input-stream* nil) (defvar *current-input-position* 0) (defun read-token (stream &key (input-wait-handler *input-wait-handler*) (pointer-button-press-handler *pointer-button-press-handler*) click-only) "Reads characters from the interactive stream `stream' until it encounters a delimiter or activation gesture, or a pointer gesture. Returns the accumulated string that was delimited by the delimiter or activation gesture, leaving the delimiter unread. If the first character of typed input is a quotation mark (#\"), then `read-token' will ignore delimiter gestures until another quotation mark is seen. When the closing quotation mark is seen, `read-token' will proceed as above. `Click-only' is ignored for now. `Input-wait-handler' and `pointer-button-press-handler' are as for 34stream-read-gesture" (declare (ignore click-only)) ;XXX For now (let ((result (make-array 1 :adjustable t :fill-pointer 0 :element-type 'character)) (in-quotes nil)) ;; The spec says that read-token ignores delimiter gestures if the ;; first character is #\", until it sees another. OK... what about ;; other occurences of #\"? Guess we'll just accumulate them. (loop for first-char = t then nil for gesture = (read-gesture :stream stream :input-wait-handler input-wait-handler :pointer-button-press-handler pointer-button-press-handler) do (cond ((or (null gesture) (activation-gesture-p gesture) (typep gesture 'pointer-button-event) (and (not in-quotes) (delimiter-gesture-p gesture))) (loop-finish)) ((characterp gesture) (if (eql gesture #\") (cond (first-char (setq in-quotes t)) (in-quotes (setq in-quotes nil)) (t (vector-push-extend gesture result))) (vector-push-extend gesture result))) (t nil)) finally (progn (when gesture (unread-gesture gesture :stream stream)) ;; Return a simple string. XXX Would returning an ;; adjustable string be so bad? (return (subseq result 0)))))) (defun write-token (token stream &key acceptably) "This function is the opposite of `read-token' given the string token, it writes it to the interactive stream stream. If `acceptably' is true and there are any characters in the token that are delimiter gestures (see the macro `with-delimiter-gestures'), then `write-token' will surround the token with quotation marks (#\"). Typically, `present' methods will use `write-token' instead of `write-string'." (let ((put-in-quotes (and acceptably (some #'delimiter-gesture-p token)))) (when put-in-quotes (write-char #\" stream)) (write-string token stream) (when put-in-quotes (write-char #\" stream)))) ;;; Signalling Errors Inside present (sic) (define-condition simple-parse-error (simple-condition parse-error) () (:documentation "The error that is signalled by `simple-parse-error'. This is a subclass of `parse-error'. This condition handles two initargs, `:format-string' and `:format-arguments', which are used to specify a control string and arguments for a call to `format'.")) (defun simple-parse-error (format-string &rest format-args) "Signals a `simple-parse-error' error while parsing an input token. Does not return. `Format-string' and `format-args' are as for format." (error 'simple-parse-error :format-control format-string :format-arguments format-args)) (define-condition input-not-of-required-type (parse-error) ((string :reader not-required-type-string :initarg :string) (type :reader not-required-type-type :initarg :type)) (:report (lambda (condition stream) (format stream "Input ~S is not of required type ~S" (not-required-type-string condition) (not-required-type-type condition)))) (:documentation "The error that is signalled by `input-not-of-required-type'. This is a subclass of `parse-error'. This condition handles two initargs, `:string' and `:type', which specify a string to be used in an error message and the expected presentation type.")) (defun input-not-of-required-type (object type) "Reports that input does not satisfy the specified type by signalling an `input-not-of-required-type' error. `Object' is a parsed object or an unparsed token (a string). `Type' is a presentation type specifier. Does not return." (error 'input-not-of-required-type :string object :type type)) ;;; 24.5 Completion (defvar *completion-gestures* '(:complete) "A list of the gesture names that cause `complete-input' to complete the user's input as fully as possible. The exact global contents of this list is unspecified, but must include the `:complete' gesture name.") (defvar *help-gestures* '(:help) "A list of the gesture names that cause `accept' and `complete-input' to display a (possibly input context-sensitive) help message, and for some presentation types a list of possibilities as well. The exact global contents of this list is unspecified, but must include the `:help' gesture name.") (defvar *possibilities-gestures* '(:possibilities) "A list of the gesture names that cause `complete-input' to display a (possibly input context-sensitive) help message and a list of possibilities. The exact global contents of this list is unspecified, but must include the `:possibilities' gesture name.") (define-condition simple-completion-error (simple-parse-error) ((input-so-far :reader completion-error-input-so-far :initarg :input-so-far)) (:documentation "The error that is signalled by `complete-input' when no completion is found. This is a subclass of `simple-parse-error'.")) ;;; wrapper around event-matches-gesture-name-p to match against characters too. (defgeneric gesture-matches-spec-p (gesture spec) (:documentation "Match a gesture against a gesture name or character.")) (defmethod gesture-matches-spec-p (gesture (spec symbol)) (event-matches-gesture-name-p gesture spec)) (defmethod gesture-matches-spec-p ((gesture character) (spec character)) (char-equal gesture spec)) (defmethod gesture-matches-spec-p (gesture spec) (declare (ignore gesture spec)) nil) (defun gesture-match (gesture list) "Returns t if gesture matches any gesture spec in list." (some #'(lambda (name) (gesture-matches-spec-p gesture name)) list)) ;;; Helpers for complete-input, which is just getting too long. (defun complete-gesture-p (gesture) (or (delimiter-gesture-p gesture) (activation-gesture-p gesture))) ;;; Break out rescanning case for complete-input. ;;; ;;; funky logic; we don't know if we're still rescanning until after the call ;;; to read-gesture. (defun complete-input-rescan (stream func partial-completers so-far allow-any-input) (when (stream-rescanning-p stream) (loop for gesture = (read-gesture :stream stream :timeout 0) while (and gesture (stream-rescanning-p stream)) if (complete-gesture-p gesture) do (let (input success object nmatches) (when (gesture-match gesture partial-completers) (setf (values input success object nmatches) (funcall func (subseq so-far 0) :complete-limited))) (unless (and (numberp nmatches) (> nmatches 0)) ;; Not a partial match; better be a total match (setf (values input success object) (funcall func (subseq so-far 0) :complete)) (if (or success allow-any-input) (progn (unread-gesture gesture :stream stream) (return-from complete-input-rescan (values object t input))) ;; This used to be an error, but no one thought ;; that was a really great idea. (signal 'simple-completion-error :format-control "complete-input: While rescanning,~ can't match ~A~A" :format-arguments (list so-far gesture) :input-so-far so-far)))) end do (vector-push-extend gesture so-far) finally (when gesture (unread-gesture gesture :stream stream)))) nil) (defun possibilities-for-menu (possibilities) (loop for (display object) in possibilities collect `(,display :value ,object))) (defun possibility-printer (possibility ptype stream) "A default function for printing a possibility. Suitable for used as value of `:possibility-printer' in calls to `complete-input'" (with-output-as-presentation (stream possibility ptype) (write-string (first possibility) stream))) (defun print-possibilities (possibilities possibility-printer stream) "Write `possibitilies' to `stream', using `possibility-printer'. `Possibilities' must be a list of input-completion possibilities. `Stream' must be an input-editing stream. Output will be done to its typeout." (with-input-editor-typeout (stream :erase t) (surrounding-output-with-border (stream :shape :drop-shadow :background +cornsilk1+) (surrounding-output-with-border (stream :shape :rectangle) (let ((ptype `(completion ,possibilities))) (format-items possibilities :stream stream :printer #'(lambda (possibility stream) (funcall possibility-printer possibility ptype stream)))))))) ;;; Helper returns gesture (or nil if gesture shouldn't be part of the input) ;;; and completion mode, if any. (defvar *completion-possibilities-continuation* nil) (defun read-completion-gesture (stream partial-completers help-displays-possibilities) (flet ((possibilitiesp (gesture) (or (gesture-match gesture *possibilities-gestures*) (and help-displays-possibilities (gesture-match gesture *help-gestures*))))) (let ((*completion-possibilities-continuation* #'(lambda () (return-from read-completion-gesture (values nil :possibilities))))) (handler-bind ((accelerator-gesture #'(lambda (c) (let ((gesture (accelerator-gesture-event c))) (when (possibilitiesp gesture) (return-from read-completion-gesture (values nil :possibilities))))))) (let ((gesture (read-gesture :stream stream))) (values gesture (cond ((possibilitiesp gesture) :possibilities) ((gesture-match gesture partial-completers) :complete-limited) ((gesture-match gesture *completion-gestures*) :complete-maximal) ((complete-gesture-p gesture) :complete) (t nil)))))))) (defparameter *trace-complete-input* nil) (defun complete-input (stream func &key partial-completers allow-any-input (possibility-printer #'possibility-printer) (help-displays-possibilities t)) (let ((so-far (make-array 1 :element-type 'character :adjustable t :fill-pointer 0)) (*accelerator-gestures* (append *help-gestures* *possibilities-gestures* *accelerator-gestures*))) (with-input-position (stream) (flet ((insert-input (input) (adjust-array so-far (length input) :fill-pointer (length input)) (replace so-far input) ;; XXX: Relies on non-specified behavior of :rescan. (replace-input stream input :rescan nil))) (multiple-value-bind (object success input) (complete-input-rescan stream func partial-completers so-far allow-any-input) (when success (return-from complete-input (values object success input)))) (loop (multiple-value-bind (gesture mode) (read-completion-gesture stream partial-completers help-displays-possibilities) (if mode (multiple-value-bind (input success object nmatches possibilities) (funcall func (subseq so-far 0) mode) (when (and (zerop nmatches) (eq mode :complete-limited) (complete-gesture-p gesture)) ;; Gesture is both a partial completer and a ;; delimiter e.g., #\space. If no partial match, ;; try again with a total match. (setf (values input success object nmatches possibilities) (funcall func (subseq so-far 0) :complete)) (setf mode :complete)) ;; Preserve the delimiter (when (and success (eq mode :complete)) (unread-gesture gesture :stream stream)) ;; Get completion from menu (when *trace-complete-input* (format *trace-output* "nmatches = ~A, mode = ~A~%" nmatches mode)) (when (and (> nmatches 0) (eq mode :possibilities)) (print-possibilities possibilities possibility-printer stream) (redraw-input-buffer stream) (let ((possibility (handler-case (with-input-context (`(completion ,possibilities) :override nil) (object type event) (prog1 nil (read-gesture :stream stream :peek-p t)) (t object)) (abort-gesture () nil)))) (if possibility (setf (values input success object nmatches) (values (first possibility) t (second possibility) 1)) (setf success nil nmatches 0)))) (unless (and (eq mode :complete) (not success)) (if (> nmatches 0) (insert-input input) (beep))) (cond ((and success (eq mode :complete)) (return-from complete-input (values object success input))) ((activation-gesture-p gesture) (if allow-any-input (return-from complete-input (values nil t (subseq so-far 0))) (error 'simple-completion-error :format-control "Input ~S does not match" :format-arguments (list so-far) :input-so-far so-far))))) (vector-push-extend gesture so-far)))))))) ;;; helper function (defun left-prefix (string1 string2 &key (end nil)) "Returns the common prefix of string1 and string2, up to end" (let* ((end1 (if end (min (length string1) end) nil)) (end2 (if end (min (length string2) end) nil)) (mismatch (mismatch string1 string2 :test #'char-equal :end1 end1 :end2 end2))) (cond (mismatch (subseq string1 0 mismatch)) (end (subseq string1 0 end)) (t string1)))) (defun complete-from-generator (initial-string generator delimiters &key (action :complete) (predicate (constantly t))) (when (eq action :possibilities) (return-from complete-from-generator (complete-from-generator-possibilities initial-string generator predicate))) (let ((initial-string-len (length initial-string)) (candidate-match nil) (matches 0) (object nil) (identical nil) (identical-match nil) (identical-object nil) (actual-match nil)) (flet ((suggester (str obj) (unless (funcall predicate obj) (return-from suggester nil)) (let ((partial-match-end (and (eq action :complete-limited) (>= (length str) initial-string-len) (position-if #'(lambda (c) (member c delimiters)) str :start initial-string-len)))) (when (and (eq action :complete-limited) (null partial-match-end)) (return-from suggester nil)) (unless partial-match-end (setq partial-match-end (1- (length str)))) (let ((mismatch-initial (mismatch initial-string str :test #'char-equal))) (cond ((and mismatch-initial (>= mismatch-initial (length initial-string))) (incf matches) (unless candidate-match (setq object obj)) (setf candidate-match (cond (candidate-match (left-prefix candidate-match str :end (1+ partial-match-end))) (partial-match-end (subseq str 0 (1+ partial-match-end))) (t str)) actual-match str)) ((null mismatch-initial) (incf matches) ;; If there's a longer match we want to find it. (if (eq action :complete-maximal) (progn (setf identical-match str) (setf identical-object obj)) (progn (setf candidate-match str) (setf object obj))) (setf identical t))))))) (funcall generator initial-string #'suggester) (let ((partial-match-before-end (and (eq action :complete-limited) (eql matches 1) (< (length candidate-match) (length actual-match))))) (values (or candidate-match identical-match initial-string) (or (and identical (or (not (eq action :complete-maximal)) (eql matches 1))) (and (eql matches 1) (not partial-match-before-end))) (if (eq action :complete-maximal) (cond ((and (eql matches 2) identical-match) object) ((and identical-match (eql matches 1)) identical-object) ((eql matches 1) object)) (and (or identical (and (eql matches 1) (not partial-match-before-end))) object)) matches nil))))) ;;; The possibilities action is different enough that I don't want to add to ;;; the spaghetti above... (defun complete-from-generator-possibilities (initial-string generator predicate) (let ((possibilities nil) (nmatches 0) (initial-len (length initial-string))) (flet ((suggester (str obj) (unless (funcall predicate obj) (return-from suggester nil)) (when (>= (or (mismatch initial-string str :test #'char-equal) (length initial-string)) initial-len) (incf nmatches) (push (list str obj) possibilities)))) (funcall generator initial-string #'suggester) (if (and (eql nmatches 1) (string-equal initial-string (caar possibilities))) ;; return values are as from complete-from-generator, qv. (values (caar possibilities) t (cdar possibilities) nmatches possibilities) (values initial-string nil nil nmatches (sort possibilities #'string-lessp :key #'car)))))) (defun complete-from-possibilities (initial-string completions delimiters &key (action :complete) (predicate (constantly t)) (name-key #'car) (value-key #'second)) (flet ((generator (input-string suggester) (declare (ignore input-string)) (do-sequence (possibility completions) (funcall suggester (funcall name-key possibility) (funcall value-key possibility))))) (complete-from-generator initial-string #'generator delimiters :action action :predicate predicate))) (defun suggest (completion object) "Specifies one possibility for `completing-from-suggestions'. `Completion' is a string, the printed representation of object. `Object' is the internal representation. Calling this function outside of the body of `completing-from-suggestions' is an error." (declare (ignore completion object)) (error "SUGGEST called outside of lexical scope of COMPLETING-FROM-SUGGESTIONS" )) (defmacro completing-from-suggestions ((stream &rest args) &body body) "Reads input from the input editing stream `stream', completing over a set of possibilities generated by calls to `suggest' within `body'. `Body' may have zero or more declarations as its first forms. `Completing-from-suggestions' returns three values, `object', `success', and `string'. The stream argument is not evaluated, and must be a symbol that is bound to a stream. If `stream' t is (the default), `*standard-input*' is used. `Partial-completers', `allow-any-input', and `possibility-printer' are as for `complete-input'. Implementations will probably use `complete-from-generator' to implement this." (when (eq stream t) (setq stream '*standard-input*)) (let ((generator (gensym "GENERATOR")) (input-string (gensym "INPUT-STRING")) (suggester (gensym "SUGGESTER"))) `(flet ((,generator (,input-string ,suggester) (declare (ignore ,input-string)) (flet ((suggest (completion object) (funcall ,suggester completion object))) ,@body))) ;; This sucks, but we can't use args to the macro directly because ;; we want the partial-delimiters argument and we need to insure its ;; proper evaluation order with everything else. (let* ((complete-input-args (list ,@args)) (partial-completers (getf complete-input-args :partial-completers nil))) (apply #'complete-input ,stream #'(lambda (so-far mode) (complete-from-generator so-far #',generator partial-completers :action mode)) complete-input-args))))) ;;; Infrasructure for detecting empty input, thus allowing accept-1 ;;; to supply a default. (defmacro handle-empty-input ((stream) input-form &body handler-forms) "Establishes a context on `stream' (a `standard-input-editing-stream') in which empty input entered in `input-form' may transfer control to `handler-forms'. Empty input is assumed when a simple-parse-error is signalled and there is a delimeter gesture or activation gesture in the stream at the position where `input-form' began its input. The gesture that caused the transfer remains to be read in `stream'. Control is transferred to the outermost `handle-empty-input' form that is empty. Note: noise strings in the buffer, such as the prompts of recursive calls to `accept', cause input to not be empty. However, the prompt generated by `accept' is generally not part of its own empty input context." (with-gensyms (input-cont handler-cont) `(flet ((,input-cont () ,input-form) (,handler-cont () ,@handler-forms)) (declare (dynamic-extent #',input-cont #',handler-cont)) (invoke-handle-empty-input ,stream #',input-cont #',handler-cont)))) (define-condition empty-input-condition (simple-condition) ((stream :reader empty-input-condition-stream :initarg :stream))) ;;; The code that signalled the error might have consumed the gesture, or ;;; not. ;;; XXX Actually, it would be a violation of the `accept' protocol to consume ;;; the gesture, but who knows what random accept methods are doing. (defun empty-input-p (stream begin-scan-pointer activation-gestures delimiter-gestures) (let ((scan-pointer (stream-scan-pointer stream)) (fill-pointer (fill-pointer (stream-input-buffer stream)))) ;; activated? (cond ((and (eql begin-scan-pointer scan-pointer) (eql scan-pointer fill-pointer)) t) ((or (eql begin-scan-pointer scan-pointer) (eql begin-scan-pointer (1- scan-pointer))) (let ((gesture (aref (stream-input-buffer stream) begin-scan-pointer))) (and (characterp gesture) (or (gesture-match gesture activation-gestures) (gesture-match gesture delimiter-gestures))))) (t nil)))) ;;; The control flow in here might be a bit confusing. The handler catches ;;; parse errors from accept forms and checks if the input stream is empty. If ;;; so, it resignals an empty-input-condition to see if an outer call to ;;; accept is empty and wishes to handle this situation. We don't resignal the ;;; parse error itself because it might get handled by a handler on ERROR in an ;;; accept method or in user code, which would screw up the default mechanism. ;;; ;;; If the situation is not handled in the innermost empty input handler, ;;; either directly or as a result of resignalling, then it won't be handled ;;; by any of the outer handlers as the stack unwinds, because EMPTY-INPUT-P ;;; will return nil. (defun invoke-handle-empty-input (stream input-continuation handler-continuation) (unless (input-editing-stream-p stream) (return-from invoke-handle-empty-input (funcall input-continuation))) (let ((begin-scan-pointer (stream-scan-pointer stream)) (activation-gestures *activation-gestures*) (delimiter-gestures *delimiter-gestures*)) (block empty-input (handler-bind (((or simple-parse-error empty-input-condition) #'(lambda (c) (when (empty-input-p stream begin-scan-pointer activation-gestures delimiter-gestures) (if (typep c 'empty-input-condition) (signal c) (signal 'empty-input-condition :stream stream)) ;; No one else wants to handle it, so we will (return-from empty-input nil))))) (return-from invoke-handle-empty-input (funcall input-continuation)))) (funcall handler-continuation))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/output.lisp0000600000175000017500000001257010423413276017227 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) (defclass standard-sheet-output-mixin () ( )) (defclass sheet-mute-output-mixin () ( )) (defclass sheet-with-medium-mixin () ((medium :initform nil :reader sheet-medium :writer (setf %sheet-medium)))) (macrolet ((frob (fn &rest args) `(defmethod ,fn ,(substitute '(medium sheet-with-medium-mixin) 'medium args) ;; medium arg is really a sheet (let ((medium (sheet-medium medium))) ,(if (symbolp fn) `(,fn ,@args) `(funcall #',fn ,@args)))))) (frob medium-foreground medium) (frob medium-background medium) (frob (setf medium-foreground) design medium) (frob (setf medium-background) design medium) (frob medium-ink medium) (frob (setf medium-ink) design medium) (frob medium-transformation medium) (frob (setf medium-transformation) transformation medium) (frob medium-clipping-region medium) (frob (setf medium-clipping-region) region medium) (frob medium-line-style medium) (frob (setf medium-line-style) line-style medium) (frob medium-default-text-style medium) (frob (setf medium-default-text-style) text-style medium) (frob medium-text-style medium) (frob (setf medium-text-style) text-style medium) (frob medium-current-text-style medium) (frob medium-beep medium)) (defclass temporary-medium-sheet-output-mixin (sheet-with-medium-mixin) ()) (defclass permanent-medium-sheet-output-mixin (sheet-with-medium-mixin) ()) (defmethod initialize-instance :after ((sheet permanent-medium-sheet-output-mixin) &rest args) (declare (ignore args)) ;; hmm, (setf (%sheet-medium sheet) (make-medium (port sheet) sheet)) ;; hmm... (engraft-medium (sheet-medium sheet) (port sheet) sheet)) (defmacro with-sheet-medium ((medium sheet) &body body) (check-type medium symbol) (let ((fn (gensym))) `(labels ((,fn (,medium) ,(declare-ignorable-form* medium) ,@body)) (declare (dynamic-extent #',fn)) (invoke-with-sheet-medium-bound #',fn nil ,sheet)))) (defmacro with-sheet-medium-bound ((sheet medium) &body body) (check-type medium symbol) (let ((fn (gensym))) `(labels ((,fn (,medium) ,(declare-ignorable-form* medium) ,@body)) (declare (dynamic-extent #',fn)) (invoke-with-sheet-medium-bound #',fn ,medium ,sheet)))) (defmethod invoke-with-sheet-medium-bound (continuation (medium null) (sheet permanent-medium-sheet-output-mixin)) (funcall continuation (sheet-medium sheet))) ; BTS added this. CHECKME (defmethod invoke-with-sheet-medium-bound (continuation (medium null) (sheet mirrored-pixmap)) (funcall continuation (pixmap-medium sheet))) (defmethod invoke-with-sheet-medium-bound (continuation (medium null) (sheet temporary-medium-sheet-output-mixin)) (let ((old-medium (sheet-medium sheet)) (new-medium (allocate-medium (port sheet) sheet))) (unwind-protect (progn (engraft-medium new-medium (port sheet) sheet) (setf (%sheet-medium sheet) new-medium) (funcall continuation new-medium)) (setf (%sheet-medium sheet) old-medium) (degraft-medium new-medium (port sheet) sheet) (deallocate-medium (port sheet) new-medium)))) ;; The description of WITH-SHEET-MEDIUM-BOUND in the spec, seems to be ;; extremly bogus, what is its purpose? (defmethod invoke-with-sheet-medium-bound (continuation (medium basic-medium) (sheet permanent-medium-sheet-output-mixin)) ;; this seems to be extremly bogus to me. (funcall continuation medium)) (defmethod invoke-with-sheet-medium-bound (continuation (medium basic-medium) (sheet temporary-medium-sheet-output-mixin)) (cond ((not (null (sheet-medium sheet))) (funcall continuation medium)) (t (let ((old-medium (sheet-medium sheet)) (new-medium medium)) (unwind-protect (progn (engraft-medium new-medium (port sheet) sheet) (setf (%sheet-medium sheet) new-medium) (funcall continuation new-medium)) (setf (%sheet-medium sheet) old-medium) (degraft-medium new-medium (port sheet) sheet) ))))) (defmethod invoke-with-special-choices (continuation (sheet sheet-with-medium-mixin)) (with-sheet-medium (medium sheet) (with-special-choices (medium) (funcall continuation sheet)))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/transforms.lisp0000600000175000017500000010360310423413301020050 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-INTERNALS; -*- ;;; -------------------------------------------------------------------------------------- ;;; Title: The CLIM Transformations ;;; Created: 1998-09-29 ;;; Author: Gilbert Baumann ;;; License: LGPL (See file COPYING for details). ;;; $Id: transforms.lisp,v 1.33 2006/03/10 21:58:13 tmoore Exp $ ;;; -------------------------------------------------------------------------------------- ;;; (c) copyright 1998,1999,2003 by Gilbert Baumann ;;; (c) copyright 2000 by ;;; Robert Strandh (strandh@labri.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) ;;;; Changes ;;; When Who What ;;; -------------------------------------------------------------------------------------- ;;; 2001-07-16 GB added a cache for the inverse transformation ;;; nobody bothers to use the log above ;-( ;; The CLIM 2 spec says: ;; "Implementations are encouraged to allow transformations that are not ;; numerically equal due to floating-point roundoff errors to be ;; TRANSFORMATION-EQUAL. An appropriae level of 'fuzziness' is ;; single-float-epsilon, or some small multiple of single-float-epsilon." ;; Note: All the predicates like RIGID-TRANSFORMATION-P, ;; RECTILINEAR-TRANSFORMATION-P etc. inherit the "fuzziness" defined by ;; COORDINATE-EPSILON. An implementation of a medium probably invoke these ;; predicates to decide, whether the graphics primitives provided by the ;; underlying windowing system could be used; or if they have to use an own ;; implementation, which may be much slower, since individual pixels may have to ;; be transferred. So I trade speed for precision here. ;; Of course it would be better to assume some resomable maximal device ;; coordinate for instance 40" * 2400dpi. Now two transformations could be said ;; to be practically equal, if the (rounded) images of any point within that ;; range are equal. ;;;; ---------------------------------------------------------------------------------------------------- ;;;; Transformations ;;;; (defclass standard-transformation (transformation) () (:documentation "All CLIM transformations inherit from this. All transformations of this class should provide a method for GET-TRANSFORMATION, as this is our internal transformation protocol.")) (defclass standard-identity-transformation (standard-transformation) ()) (defparameter +identity-transformation+ (make-instance 'standard-identity-transformation)) (defclass standard-translation (standard-transformation) ((dx :type coordinate :initarg :dx) (dy :type coordinate :initarg :dy))) (defclass cached-inverse-transformation-mixin () ((inverse :type (or null standard-transformation) :initform nil :documentation "Cached inverse transformation."))) (defclass standard-hairy-transformation (standard-transformation cached-inverse-transformation-mixin) ((mxx :type coordinate :initarg :mxx) (mxy :type coordinate :initarg :mxy) (myx :type coordinate :initarg :myx) (myy :type coordinate :initarg :myy) (tx :type coordinate :initarg :tx) (ty :type coordinate :initarg :ty)) (:documentation "A transformation class which is neither the identity nor a translation.")) (defmethod print-object ((self standard-transformation) sink) (print-unreadable-object (self sink :identity nil :type t) (apply #'format sink "~S ~S ~S ~S ~S ~S" (multiple-value-list (get-transformation self))))) (defun make-transformation (mxx mxy myx myy tx ty) ;; Make a transformation, which will map a point (x,y) into ;; x' = mxx*x + mxy*y + tx ;; y' = myx*x + myy*y + ty (let ((mxx (coerce mxx 'coordinate)) (mxy (coerce mxy 'coordinate)) (myx (coerce myx 'coordinate)) (myy (coerce myy 'coordinate)) (tx (coerce tx 'coordinate)) (ty (coerce ty 'coordinate))) (cond ((and (= 1 mxx) (= 0 mxy) (= 0 myx) (= 1 myy)) (cond ((and (= 0 tx) (= 0 ty)) +identity-transformation+) (t (make-translation-transformation tx ty)))) (t (make-instance 'standard-hairy-transformation :mxx mxx :mxy mxy :tx tx :myx myx :myy myy :ty ty))))) (defgeneric get-transformation (transformation) (:documentation "Get the values of the transformation matrix as multiple values. This is not an exported function!")) (defmethod get-transformation ((transformation standard-identity-transformation)) (values 1 0 0 1 0 0)) (defmethod get-transformation ((transformation standard-translation)) (with-slots (dx dy) transformation (values 1 0 0 1 dx dy))) (defmethod get-transformation ((transformation standard-hairy-transformation)) (with-slots (mxx mxy myx myy tx ty) transformation (values mxx mxy myx myy tx ty))) (defun make-translation-transformation (dx dy) (cond ((and (coordinate= dx 0) (coordinate= dy 0)) +identity-transformation+) (t (make-instance 'standard-translation :dx (coordinate dx) :dy (coordinate dy))))) (defun make-rotation-transformation (angle &optional origin) (if origin (make-rotation-transformation* angle (point-x origin) (point-y origin)) (make-rotation-transformation* angle 0 0))) (defun make-rotation-transformation* (angle &optional origin-x origin-y) (let ((origin-x (or origin-x 0)) (origin-y (or origin-y 0))) (let ((s (coerce (sin angle) 'coordinate)) (c (coerce (cos angle) 'coordinate))) ;; This clamping should be done more sensible -- And: is this actually a good thing? (when (coordinate= s 0) (setq s 0)) (when (coordinate= c 0) (setq c 0)) (when (coordinate= s 1) (setq s 1)) (when (coordinate= c 1) (setq c 1)) (when (coordinate= s -1) (setq s -1)) (when (coordinate= c -1) (setq c -1)) ;; Wir stellen uns hier mal ganz dumm: (make-3-point-transformation* origin-x origin-y (+ origin-x 1) origin-y origin-x (+ origin-y 1) origin-x origin-y (+ origin-x c) (+ origin-y s) (- origin-x s) (+ origin-y c)) ))) (defun make-scaling-transformation (scale-x scale-y &optional origin) "MAKE-SCALING-TRANSFORMATION returns a transformation that multiplies the x-coordinate distance of every point from origin by SCALE-X and the y-coordinate distance of every point from origin by SCALE-Y. SCALE-X and SCALE-Y must be real numbers. If ORIGIN is supplied it must be a point; if not supplied it defaults to (0, 0). ORIGIN-X and ORIGIN-Y must be real numbers, and default to 0." (make-scaling-transformation* scale-x scale-y (if origin (point-x origin) 0) (if origin (point-y origin) 0))) (defun make-scaling-transformation* (scale-x scale-y &optional origin-x origin-y) (let ((origin-x (or origin-x 0)) (origin-y (or origin-y 0))) (make-transformation scale-x 0 0 scale-y (- origin-x (* scale-x origin-x)) (- origin-y (* scale-y origin-y)))) ) (defun make-reflection-transformation (point1 point2) (make-reflection-transformation* (point-x point1) (point-y point1) (point-x point2) (point-y point2))) (defun make-reflection-transformation* (x1 y1 x2 y2) (let ((dx (- x2 x1)) (dy (- y2 y1))) (handler-case (make-3-point-transformation* x1 y1 x2 y2 (- x1 dy) (+ y1 dx) x1 y1 x2 y2 (+ x1 dy) (- y1 dx)) (transformation-underspecified (c) (error 'reflection-underspecified :why c :coords (list x1 y1 x2 y2)))))) (defun make-3-point-transformation (point-1 point-2 point-3 point-1-image point-2-image point-3-image) (make-3-point-transformation* (point-x point-1) (point-y point-1) (point-x point-2) (point-y point-2) (point-x point-3) (point-y point-3) (point-x point-1-image) (point-y point-1-image) (point-x point-2-image) (point-y point-2-image) (point-x point-3-image) (point-y point-3-image))) (defun make-3-point-transformation* (x1 y1 x2 y2 x3 y3 x1-image y1-image x2-image y2-image x3-image y3-image) ;; Find a transformation matrix, which transforms each of the three ;; points (x_i, y_i) to its image (y_i_image, y_i_image) ;; ;; Therefore, we have to solve these two linear equations: ;; ;; / x1 y1 1 \ / mxx \ / x1-image \ / myx \ / y1-image \ ;; A:= | x2 y2 1 | ; A | mxy | = | x2-image | and A | myy | = | y2-image | ; ;; \ x3 y3 1 / \ tx / \ x3-image / \ ty / \ y3-image / ;; ;; These matrices are small enough to simply calculate A^-1 = |A|^-1 (adj A). ;; (let ((det (+ (* x1 y2) (* y1 x3) (* x2 y3) (- (* y2 x3)) (- (* y1 x2)) (- (* x1 y3))))) (if (coordinate/= 0 det) (let* ((/det (/ det)) ;; a thru' i is (adj A) (a (- y2 y3)) (b (- y3 y1)) (c (- y1 y2)) (d (- x3 x2)) (e (- x1 x3)) (f (- x2 x1)) (g (- (* x2 y3) (* x3 y2))) (h (- (* x3 y1) (* x1 y3))) (i (- (* x1 y2) (* x2 y1))) ;; calculate 1/|A| * (adj A) * (x1-image x2-image x3-image)^t (mxx (* /det (+ (* a x1-image) (* b x2-image) (* c x3-image)))) (mxy (* /det (+ (* d x1-image) (* e x2-image) (* f x3-image)))) (tx (* /det (+ (* g x1-image) (* h x2-image) (* i x3-image)))) ;; finally 1/|A| * (adj A) * (y1-image y2-image y3-image)^t (myx (* /det (+ (* a y1-image) (* b y2-image) (* c y3-image)))) (myy (* /det (+ (* d y1-image) (* e y2-image) (* f y3-image)))) (ty (* /det (+ (* g y1-image) (* h y2-image) (* i y3-image))))) ;; we're done (make-transformation mxx mxy myx myy tx ty) ) ;; determinant was zero, so signal error (error 'transformation-underspecified :coords (list x1 y1 x2 y2 x3 y3 x1-image y1-image x2-image y2-image x3-image y3-image)) ))) (define-condition transformation-error (error) ()) (define-condition transformation-underspecified (transformation-error) ((coords :initarg :coords :reader transformation-error-coords)) (:report (lambda (self sink) (apply #'format sink "The three points (~D,~D), (~D,~D), and (~D,~D) are propably collinear." (subseq (transformation-error-coords self) 0 6))))) (define-condition reflection-underspecified (transformation-error) ((coords :initarg :coords :reader transformation-error-coords) (why :initarg :why :initform nil :reader transformation-error-why)) (:report (lambda (self sink) (apply #'format sink "The two points (~D,~D) and (~D,~D) are coincident." (transformation-error-coords self)) (when (transformation-error-why self) (format sink " (That was determined by the following error:~%~A)" (transformation-error-why self)))))) (define-condition singular-transformation (transformation-error) ((transformation :initarg :transformation :reader transformation-error-transformation) (why :initarg :why :initform nil :reader transformation-error-why)) (:report (lambda (self sink) (format sink "Attempt to invert the probably singular transformation ~S." (transformation-error-transformation self)) (when (transformation-error-why self) (format sink "~%Another error occurred while computing the inverse:~% ~A" (transformation-error-why self)))))) (define-condition rectangle-transformation-error (transformation-error) ((transformation :initarg :transformation :reader transformation-error-transformation) (rect :initarg :rect :reader transformation-error-rect)) (:report (lambda (self sink) (format sink "Attempt to transform the rectangle ~S through the non-rectilinear transformation ~S." (transformation-error-rect self) (transformation-error-transformation self))))) (defmethod transformation-equal ((transformation1 standard-transformation) (transformation2 standard-transformation)) (every #'coordinate= (multiple-value-list (get-transformation transformation1)) (multiple-value-list (get-transformation transformation2)))) ;; make-transformation always returns +identity-transformation+, if ;; the transformation to be build would be the identity. So we ;; IDENTITY-TRANSFORMATION-P can just specialize on ;; STANDARD-IDENTITY-TRANSFORMATION. (defmethod identity-transformation-p ((transformation standard-identity-transformation)) t) (defmethod identity-transformation-p ((transformation standard-transformation)) nil) ;; Same for translations, but +identity-transformation+ is a translation too. (defmethod translation-transformation-p ((transformation standard-translation)) t) (defmethod translation-transformation-p ((transformation standard-identity-transformation)) t) (defmethod translation-transformation-p ((transformation standard-transformation)) nil) (defun transformation-determinant (tr) (multiple-value-bind (mxx mxy myx myy) (get-transformation tr) (- (* mxx myy) (* mxy myx)))) (defmethod invertible-transformation-p ((transformation standard-transformation)) (coordinate/= 0 (transformation-determinant transformation))) (defmethod reflection-transformation-p ((transformation standard-transformation)) (< (transformation-determinant transformation) 0)) (defmethod rigid-transformation-p ((transformation standard-transformation)) (multiple-value-bind (a b c d) (get-transformation transformation) (and (coordinate= 1 (+ (* a a) (* c c))) ; |A(1,0)| = 1 (coordinate= 1 (+ (* b b) (* d d))) ; |A(0,1)| = 1 (coordinate= 0 (+ (* a b) (* c d)))))) ; (A(1,0))(A(0,1)) = 0 (defmethod even-scaling-transformation-p ((transformation standard-transformation)) (and (scaling-transformation-p transformation) (multiple-value-bind (mxx myx mxy myy) (get-transformation transformation) (declare (ignore mxy myx)) (coordinate= (abs mxx) (abs myy))))) (defmethod scaling-transformation-p ((transformation standard-transformation)) ;; Q: was ist mit dem translationsanteil? ;; what gives (scaling-transformation-p (make-translation-transformation 17 42)) ;; I think it would be strange if (s-t-p (make-s-t* 2 1 1 0)) is not T. -- APD (multiple-value-bind (mxx mxy myx myy tx ty) (get-transformation transformation) (declare (ignore tx ty)) (and (coordinate= 0 mxy) (coordinate= 0 myx) (coordinate/= 0 mxx) (coordinate/= 0 myy)))) ; ? (defmethod rectilinear-transformation-p ((transformation standard-transformation)) ;; Das testen wir einfach ganz brutal ;;; ist das auch richtig? (multiple-value-bind (mxx mxy myx myy) (get-transformation transformation) (or (and (coordinate= mxx 0) (coordinate/= mxy 0) (coordinate/= myx 0) (coordinate= myy 0)) (and (coordinate/= mxx 0) (coordinate= mxy 0) (coordinate= myx 0) (coordinate/= myy 0))))) (defmethod y-inverting-transformation-p ((transformation standard-transformation)) (multiple-value-bind (mxx mxy myx myy) (get-transformation transformation) (and (coordinate= mxx 1) (coordinate= mxy 0) (coordinate= myx 0) (coordinate= myy -1)))) (defmethod compose-transformations ((transformation2 standard-transformation) (transformation1 standard-transformation)) ;; (compose-transformations A B)x = (A o B)x = ABx (multiple-value-bind (a1 b1 d1 e1 c1 f1) (get-transformation transformation1) (multiple-value-bind (a2 b2 d2 e2 c2 f2) (get-transformation transformation2) (make-transformation (+ (* a2 a1) (* b2 d1)) (+ (* a2 b1) (* b2 e1)) (+ (* d2 a1) (* e2 d1)) (+ (* d2 b1) (* e2 e1)) (+ (* a2 c1) (* b2 f1) c2) (+ (* d2 c1) (* e2 f1) f2) )))) (defmethod invert-transformation :around ((transformation cached-inverse-transformation-mixin)) (with-slots (inverse) transformation (or inverse (let ((computed-inverse (call-next-method))) (when (typep computed-inverse 'cached-inverse-transformation-mixin) (setf (slot-value computed-inverse 'inverse) transformation)) (setf inverse computed-inverse) computed-inverse)))) (defmethod invert-transformation ((transformation standard-transformation)) (restart-case (or (handler-case (multiple-value-bind (mxx mxy myx myy tx ty) (get-transformation transformation) (let ((det (- (* mxx myy) (* myx mxy)))) (if (coordinate= 0 det) nil (let ((/det (/ det))) (let ((mxx (* /det myy)) (mxy (* /det (- mxy))) (myx (* /det (- myx))) (myy (* /det mxx))) (make-transformation mxx mxy myx myy (+ (* -1 mxx tx) (* -1 mxy ty)) (+ (* -1 myx tx) (* -1 myy ty)))))))) (error (c) (error 'singular-transformation :why c :transformation transformation))) (error 'singular-transformation :transformation transformation)) (use-value (value) :report (lambda (sink) (format sink "Supply a transformation to use instead of the inverse.")) value))) (defun compose-translation-with-transformation (transformation dx dy) (compose-transformations transformation (make-translation-transformation dx dy))) (defun compose-scaling-with-transformation (transformation sx sy &optional origin) (compose-transformations transformation (make-scaling-transformation sx sy origin))) (defun compose-rotation-with-transformation (transformation angle &optional origin) (compose-transformations transformation (make-rotation-transformation angle origin))) (defun compose-transformation-with-translation (transformation dx dy) (compose-transformations (make-translation-transformation dx dy) transformation)) (defun compose-transformation-with-scaling (transformation sx sy &optional origin) (compose-transformations (make-scaling-transformation sx sy origin) transformation)) (defun compose-transformation-with-rotation (transformation angle &optional origin) (compose-transformations (make-rotation-transformation angle origin) transformation)) (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 origin) &body body) (if sy `(with-drawing-options (,medium :transformation (make-scaling-transformation ,sx ,sy ,@(if origin (list origin) nil))) ,@body) (let ((sx-var (make-symbol "SX"))) `(let* ((,sx-var ,sx)) (with-drawing-options (,medium :transformation (make-scaling-transformation ,sx-var ,sx-var)) ,@body)) ))) (defmacro with-rotation ((medium angle &optional origin) &body body) `(with-drawing-options (,medium :transformation (make-rotation-transformation ,angle ,@(if origin (list origin) nil))) ,@body)) ;;(defmacro with-local-coordinates ((medium &optional x y) &body body)) -- what are local coordinates? ;;(defmacro with-first-quadrant-coordinates ((medium &optional x y) &body body)) (defmacro with-identity-transformation ((medium) &body body) ;; I believe this should set the medium transformation to the identity ;; transformation. To use WITH-DRAWING-OPTIONS which concatenates the the ;; transformation given to the existing one we just pass the inverse. ;; ;; "Further we don't use LETF since it is a pretty much broken idea in case ;; of multithreading." -- gilbert ;; ;; "That may be, but all of the transformation functions/macros are ;; going to set the medium state at some point (see ;; with-drawing-options), and that's not thread-safe either. So I ;; say, 'just use LETF.'" -- moore ;; ;; Q: Do we want a invoke-with-identity-transformation? ;; (let ((medium (stream-designator-symbol medium '*standard-output*))) (gen-invoke-trampoline 'invoke-with-identity-transformation (list medium) nil body))) ;; invoke-with-identity-transformation is gone to graphics.lisp ;; invoke-with-identity-transformation and ;; invoke-with-first-quadrant-coordinates ;; likewise because of the with-drawing-options macro, ;; perhaps we should gather macros in a macros.lisp file? (defmacro with-local-coordinates ((medium &optional x y) &body body) (setf medium (stream-designator-symbol medium '*standard-output*)) (gen-invoke-trampoline 'invoke-with-local-coordinates (list medium) (list x y) body)) (defmacro with-first-quadrant-coordinates ((medium &optional x y) &body body) (setf medium (stream-designator-symbol medium '*standard-output*)) (gen-invoke-trampoline 'invoke-with-first-quadrant-coordinates (list medium) (list x y) body)) (defmethod untransform-region ((transformation transformation) region) (transform-region (invert-transformation transformation) region)) (defmethod transform-position ((transformation standard-transformation) x y) (let ((x (coordinate x)) (y (coordinate y))) (multiple-value-bind (mxx mxy myx myy tx ty) (get-transformation transformation) (declare (type coordinate mxx mxy myx myy tx ty)) (values (+ (* mxx x) (* mxy y) tx) (+ (* myx x) (* myy y) ty))))) (defmethod untransform-position ((transformation transformation) x y) (transform-position (invert-transformation transformation) x y)) (defmethod transform-distance ((transformation standard-transformation) dx dy) (let ((dx (coordinate dx)) (dy (coordinate dy))) (multiple-value-bind (mxx mxy myx myy) (get-transformation transformation) (declare (type coordinate mxx mxy myx myy)) (values (+ (* mxx dx) (* mxy dy)) (+ (* myx dx) (* myy dy)))))) (defmethod untransform-distance ((transformation transformation) dx dy) (transform-distance (invert-transformation transformation) dx dy)) (defun transform-positions (transformation coord-seq) ;; Some appliations (like a function graph plotter) use a large number of ;; coordinates, therefore we bother optimizing this. We do this by testing ;; the individual elements of the transformation matrix for being 0 or +1 or ;; -1 as these are common cases as most transformations are either mere ;; translations or just scalings. ;; ;; Also: For now we always return a vector. ;; (cond ((eql transformation +identity-transformation+) coord-seq) (t (multiple-value-bind (mxx mxy myx myy tx ty) (climi::get-transformation transformation) (declare (type coordinate mxx mxy myx myy tx ty)) (macrolet ((do-transform () `(progn (cond ((zerop mxx)) ((= mxx +1) (for-coord-seq (setf res.x x))) ((= mxx -1) (for-coord-seq (setf res.x (- x)))) (t (for-coord-seq (setf res.x (* mxx x))))) (cond ((zerop myy)) ((= myy +1) (for-coord-seq (setf res.y y))) ((= myy -1) (for-coord-seq (setf res.y (- y)))) (t (for-coord-seq (setf res.y (* myy y))))) (unless (and (zerop mxy) (zerop myx)) (for-coord-seq (incf res.x (* mxy y)) (incf res.y (* myx x)))) (unless (and (zerop tx) (zerop ty)) (for-coord-seq (incf res.x tx) (incf res.y ty)))))) (macrolet ((do-on-vector () `(let* ((n (length coord-seq)) (res (make-array n :initial-element 0))) (declare (type simple-vector res)) (macrolet ((for-coord-seq (&rest body) `(loop for i of-type fixnum below n by 2 do (let ((x (aref coord-seq i)) (y (aref coord-seq (+ i 1)))) (declare (ignorable x y)) (symbol-macrolet ((res.x (aref res i)) (res.y (aref res (+ i 1)))) ,@body))))) (do-transform)) res)) (do-on-list () `(let* ((n (length coord-seq)) (res (make-array n :initial-element 0))) (declare (type simple-vector res)) (macrolet ((for-coord-seq (&rest body) `(loop for i of-type fixnum below n by 2 for q on coord-seq by #'cddr do (let ((x (car q)) (y (cadr q))) (declare (ignorable x y)) (symbol-macrolet ((res.x (aref res i)) (res.y (aref res (+ i 1)))) ,@body))))) (do-transform)) res))) (cond ((typep coord-seq 'simple-vector) (locally (declare (type simple-vector coord-seq)) (do-on-vector))) ((typep coord-seq 'vector) (locally (declare (type vector coord-seq)) (do-on-vector))) ((typep coord-seq 'list) (locally (declare (type list coord-seq)) (do-on-list))) (t (error "~S is not a sequence." coord-seq)) ))))))) (defun transform-position-sequence (seq-type transformation coord-seq) (cond ((subtypep seq-type 'vector) (transform-positions transformation coord-seq)) (t (map-repeated-sequence seq-type 2 (lambda (x y) (transform-position transformation x y)) coord-seq)))) (defmethod transform-rectangle* ((transformation transformation) x1 y1 x2 y2) (if (rectilinear-transformation-p transformation) (multiple-value-bind (x1 y1) (transform-position transformation x1 y1) (multiple-value-bind (x2 y2) (transform-position transformation x2 y2) (values (min x1 x2) (min y1 y2) (max x1 x2) (max y1 y2)))) (error 'rectangle-transformation-error :transformation transformation :rect (list x1 y2 x2 y2)))) (defmethod untransform-rectangle* ((transformation transformation) x1 y1 x2 y2) (transform-rectangle* (invert-transformation transformation) x1 y1 x2 y2)) (defmethod transformation-transformator ((transformation standard-transformation) &optional (input-type 'real)) ;; returns a function, which transforms its arguments (multiple-value-bind (mxx mxy myx myy tx ty) (get-transformation transformation) (labels ((s* (x y) (cond ((coordinate= 0 x) nil) ((coordinate= 1 x) (list y)) ((coordinate= -1 x) (list `(- ,y))) ((list `(* ,x ,y))))) (s+ (args) (cond ((null args) (coerce 0 'coordinate)) ((null (cdr args)) (car args)) (t `(+ .,args))))) (compile nil `(lambda (x y) (declare (ignorable x y) (type ,input-type x y) (optimize (speed 3) (space 0) (safety 0))) (values ,(s+ (nconc (s* mxx 'x) (s* mxy 'y) (if (coordinate/= 0 tx) (list tx) nil))) ,(s+ (nconc (s* myx 'x) (s* myy 'y) (if (coordinate/= 0 ty) (list ty) nil))))) )))) (defmethod transformation-transformator ((transformation transformation) &optional (input-type 'real)) (declare (ignore input-type)) #'(lambda (x y) (transform-position transformation x y))) (defun atan* (x y) ;; atan so, wie wir es brauchen. ;; Bei uns ist phi=0 entlang der x-axis und Winkel sind immer zwischen 0 und 2pi. (let ((r (atan y x))) (if (< r 0) (+ r (* 2 pi)) r))) (defun correct-angle (a phi) (if (< a phi) (+ a (* 2 pi)) a)) (defun transform-angle (transformation phi) (multiple-value-bind (rotations remainder) (ffloor phi (* 2 pi)) (when (reflection-transformation-p transformation) (setq rotations (ffloor (- phi) (* 2 pi)))) (multiple-value-bind (ix iy) (transform-distance transformation (cos remainder) (sin remainder)) (multiple-value-bind (x0 y0) (transform-distance transformation 1 0) (let ((my-angle (atan* ix iy)) (null-angle (atan* x0 y0))) (+ (* rotations 2 pi) (correct-angle my-angle null-angle))))))) (defun untransform-angle (transformation phi) (multiple-value-bind (rotations remainder) (ffloor phi (* 2 pi)) (when (reflection-transformation-p transformation) (setq rotations (ffloor (- phi) (* 2 pi)))) (multiple-value-bind (ix iy) (untransform-distance transformation (cos remainder) (sin remainder)) (multiple-value-bind (x0 y0) (untransform-distance transformation 1 0) (let ((my-angle (atan* ix iy)) (null-angle (atan* x0 y0))) (+ (* rotations 2 pi) (correct-angle my-angle null-angle))))))) ;;;; Methods on special transformations for performance. (defmethod compose-transformations ((transformation2 standard-translation) (transformation1 standard-translation)) ;; (compose-transformations A B)x = (A o B)x = ABx (with-slots ((dx1 dx) (dy1 dy)) transformation1 (with-slots ((dx2 dx) (dy2 dy)) transformation2 (make-translation-transformation (+ dx1 dx2) (+ dy1 dy2))))) (defmethod compose-transformations (transformation2 (transformation1 standard-identity-transformation)) transformation2) (defmethod compose-transformations ((transformation2 standard-identity-transformation) transformation1) transformation1) (defmethod invert-transformation ((transformation standard-identity-transformation)) transformation) (defmethod invert-transformation ((transformation standard-translation)) (with-slots (dx dy) transformation (make-translation-transformation (- dx) (- dy)))) (defmethod transform-position ((transformation standard-translation) x y) (with-slots (dx dy) transformation (let ((x (coordinate x)) (y (coordinate y))) (declare (type coordinate dx dy x y)) (values (+ x dx) (+ y dy))))) (defmethod transform-position ((transformation standard-identity-transformation) x y) (values x y)) (defmethod transform-region ((transformation standard-identity-transformation) region) region) (defmethod rectilinear-transformation-p ((tr standard-identity-transformation)) t) (defmethod rectilinear-transformation-p ((tr standard-translation)) t) (defmethod scaling-transformation-p ((tr standard-translation)) t) (defmethod scaling-transformation-p ((tr standard-identity-transformation)) t) (defmethod transformation-equal ((t1 standard-identity-transformation) (t2 standard-identity-transformation)) t) (defmethod transformation-equal ((t1 standard-identity-transformation) (t2 t)) nil) (defmethod transformation-equal ((t2 t) (t1 standard-identity-transformation)) nil) (defmethod transformation-equal ((t1 standard-translation) (t2 standard-translation)) (with-slots ((dx1 dx) (dy1 dy)) t1 (with-slots ((dx2 dx) (dy2 dy)) t2 (and (coordinate= dx1 dx2) (coordinate= dy1 dy2))))) (defmethod transformation-equal ((t1 standard-translation) (t2 t)) nil) (defmethod transformation-equal ((t2 t) (t1 standard-translation)) nil) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/recording.lisp0000644000175000017500000031125711345155772017667 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 1998,1999,2000,2001 by Michael McDonald (mikemac@mikemac.com) ;;; (c) copyright 2000 by ;;; Robert Strandh (strandh@labri.u-bordeaux.fr) ;;; (c) copyright 2001 by ;;; Arnaud Rouanet (rouanet@emi.u-bordeaux.fr) ;;; Lionel Salabartan (salabart@emi.u-bordeaux.fr) ;;; (c) copyright 2001, 2002 by Alexey Dejneka (adejneka@comail.ru) ;;; (c) copyright 2003 by Gilbert Baumann ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; TODO: ;;; ;;; - Scrolling does not work correctly. Region is given in "window" ;;; coordinates, without bounding-rectangle-position transformation. ;;; (Is it still valid?) ;;; ;;; - Redo setf*-output-record-position, extent recomputation for ;;; compound records ;;; ;;; - When DRAWING-P is NIL, should stream cursor move? ;;; ;;; - :{X,Y}-OFFSET. ;;; ;;; - (SETF OUTPUT-RECORD-START-CURSOR-POSITION) does not affect the ;;; bounding rectangle. What does it affect? ;;; ;;; - How should (SETF OUTPUT-RECORD-POSITION) affect the bounding ;;; rectangle of the parent? Now its bounding rectangle is accurately ;;; recomputed, but it is very inefficient for table formatting. It ;;; seems that CLIM is supposed to keep a "large enougn" rectangle and ;;; to shrink it to the correct size only when the layout is complete ;;; by calling TREE-RECOMPUTE-EXTENT. ;;; ;;; - Computation of the bounding rectangle of lines/polygons ignores ;;; LINE-STYLE-CAP-SHAPE. ;;; ;;; - Rounding of coordinates. ;;; ;;; - Document carefully the interface of ;;; STANDARD-OUTPUT-RECORDING-STREAM. ;;; ;;; - COORD-SEQ is a sequence, not a list. ;;; Troubles ;;; DC ;;; ;;; Some GFs are defined to have "a default method on CLIM's standard ;;; output record class". What does it mean? What is "CLIM's standard ;;; output record class"? Is it OUTPUT-RECORD or BASIC-OUTPUT-RECORD? ;;; Now they are defined on OUTPUT-RECORD. (in-package :clim-internals) ;;; 16.2.1. The Basic Output Record Protocol #+:cmu(declaim (ftype (function (output-record) (values rational rational)) output-record-position)) ;; XXX What does #+:CMU mean? FTYPE was excluded from ANSI CL? Other ;; compilers try to check type declarations? (defgeneric output-record-position (record) (:documentation "Returns the x and y position of RECORD. The position is the position of the upper-left corner of its bounding rectangle. The position is relative to the stream, where (0,0) is (initially) the upper-left corner of the stream.")) (defgeneric* (setf output-record-position) (x y record) (:documentation "Changes the x and y position of the RECORD to be X and Y, and updates the bounding rectangle to reflect the new position (and saved cursor positions, if the output record stores it). If RECORD has any children, all of the children (and their descendants as well) will be moved by the same amount as RECORD was moved. The bounding rectangles of all of RECORD's ancestors will also be updated to be large enough to contain RECORD.")) #+:cmu(declaim (ftype (function (output-record) (values integer integer)) output-record-start-cursor-position)) (defgeneric output-record-start-cursor-position (record) (:documentation "Returns the x and y starting cursor position of RECORD. The positions are relative to the stream, where (0,0) is (initially) the upper-left corner of the stream.")) (defgeneric* (setf output-record-start-cursor-position) (x y record)) #+:cmu(declaim (ftype (function (output-record) (values integer integer)) output-record-end-cursor-position)) (defgeneric output-record-end-cursor-position (record) (:documentation "Returns the x and y ending cursor position of RECORD. The positions are relative to the stream, where (0,0) is (initially) the upper-left corner of the stream.")) (defgeneric* (setf output-record-end-cursor-position) (x y record)) (defgeneric output-record-parent (record) (:documentation "Returns the output record that is the parent of RECORD, or NIL if RECORD has no parent.")) (defgeneric (setf output-record-parent) (parent record) (:documentation "Non-standard function.")) (defgeneric replay-output-record (record stream &optional region x-offset y-offset) (:documentation "Displays the output captured by RECORD on the STREAM, exactly as it was originally captured. The current user transformation, line style, text style, ink and clipping region of STREAM are all ignored. Instead, these are gotten from the output record. Only those records that overlap REGION are displayed.")) (defgeneric output-record-hit-detection-rectangle* (record)) (defgeneric output-record-refined-position-test (record x y)) (defgeneric highlight-output-record (record stream state)) (defgeneric displayed-output-record-ink (displayed-output-record)) ;;; 16.2.2. Output Record "Database" Protocol (defgeneric output-record-children (record)) (defgeneric add-output-record (child record)) (defgeneric delete-output-record (child record &optional errorp)) (defgeneric clear-output-record (record)) (defgeneric output-record-count (record)) (defgeneric map-over-output-records-containing-position (function record x y &optional x-offset y-offset &rest function-args) (:documentation "Maps over all of the children of RECORD that contain the point at (X,Y), calling FUNCTION on each one. FUNCTION is a function of one or more arguments, the first argument being the record containing the point. FUNCTION is also called with all of FUNCTION-ARGS as APPLY arguments. If there are multiple records that contain the point, MAP-OVER-OUTPUT-RECORDS-CONTAINING-POSITION hits the most recently inserted record first and the least recently inserted record last. Otherwise, the order in which the records are traversed is unspecified.")) (defgeneric map-over-output-records-overlapping-region (function record region &optional x-offset y-offset &rest function-args) (:documentation "Maps over all of the children of the RECORD that overlap the REGION, calling FUNCTION on each one. FUNCTION is a function of one or more arguments, the first argument being the record overlapping the region. FUNCTION is also called with all of FUNCTION-ARGS as APPLY arguments. If there are multiple records that overlap the region and that overlap each other, MAP-OVER-OUTPUT-RECORDS-OVERLAPPING-REGION hits the least recently inserted record first and the most recently inserted record last. Otherwise, the order in which the records are traversed is unspecified. ")) ;;; From the Franz CLIM user's guide but not in the spec... clearly necessary. (defgeneric map-over-output-records-1 (continuation record continuation-args)) (defun map-over-output-records (continuation record &optional x-offset y-offset &rest continuation-args) (declare (ignore x-offset y-offset)) (map-over-output-records-1 continuation record continuation-args)) ;;; 16.2.3. Output Record Change Notification Protocol (defgeneric recompute-extent-for-new-child (record child)) (defgeneric recompute-extent-for-changed-child (record child old-min-x old-min-y old-max-x old-max-y)) (defgeneric tree-recompute-extent (record)) ;;; 21.3 Incremental Redisplay Protocol. These generic functions need ;;; to be implemented for all the basic displayed-output-records, so they are ;;; defined in this file. ;;; ;;; match-output-records and find-child-output-record, as defined in ;;; the CLIM spec, are pretty silly. How does incremental redisplay know ;;; what keyword arguments to supply to find-child-output-record? Through ;;; a gf specialized on the type of the record it needs to match... why ;;; not define the search function and the predicate on two records then! ;;; ;;; We'll implement match-output-records and find-child-output-record, ;;; but we won't actually use them. Instead, output-record-equal will ;;; match two records, and find-child-record-equal will search for the ;;; equivalent record. (defgeneric match-output-records (record &rest args)) ;;; These gf's use :most-specific-last because one of the least ;;; specific methods will check the bounding boxes of the records, which ;;; should cause an early out most of the time. (defgeneric match-output-records-1 (record &key) (:method-combination and :most-specific-last)) (defgeneric output-record-equal (record1 record2) (:method-combination and :most-specific-last)) (defmethod output-record-equal :around (record1 record2) (cond ((eq record1 record2) ;; Some unusual record -- like a Goatee screen line -- might ;; exist in two trees at once t) ((eq (class-of record1) (class-of record2)) (let ((result (call-next-method))) (if (eq result 'maybe) nil result))) (t nil))) ;;; A fallback method so that something's always applicable. (defmethod output-record-equal and (record1 record2) (declare (ignore record1 record2)) 'maybe) ;;; The code for match-output-records-1 and output-record-equal ;;; methods are very similar, hence this macro. In order to exploit ;;; the similarities, it's necessary to treat the slots of the second ;;; record like variables, so for convenience the macro will use ;;; slot-value on both records. (defmacro defrecord-predicate (record-type slots &body body) "Each element of SLOTS is either a symbol or (:initarg-name slot-name)." (let* ((slot-names (mapcar #'(lambda (slot-spec) (if (consp slot-spec) (cadr slot-spec) slot-spec)) slots)) (supplied-vars (mapcar #'(lambda (slot) (gensym (symbol-name (symbol-concat slot '#:-p)))) slot-names)) (key-args (mapcar #'(lambda (slot-spec supplied) `(,slot-spec nil ,supplied)) slots supplied-vars)) (key-arg-alist (mapcar #'cons slot-names supplied-vars))) `(progn (defmethod output-record-equal and ((record ,record-type) (record2 ,record-type)) (macrolet ((if-supplied ((var &optional (type t)) &body supplied-body) (declare (ignore var type)) `(progn ,@supplied-body))) (with-slots ,slot-names record2 ,@body))) (defmethod match-output-records-1 and ((record ,record-type) &key ,@key-args) (macrolet ((if-supplied ((var &optional (type t)) &body supplied-body) (let ((supplied-var (cdr (assoc var ',key-arg-alist)))) (unless supplied-var (error "Unknown slot ~S" var)) `(or (null ,supplied-var) ,@(if (eq type t) `((progn ,@supplied-body)) `((if (typep ,var ',type) (progn ,@supplied-body) (error 'type-error :datum ,var :expected-type ',type)))))))) ,@body))) )) ;;; Macros (defmacro with-output-recording-options ((stream &key (record nil record-supplied-p) (draw nil draw-supplied-p)) &body body) (setq stream (stream-designator-symbol stream '*standard-output*)) (with-gensyms (continuation) `(flet ((,continuation (,stream) ,(declare-ignorable-form* stream) ,@body)) (declare (dynamic-extent #',continuation)) (invoke-with-output-recording-options ,stream #',continuation ,(if record-supplied-p record `(stream-recording-p ,stream)) ,(if draw-supplied-p draw `(stream-drawing-p ,stream)))))) ;;; Macro masturbation... (defmacro define-invoke-with (macro-name func-name record-type doc-string) `(defmacro ,macro-name ((stream &optional (record-type '',record-type) (record (gensym)) &rest initargs) &body body) ,doc-string (setq stream (stream-designator-symbol stream '*standard-output*)) (with-gensyms (constructor continuation) (multiple-value-bind (bindings m-i-args) (rebind-arguments initargs) `(let ,bindings (flet ((,constructor () (make-instance ,record-type ,@m-i-args)) (,continuation (,stream ,record) ,(declare-ignorable-form* stream record) ,@body)) (declare (dynamic-extent #',constructor #',continuation)) (,',func-name ,stream #',continuation ,record-type #',constructor ,@m-i-args))))))) (define-invoke-with with-new-output-record invoke-with-new-output-record standard-sequence-output-record "Creates a new output record of type RECORD-TYPE and then captures the output of BODY into the new output record, and inserts the new record into the current \"open\" output record assotiated with STREAM. If RECORD is supplied, it is the name of a variable that will be lexically bound to the new output record inside the body. INITARGS are CLOS initargs that are passed to MAKE-INSTANCE when the new output record is created. It returns the created output record. The STREAM argument is a symbol that is bound to an output recording stream. If it is T, *STANDARD-OUTPUT* is used.") (define-invoke-with with-output-to-output-record invoke-with-output-to-output-record standard-sequence-output-record "Creates a new output record of type RECORD-TYPE and then captures the output of BODY into the new output record. The cursor position of STREAM is initially bound to (0,0) If RECORD is supplied, it is the name of a variable that will be lexically bound to the new output record inside the body. INITARGS are CLOS initargs that are passed to MAKE-INSTANCE when the new output record is created. It returns the created output record. The STREAM argument is a symbol that is bound to an output recording stream. If it is T, *STANDARD-OUTPUT* is used.") ;;;; Implementation (defclass basic-output-record (standard-bounding-rectangle output-record) ((parent :initarg :parent ; XXX :initform nil :accessor output-record-parent)) ; XXX (:documentation "Implementation class for the Basic Output Record Protocol.")) (defmethod initialize-instance :after ((record basic-output-record) &key (x-position 0.0d0) (y-position 0.0d0)) (setf (rectangle-edges* record) (values x-position y-position x-position y-position))) ;;; XXX I'd really like to get rid of the x and y slots. They are surely ;;; redundant with the bounding rectangle coordinates. (defclass compound-output-record (basic-output-record) ((x :initarg :x-position :initform 0.0d0 :documentation "X-position of the empty record.") (y :initarg :y-position :initform 0.0d0 :documentation "Y-position of the empty record.") (in-moving-p :initform nil :documentation "Is set while changing the position.")) (:documentation "Implementation class for output records with children.")) ;;; 16.2.1. The Basic Output Record Protocol (defmethod output-record-position ((record basic-output-record)) (bounding-rectangle-position record)) (defmethod* (setf output-record-position) (nx ny (record basic-output-record)) (with-standard-rectangle (x1 y1 x2 y2) record (let ((dx (- nx x1)) (dy (- ny y1))) (setf (rectangle-edges* record) (values nx ny (+ x2 dx) (+ y2 dy))))) (values nx ny)) (defmethod* (setf output-record-position) :around (nx ny (record basic-output-record)) (with-bounding-rectangle* (min-x min-y max-x max-y) record (call-next-method) (let ((parent (output-record-parent record))) (when (and parent (not (and (typep parent 'compound-output-record) (slot-value parent 'in-moving-p)))) ; XXX (recompute-extent-for-changed-child parent record min-x min-y max-x max-y))) (values nx ny))) (defmethod* (setf output-record-position) :before (nx ny (record compound-output-record)) (with-standard-rectangle* (:x1 x1 :y1 y1) record (letf (((slot-value record 'in-moving-p) t)) (let ((dx (- nx x1)) (dy (- ny y1))) (map-over-output-records (lambda (child) (multiple-value-bind (x y) (output-record-position child) (setf (output-record-position child) (values (+ x dx) (+ y dy))))) record))))) (defmethod output-record-start-cursor-position ((record basic-output-record)) (values nil nil)) (defmethod* (setf output-record-start-cursor-position) (x y (record basic-output-record)) (values x y)) (defmethod output-record-end-cursor-position ((record basic-output-record)) (values nil nil)) (defmethod* (setf output-record-end-cursor-position) (x y (record basic-output-record)) (values x y)) #+cmu (progn ;; Sometimes CMU's PCL fails with forward reference classes, so this ;; is a kludge to keep it happy. ;; ;; This was reported as a bug to cmucl-imp [] ;; ;; In short it exposes itself when you compile and load into a ;; _virgin_ lisp the following: ;; ;; (defclass foo (bar) ()) ;; (defun barz () (make-instance 'foo)) ;; (defclass bar () ()) ;; ;; --GB 2003-03-18 ;; (defclass gs-ink-mixin () ()) (defclass gs-clip-mixin () ()) (defclass gs-line-style-mixin () ()) (defclass gs-text-style-mixin () ())) ;;; Humph. It'd be nice to tie this to the actual definition of a ;;; medium. -- moore (defclass complete-medium-state (gs-ink-mixin gs-clip-mixin gs-line-style-mixin gs-text-style-mixin) ()) (defun replay (record stream &optional (region (or (pane-viewport-region stream) (sheet-region stream)))) (if (typep stream 'encapsulating-stream) (replay record (encapsulating-stream-stream stream) region) (progn (stream-close-text-output-record stream) (when (stream-drawing-p stream) (with-cursor-off stream ;;FIXME? (letf (((stream-cursor-position stream) (values 0 0)) ((stream-recording-p stream) nil) ;; Is there a better value to bind to baseline? ((slot-value stream 'baseline) (slot-value stream 'baseline))) (with-sheet-medium (medium stream) (let ((transformation (medium-transformation medium))) (unwind-protect (progn (setf (medium-transformation medium) +identity-transformation+) (replay-output-record record stream region)) (setf (medium-transformation medium) transformation)))))))))) (defmethod replay-output-record ((record compound-output-record) stream &optional region (x-offset 0) (y-offset 0)) (when (null region) (setq region (or (pane-viewport-region stream) +everywhere+))) (with-drawing-options (stream :clipping-region region) (map-over-output-records-overlapping-region #'replay-output-record record region x-offset y-offset stream region x-offset y-offset))) (defmethod output-record-hit-detection-rectangle* ((record output-record)) ;; XXX DC (bounding-rectangle* record)) (defmethod output-record-refined-position-test ((record basic-output-record) x y) (declare (ignore x y)) t) (defun highlight-output-record-rectangle (record stream state) (with-identity-transformation (stream) (multiple-value-bind (x1 y1 x2 y2) (output-record-hit-detection-rectangle* record) (ecase state (:highlight (draw-rectangle* (sheet-medium stream) x1 y1 (1- x2) (1- y2) :filled nil :ink +foreground-ink+)) ; XXX +FLIPPING-INK+? (:unhighlight ;; FIXME: repaint the hit detection rectangle. It could be bigger than ;; the bounding rectangle. (repaint-sheet stream record) ;; Using queue-repaint should be faster in apps (such as clouseau) that ;; highlight/unhighlight many bounding rectangles at once. The event ;; code should merge these into a single larger repaint. Unfortunately, ;; since an enqueued repaint does not occur immediately, and highlight ;; rectangles are not recorded, newer highlighting gets wiped out ;; shortly after being drawn. So, we aren't ready for this yet. ;; ..Actually, it isn't necessarily faster. Depends on the app. #+NIL (queue-repaint stream (make-instance 'window-repaint-event :sheet stream :region (transform-region (sheet-native-transformation stream) record)))))))) ;;; XXX Should this only be defined on recording streams? (defmethod highlight-output-record ((record output-record) stream state) ;; XXX DC ;; XXX Disable recording? (highlight-output-record-rectangle record stream state)) ;;; 16.2.2. The Output Record "Database" Protocol ;; These two aren't in the spec, but are needed to make indirect adding/deleting ;; of GADGET-OUTPUT-RECORDs work: (defgeneric note-output-record-lost-sheet (record sheet)) (defgeneric note-output-record-got-sheet (record sheet)) (defmethod note-output-record-lost-sheet ((record output-record) sheet) (declare (ignore record sheet)) (values)) (defmethod note-output-record-lost-sheet :after ((record compound-output-record) sheet) (map-over-output-records #'note-output-record-lost-sheet record 0 0 sheet)) (defmethod note-output-record-got-sheet ((record output-record) sheet) (declare (ignore record sheet)) (values)) (defmethod note-output-record-got-sheet :after ((record compound-output-record) sheet) (map-over-output-records #'note-output-record-got-sheet record 0 0 sheet)) (defun find-output-record-sheet (record) "Walks up the parents of RECORD, searching for an output history from which the associated sheet can be determined." (typecase record (stream-output-history-mixin (output-history-stream record)) (basic-output-record (find-output-record-sheet (output-record-parent record))))) (defmethod output-record-children ((record basic-output-record)) nil) (defmethod add-output-record (child (record basic-output-record)) (declare (ignore child)) (error "Cannot add a child to ~S." record)) (defmethod add-output-record :before (child (record compound-output-record)) (let ((parent (output-record-parent child))) (cond (parent (restart-case (error "~S already has a parent ~S." child parent) (delete () :report "Delete from the old parent." (delete-output-record child parent)))) ((eq record child) (error "~S is being added to itself" record)) ((eq (output-record-parent record) child) (error "child ~S is being added to its own child ~S" child record))))) (defmethod add-output-record :after (child (record compound-output-record)) (recompute-extent-for-new-child record child) (when (eq record (output-record-parent child)) (let ((sheet (find-output-record-sheet record))) (when sheet (note-output-record-got-sheet child sheet))))) (defmethod delete-output-record :before (child (record basic-output-record) &optional (errorp t)) (declare (ignore errorp)) (let ((sheet (find-output-record-sheet record))) (when sheet (note-output-record-lost-sheet child sheet)))) (defmethod delete-output-record (child (record basic-output-record) &optional (errorp t)) (declare (ignore child)) (when errorp (error "Cannot delete a child from ~S." record))) (defmethod delete-output-record :after (child (record compound-output-record) &optional (errorp t)) (declare (ignore errorp)) (with-bounding-rectangle* (x1 y1 x2 y2) child (recompute-extent-for-changed-child record child x1 y1 x2 y2))) (defmethod clear-output-record ((record basic-output-record)) (error "Cannot clear ~S." record)) (defmethod clear-output-record :before ((record compound-output-record)) (let ((sheet (find-output-record-sheet record))) (when sheet (map-over-output-records #'note-output-record-lost-sheet record 0 0 sheet)))) (defmethod clear-output-record :around ((record compound-output-record)) (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* record) (call-next-method) (assert (null-bounding-rectangle-p record)) (when (output-record-parent record) (recompute-extent-for-changed-child (output-record-parent record) record x1 y1 x2 y2)))) (defmethod clear-output-record :after ((record compound-output-record)) ;; XXX banish x and y (with-slots (x y) record (setf (rectangle-edges* record) (values x y x y)))) (defmethod output-record-count ((record displayed-output-record)) 0) (defmethod map-over-output-records-1 (function (record displayed-output-record) function-args) (declare (ignore function function-args)) nil) ;;; This needs to work in "most recently added last" order. Is this ;;; implementation right? -- APD, 2002-06-13 #+nil (defmethod map-over-output-records (function (record compound-output-record) &optional (x-offset 0) (y-offset 0) &rest function-args) (declare (ignore x-offset y-offset)) (map nil (lambda (child) (apply function child function-args)) (output-record-children record))) (defmethod map-over-output-records-containing-position (function (record displayed-output-record) x y &optional (x-offset 0) (y-offset 0) &rest function-args) (declare (ignore function x y x-offset y-offset function-args)) nil) ;;; This needs to work in "most recently added first" order. Is this ;;; implementation right? -- APD, 2002-06-13 #+nil (defmethod map-over-output-records-containing-position (function (record compound-output-record) x y &optional (x-offset 0) (y-offset 0) &rest function-args) (declare (ignore x-offset y-offset)) (map nil (lambda (child) (when (and (multiple-value-bind (min-x min-y max-x max-y) (output-record-hit-detection-rectangle* child) (and (<= min-x x max-x) (<= min-y y max-y))) (output-record-refined-position-test child x y)) (apply function child function-args))) (output-record-children record))) (defmethod map-over-output-records-overlapping-region (function (record displayed-output-record) region &optional (x-offset 0) (y-offset 0) &rest function-args) (declare (ignore function region x-offset y-offset function-args)) nil) ;;; This needs to work in "most recently added last" order. Is this ;;; implementation right? -- APD, 2002-06-13 #+nil (defmethod map-over-output-records-overlapping-region (function (record compound-output-record) region &optional (x-offset 0) (y-offset 0) &rest function-args) (declare (ignore x-offset y-offset)) (map nil (lambda (child) (when (region-intersects-region-p region child) (apply function child function-args))) (output-record-children record))) ;;; XXX Dunno about this definition... -- moore ;;; Your apprehension is justified, but we lack a better means by which ;;; to distinguish "empty" compound records (roots of trees of compound ;;; records, containing no non-compound records). Such subtrees should ;;; not affect bounding rectangles. -- Hefner (defun null-bounding-rectangle-p (bbox) (with-bounding-rectangle* (x1 y1 x2 y2) bbox (and (= x1 x2) (= y1 y2)))) ;;; 16.2.3. Output Record Change Notification Protocol (defmethod recompute-extent-for-new-child ((record compound-output-record) child) (unless (null-bounding-rectangle-p child) (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record (cond ((null-bounding-rectangle-p record) (setf (rectangle-edges* record) (bounding-rectangle* child))) ((not (null-bounding-rectangle-p child)) (assert (not (null-bounding-rectangle-p record))) ; important. (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) child (setf (rectangle-edges* record) (values (min old-x1 x1-child) (min old-y1 y1-child) (max old-x2 x2-child) (max old-y2 y2-child)))))) (let ((parent (output-record-parent record))) (when parent (recompute-extent-for-changed-child parent record old-x1 old-y1 old-x2 old-y2))))) record) (defmethod %tree-recompute-extent* ((record compound-output-record)) ;; Internal helper function (let ((new-x1 0) (new-y1 0) (new-x2 0) (new-y2 0) (first-time t)) (map-over-output-records (lambda (child) (unless (null-bounding-rectangle-p child) (if first-time (progn (multiple-value-setq (new-x1 new-y1 new-x2 new-y2) (bounding-rectangle* child)) (setq first-time nil)) (with-bounding-rectangle* (cx1 cy1 cx2 cy2) child (minf new-x1 cx1) (minf new-y1 cy1) (maxf new-x2 cx2) (maxf new-y2 cy2))))) record) (if first-time ;; XXX banish x y (with-slots (x y) record (values x y x y)) (values new-x1 new-y1 new-x2 new-y2)))) (defgeneric tree-recompute-extent-aux (record)) (defmethod tree-recompute-extent-aux (record) (bounding-rectangle* record)) (defmethod tree-recompute-extent-aux ((record compound-output-record)) (let ((new-x1 0) (new-y1 0) (new-x2 0) (new-y2 0) (first-time t)) (map-over-output-records (lambda (child) (if first-time (progn (multiple-value-setq (new-x1 new-y1 new-x2 new-y2) (tree-recompute-extent-aux child)) (setq first-time nil)) (multiple-value-bind (cx1 cy1 cx2 cy2) (tree-recompute-extent-aux child) (minf new-x1 cx1) (minf new-y1 cy1) (maxf new-x2 cx2) (maxf new-y2 cy2)))) record) (with-slots (x y) record (if first-time ;No children (bounding-rectangle* record) (progn ;; XXX banish x,y (setf x new-x1 y new-y1) (setf (rectangle-edges* record) (values new-x1 new-y1 new-x2 new-y2))))))) (defmethod recompute-extent-for-changed-child ((record compound-output-record) changed-child old-min-x old-min-y old-max-x old-max-y) (with-bounding-rectangle* (ox1 oy1 ox2 oy2) record (with-bounding-rectangle* (cx1 cy1 cx2 cy2) changed-child ;; If record is currently empty, use the child's bbox directly. Else.. ;; Does the new rectangle of the child contain the original rectangle? ;; If so, we can use min/max to grow record's current rectangle. ;; If not, the child has shrunk, and we need to fully recompute. (multiple-value-bind (nx1 ny1 nx2 ny2) (cond ;; The child has been deleted; who knows what the ;; new bounding box might be. ;; This case shouldn't be really necessary. ((not (output-record-parent changed-child)) (%tree-recompute-extent* record)) ;; Only one child of record, and we already have the bounds. ((eql (output-record-count record) 1) ;; See output-record-children for why this assert breaks: ;; (assert (eq changed-child (elt (output-record-children record) 0))) (values cx1 cy1 cx2 cy2)) ;; If our record occupied no space (had no children, or had only ;; children similarly occupying no space, hackishly determined by ;; null-bounding-rectangle-p), recompute the extent now, otherwise ;; the next COND clause would, as an optimization, attempt to extend ;; our current bounding rectangle, which is invalid. ((null-bounding-rectangle-p record) (%tree-recompute-extent* record)) ;; In the following cases, we can grow the new bounding rectangle ;; from its previous state: ((or ;; If the child was originally empty, it could not have affected ;; previous computation of our bounding rectangle. ;; This is hackish for reasons similar to the above. (and (= old-min-x old-max-x) (= old-min-y old-max-y)) ;; For each edge of the original child bounds, if it was within ;; its respective edge of the old parent bounding rectangle, ;; or if it has not changed: (and (or (> old-min-x ox1) (= old-min-x cx1)) (or (> old-min-y oy1) (= old-min-y cy1)) (or (< old-max-x ox2) (= old-max-x cx2)) (or (< old-max-y oy2) (= old-max-y cy2))) ;; New child bounds contain old child bounds, so use min/max ;; to extend the already-calculated rectangle. (and (<= cx1 old-min-x) (<= cy1 old-min-y) (>= cx2 old-max-x) (>= cy2 old-max-y))) (values (min cx1 ox1) (min cy1 oy1) (max cx2 ox2) (max cy2 oy2))) ;; No shortcuts - we must compute a new bounding box from those of ;; all our children. We want to avoid this - in worst cases, such as ;; a toplevel output history, large graph, or table, there may exist ;; thousands of children. Without the above optimizations, ;; construction becomes O(N^2) due to bounding rectangle calculation. (t (%tree-recompute-extent* record))) ;; XXX banish x, y (with-slots (x y) record (setf x nx1 y ny1) (setf (rectangle-edges* record) (values nx1 ny1 nx2 ny2)) (let ((parent (output-record-parent record))) (unless (or (null parent) (and (= nx1 ox1) (= ny1 oy1) (= nx2 ox2) (= nx2 oy2))) (recompute-extent-for-changed-child parent record ox1 oy1 ox2 oy2))))))) record) (defmethod tree-recompute-extent ((record compound-output-record)) (tree-recompute-extent-aux record) record) (defmethod tree-recompute-extent :around ((record compound-output-record)) (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record (call-next-method) (with-bounding-rectangle* (x1 y1 x2 y2) record (let ((parent (output-record-parent record))) (when (and parent (not (and (= old-x1 x1) (= old-y1 y1) (= old-x2 x2) (= old-y2 y2)))) (recompute-extent-for-changed-child parent record old-x1 old-y1 old-x2 old-y2))))) record) ;;; 16.3.1. Standard output record classes (defclass standard-sequence-output-record (compound-output-record) ((children :initform (make-array 8 :adjustable t :fill-pointer 0) :reader output-record-children))) (defmethod add-output-record (child (record standard-sequence-output-record)) (vector-push-extend child (output-record-children record)) (setf (output-record-parent child) record)) (defmethod delete-output-record (child (record standard-sequence-output-record) &optional (errorp t)) (with-slots (children) record (let ((pos (position child children :test #'eq))) (if (null pos) (when errorp (error "~S is not a child of ~S" child record)) (progn (setq children (replace children children :start1 pos :start2 (1+ pos))) (decf (fill-pointer children)) (setf (output-record-parent child) nil)))))) (defmethod clear-output-record ((record standard-sequence-output-record)) (let ((children (output-record-children record))) (map 'nil (lambda (child) (setf (output-record-parent child) nil)) children) (fill children nil) (setf (fill-pointer children) 0))) (defmethod output-record-count ((record standard-sequence-output-record)) (length (output-record-children record))) (defmethod map-over-output-records-1 (function (record standard-sequence-output-record) function-args) "Applies FUNCTION to all children in the order they were added." (if function-args (loop with children = (output-record-children record) for child across children do (apply function child function-args)) (loop with children = (output-record-children record) for child across children do (funcall function child)))) (defmethod map-over-output-records-containing-position (function (record standard-sequence-output-record) x y &optional (x-offset 0) (y-offset 0) &rest function-args) "Applies FUNCTION to children, containing (X,Y), in the reversed order they were added." (declare (ignore x-offset y-offset)) (loop with children = (output-record-children record) for i from (1- (length children)) downto 0 for child = (aref children i) when (and (multiple-value-bind (min-x min-y max-x max-y) (output-record-hit-detection-rectangle* child) (and (<= min-x x max-x) (<= min-y y max-y))) (output-record-refined-position-test child x y)) do (apply function child function-args))) (defmethod map-over-output-records-overlapping-region (function (record standard-sequence-output-record) region &optional (x-offset 0) (y-offset 0) &rest function-args) "Applies FUNCTION to children, overlapping REGION, in the order they were added." (declare (ignore x-offset y-offset)) (loop with children = (output-record-children record) for child across children when (region-intersects-region-p region child) do (apply function child function-args))) ;;; tree output recording (defclass tree-output-record-entry () ((record :initarg :record :reader tree-output-record-entry-record) (cached-rectangle :initform nil :accessor tree-output-record-entry-cached-rectangle) (inserted-nr :initarg :inserted-nr :accessor tree-output-record-entry-inserted-nr))) (defun make-tree-output-record-entry (record inserted-nr) (make-instance 'tree-output-record-entry :record record :inserted-nr inserted-nr)) (defun %record-to-spatial-tree-rectangle (r) (rectangles:make-rectangle :lows `(,(bounding-rectangle-min-x r) ,(bounding-rectangle-min-y r)) :highs `(,(bounding-rectangle-max-x r) ,(bounding-rectangle-max-y r)))) (defun %output-record-entry-to-spatial-tree-rectangle (r) (when (null (tree-output-record-entry-cached-rectangle r)) (let* ((record (tree-output-record-entry-record r))) (setf (tree-output-record-entry-cached-rectangle r) (%record-to-spatial-tree-rectangle record)))) (tree-output-record-entry-cached-rectangle r)) (defun %make-tree-output-record-tree () (spatial-trees:make-spatial-tree :r :rectfun #'%output-record-entry-to-spatial-tree-rectangle)) (defclass standard-tree-output-record (compound-output-record) ((children :initform (%make-tree-output-record-tree) :accessor %tree-record-children) (children-hash :initform (make-hash-table :test #'eql) :reader %tree-record-children-cache) (child-count :initform 0) (last-insertion-nr :initform 0 :accessor last-insertion-nr))) (defun %entry-in-children-cache (record entry) (gethash entry (%tree-record-children-cache record))) (defun (setf %entry-in-children-cache) (new-val record entry) (setf (gethash entry (%tree-record-children-cache record)) new-val)) (defun %remove-entry-from-children-cache (record entry) (remhash entry (%tree-record-children-cache record))) (defmethod output-record-children ((record standard-tree-output-record)) (with-bounding-rectangle* (min-x min-y max-x max-y) record (map 'list #'tree-output-record-entry-record (spatial-trees:search ;; Originally, (%record-to-spatial-tree-rectangle record). ;; The form below intends to fix output-record-children not ;; reporting empty children, which may lie outside the reported ;; bounding rectangle of their parent. ;; Assumption: null bounding records are always at the origin. ;; I've never noticed this violated, but it's out of line with ;; what null-bounding-rectangle-p checks, and setf of ;; output-record-position may invalidate it. Seems to work, but ;; fix that and try again later. ;; Note that max x or y may be less than zero.. (rectangles:make-rectangle :lows (list (min 0 min-x) (min 0 min-y)) :highs (list (max 0 max-x) (max 0 max-y))) (%tree-record-children record))))) (defmethod add-output-record (child (record standard-tree-output-record)) (let ((entry (make-tree-output-record-entry child (incf (last-insertion-nr record))))) (spatial-trees:insert entry (%tree-record-children record)) (setf (output-record-parent child) record) (setf (%entry-in-children-cache record child) entry)) (incf (slot-value record 'child-count)) (values)) (defmethod delete-output-record (child (record standard-tree-output-record) &optional (errorp t)) (let ((entry (find child (spatial-trees:search (%entry-in-children-cache record child) (%tree-record-children record)) :key #'tree-output-record-entry-record))) (decf (slot-value record 'child-count)) (cond ((not (null entry)) (spatial-trees:delete entry (%tree-record-children record)) (%remove-entry-from-children-cache record child) (setf (output-record-parent child) nil)) (errorp (error "~S is not a child of ~S" child record))))) (defmethod clear-output-record ((record standard-tree-output-record)) (map nil (lambda (child) (setf (output-record-parent child) nil) (%remove-entry-from-children-cache record child)) (output-record-children record)) (setf (slot-value record 'child-count) 0) (setf (%tree-record-children record) (%make-tree-output-record-tree))) (defmethod output-record-count ((record standard-tree-output-record)) (slot-value record 'child-count)) (defun map-over-tree-output-records (function record rectangle sort-order function-args) (dolist (child (sort (spatial-trees:search rectangle (%tree-record-children record)) (ecase sort-order (:most-recent-first #'>) (:most-recent-last #'<)) :key #'tree-output-record-entry-inserted-nr)) (apply function (tree-output-record-entry-record child) function-args))) (defmethod map-over-output-records-1 (function (record standard-tree-output-record) function-args) (map-over-tree-output-records function record (%record-to-spatial-tree-rectangle record) :most-recent-last function-args)) (defmethod map-over-output-records-containing-position (function (record standard-tree-output-record) x y &optional x-offset y-offset &rest function-args) (declare (ignore x-offset y-offset)) (map-over-tree-output-records function record (rectangles:make-rectangle :lows `(,x ,y) :highs `(,x ,y)) :most-recent-first function-args)) (defmethod map-over-output-records-overlapping-region (function (record standard-tree-output-record) region &optional x-offset y-offset &rest function-args) (declare (ignore x-offset y-offset)) (typecase region (everywhere-region (map-over-output-records-1 function record function-args)) (nowhere-region nil) (otherwise (map-over-tree-output-records (lambda (child) (if (region-intersects-region-p (multiple-value-call 'make-rectangle* (bounding-rectangle* child)) region) (apply function child function-args))) record (%record-to-spatial-tree-rectangle (bounding-rectangle region)) :most-recent-last nil)))) (defmethod recompute-extent-for-changed-child :around ((record standard-tree-output-record) child old-min-x old-min-y old-max-x old-max-y) (when (eql record (output-record-parent child)) (let ((entry (%entry-in-children-cache record child))) (spatial-trees:delete entry (%tree-record-children record)) (setf (tree-output-record-entry-cached-rectangle entry) nil) (spatial-trees:insert entry (%tree-record-children record)))) (call-next-method)) ;;; (defmethod match-output-records ((record t) &rest args) (apply #'match-output-records-1 record args)) ;;; Factor out the graphics state portions of the output records so ;;; they can be manipulated seperately e.g., by incremental ;;; display. The individual slots of a graphics state are factored into mixin ;;; classes so that each output record can capture only the state that it needs. ;;; -- moore ;;; It would be appealing to define a setf method, e.g. (setf ;;; medium-graphics-state), for setting a medium's state from a graphics state ;;; object, but that would require us to define a medium-graphics-state reader ;;; that would cons a state object. I don't want to do that. (defclass graphics-state () () (:documentation "Stores those parts of the medium/stream graphics state that need to be restored when drawing an output record")) (defclass gs-ink-mixin (graphics-state) ((ink :initarg :ink :accessor graphics-state-ink))) (defmethod initialize-instance :after ((obj gs-ink-mixin) &key (stream nil) (medium (when stream (sheet-medium stream)))) (when (and medium (not (slot-boundp obj 'ink))) (setf (slot-value obj 'ink) (medium-ink medium)))) (defmethod replay-output-record :around ((record gs-ink-mixin) stream &optional region x-offset y-offset) (declare (ignore region x-offset y-offset)) (with-drawing-options (stream :ink (graphics-state-ink record)) (call-next-method))) (defrecord-predicate gs-ink-mixin (ink) (if-supplied (ink) (design-equalp (slot-value record 'ink) ink))) (defclass gs-clip-mixin (graphics-state) ((clip :initarg :clipping-region :accessor graphics-state-clip :documentation "Clipping region in stream coordinates."))) (defmethod initialize-instance :after ((obj gs-clip-mixin) &key (stream nil) (medium (when stream (sheet-medium stream)))) (when medium (with-slots (clip) obj (let ((clip-region (if (slot-boundp obj 'clip) (region-intersection (medium-clipping-region medium) clip) (medium-clipping-region medium)))) (setq clip (transform-region (medium-transformation medium) clip-region)))))) (defmethod replay-output-record :around ((record gs-clip-mixin) stream &optional region x-offset y-offset) (declare (ignore region x-offset y-offset)) (let ((clipping-region (graphics-state-clip record))) (if (or (eq clipping-region +everywhere+) ; !!! (region-contains-region-p clipping-region (medium-clipping-region stream))) (call-next-method) (with-drawing-options (stream :clipping-region (graphics-state-clip record)) (call-next-method))))) (defrecord-predicate gs-clip-mixin ((:clipping-region clip)) (if-supplied (clip) (region-equal (slot-value record 'clip) clip))) ;;; 16.3.2. Graphics Displayed Output Records (defclass standard-displayed-output-record (gs-clip-mixin gs-ink-mixin basic-output-record displayed-output-record) ((ink :reader displayed-output-record-ink) (stream :initarg :stream)) (:documentation "Implementation class for DISPLAYED-OUTPUT-RECORD.") (:default-initargs :stream nil)) (defclass gs-line-style-mixin (graphics-state) ((line-style :initarg :line-style :accessor graphics-state-line-style))) (defmethod initialize-instance :after ((obj gs-line-style-mixin) &key (stream nil) (medium (when stream (sheet-medium stream)))) (when medium (unless (slot-boundp obj 'line-style) (setf (slot-value obj 'line-style) (medium-line-style medium))))) (defmethod replay-output-record :around ((record gs-line-style-mixin) stream &optional region x-offset y-offset) (declare (ignore region x-offset y-offset)) (with-drawing-options (stream :line-style (graphics-state-line-style record)) (call-next-method))) (defrecord-predicate gs-line-style-mixin (line-style) (if-supplied (line-style) (line-style-equalp (slot-value record 'line-style) line-style))) (defgeneric graphics-state-line-style-border (record medium) (:method ((record gs-line-style-mixin) medium) (/ (line-style-effective-thickness (graphics-state-line-style record) medium) 2))) (defclass gs-text-style-mixin (graphics-state) ((text-style :initarg :text-style :accessor graphics-state-text-style))) (defmethod initialize-instance :after ((obj gs-text-style-mixin) &key (stream nil) (medium (when stream (sheet-medium stream)))) (when medium (unless (slot-boundp obj 'text-style) (setf (slot-value obj 'text-style) (medium-text-style medium))))) (defmethod replay-output-record :around ((record gs-text-style-mixin) stream &optional region x-offset y-offset) (declare (ignore region x-offset y-offset)) (with-drawing-options (stream :text-style (graphics-state-text-style record)) (call-next-method))) (defrecord-predicate gs-text-style-mixin (text-style) (if-supplied (text-style) (text-style-equalp (slot-value record 'text-style) text-style))) (defclass standard-graphics-displayed-output-record (standard-displayed-output-record graphics-displayed-output-record) ()) (defmethod match-output-records-1 and ((record standard-displayed-output-record) &key (x1 nil x1-p) (y1 nil y1-p) (x2 nil x2-p) (y2 nil y2-p) (bounding-rectangle nil bounding-rectangle-p)) (if bounding-rectangle-p (region-equal record bounding-rectangle) (multiple-value-bind (my-x1 my-y1 my-x2 my-y2) (bounding-rectangle* record) (macrolet ((coordinate=-or-lose (key mine) `(if (typep ,key 'coordinate) (coordinate= ,mine ,key) (error 'type-error :datum ,key :expected-type 'coordinate)))) (and (or (null x1-p) (coordinate=-or-lose x1 my-x1)) (or (null y1-p) (coordinate=-or-lose y1 my-y1)) (or (null x2-p) (coordinate=-or-lose x2 my-x2)) (or (null y2-p) (coordinate=-or-lose y2 my-y2))))))) (defmethod output-record-equal and ((record standard-displayed-output-record) (record2 standard-displayed-output-record)) (region-equal record record2)) (defclass coord-seq-mixin () ((coord-seq :accessor coord-seq :initarg :coord-seq)) (:documentation "Mixin class that implements methods for records that contain sequences of coordinates.")) (defun coord-seq-bounds (coord-seq border) (setf border (ceiling border)) (let* ((min-x (elt coord-seq 0)) (min-y (elt coord-seq 1)) (max-x min-x) (max-y min-y)) (do-sequence ((x y) coord-seq) (minf min-x x) (minf min-y y) (maxf max-x x) (maxf max-y y)) (values (floor (- min-x border)) (floor (- min-y border)) (ceiling (+ max-x border)) (ceiling (+ max-y border))))) ;;; record must be a standard-rectangle (defmethod* (setf output-record-position) :around (nx ny (record coord-seq-mixin)) (with-standard-rectangle* (:x1 x1 :y1 y1) record (let ((dx (- nx x1)) (dy (- ny y1)) (coords (slot-value record 'coord-seq))) (multiple-value-prog1 (call-next-method) (loop for i from 0 below (length coords) by 2 do (progn (incf (aref coords i) dx) (incf (aref coords (1+ i)) dy))))))) (defmethod match-output-records-1 and ((record coord-seq-mixin) &key (coord-seq nil coord-seq-p)) (or (null coord-seq-p) (let* ((my-coord-seq (slot-value record 'coord-seq)) (len (length my-coord-seq))) (and (eql len (length coord-seq)) (loop for elt1 across my-coord-seq for elt2 across coord-seq always (coordinate= elt1 elt2)))))) (defmacro generate-medium-recording-body (class-name method-name args) (let ((arg-list (loop for arg in args nconc `(,(intern (symbol-name arg) :keyword) ,arg)))) `(with-sheet-medium (medium stream) (when (stream-recording-p stream) (let ((record ;; Hack: the coord-seq-mixin makes the assumption that, well ;; coord-seq is a coord-vector. So we morph a possible ;; coord-seq argument into a vector. (let (,@(when (member 'coord-seq args) `((coord-seq (if (vectorp coord-seq) coord-seq (coerce coord-seq 'vector)))))) (make-instance ',class-name :stream stream ,@arg-list)))) (stream-add-output-record stream record))) (when (stream-drawing-p stream) (,method-name medium ,@args))))) ;; DEF-GRECORDING: This is the central interface through which recording ;; is implemented for drawing functions. The body provided is used to ;; compute the bounding rectangle of the rendered output. DEF-GRECORDING ;; will define a class for the output record, with slots corresponding to the ;; drawing function arguments. It also defines an INITIALIZE-INSTANCE method ;; computing the bounding rectangle of the record. It defines a method for ;; the medium drawing function specialized on output-recording-stream, which ;; is responsible for creating the output record and adding it to the stream ;; history. It also defines a REPLAY-OUTPUT-RECORD method, which calls the ;; medium drawing function based on the recorded slots. (defmacro def-grecording (name ((&rest mixins) &rest args) (&key (class t) (medium-fn t) (replay-fn t)) &body body) (let ((method-name (symbol-concat '#:medium- name '*)) (class-name (symbol-concat name '#:-output-record)) (medium (gensym "MEDIUM")) (class-vars `((stream :initarg :stream) ,@(loop for arg in args collect `(,arg :initarg ,(intern (symbol-name arg) :keyword)))))) `(progn ,@(when class `((defclass ,class-name (,@mixins standard-graphics-displayed-output-record) ,class-vars) (defmethod initialize-instance :after ((graphic ,class-name) &key) (with-slots (stream ink clipping-region line-style text-style ,@args) graphic (let* ((medium (sheet-medium stream))) (setf (rectangle-edges* graphic) (progn ,@body))))))) ,(when medium-fn `(defmethod ,method-name :around ((stream output-recording-stream) ,@args) ;; XXX STANDARD-OUTPUT-RECORDING-STREAM ^? (generate-medium-recording-body ,class-name ,method-name ,args))) ,(when replay-fn `(defmethod replay-output-record ((record ,class-name) stream &optional (region +everywhere+) (x-offset 0) (y-offset 0)) (declare (ignore x-offset y-offset region)) (with-slots (,@args) record (let ((,medium (sheet-medium stream)) ;; is sheet a sheet-with-medium-mixin? --GB ) ;; Graphics state is set up in :around method. (,method-name ,medium ,@args)))))))) (def-grecording draw-point ((gs-line-style-mixin) point-x point-y) () (let ((border (graphics-state-line-style-border graphic medium))) (with-transformed-position ((medium-transformation medium) point-x point-y) (setf (slot-value graphic 'point-x) point-x (slot-value graphic 'point-y) point-y) (values (- point-x border) (- point-y border) (+ point-x border) (+ point-y border))))) (defmethod* (setf output-record-position) :around (nx ny (record draw-point-output-record)) (with-standard-rectangle* (:x1 x1 :y1 y1) record (with-slots (point-x point-y) record (let ((dx (- nx x1)) (dy (- ny y1))) (multiple-value-prog1 (call-next-method) (incf point-x dx) (incf point-y dy)))))) (defrecord-predicate draw-point-output-record (point-x point-y) (and (if-supplied (point-x coordinate) (coordinate= (slot-value record 'point-x) point-x)) (if-supplied (point-y coordinate) (coordinate= (slot-value record 'point-y) point-y)))) (def-grecording draw-points ((coord-seq-mixin gs-line-style-mixin) coord-seq) () (let ((transformed-coord-seq (transform-positions (medium-transformation medium) coord-seq)) (border (graphics-state-line-style-border graphic medium))) (setf (slot-value graphic 'coord-seq) transformed-coord-seq) (coord-seq-bounds transformed-coord-seq border))) (def-grecording draw-line ((gs-line-style-mixin) point-x1 point-y1 point-x2 point-y2) () (let ((transform (medium-transformation medium)) (border (graphics-state-line-style-border graphic medium))) (with-transformed-position (transform point-x1 point-y1) (with-transformed-position (transform point-x2 point-y2) (setf (slot-value graphic 'point-x1) point-x1 (slot-value graphic 'point-y1) point-y1 (slot-value graphic 'point-x2) point-x2 (slot-value graphic 'point-y2) point-y2) (values (- (min point-x1 point-x2) border) (- (min point-y1 point-y2) border) (+ (max point-x1 point-x2) border) (+ (max point-y1 point-y2) border)))))) (defmethod* (setf output-record-position) :around (nx ny (record draw-line-output-record)) (with-standard-rectangle* (:x1 x1 :y1 y1) record (with-slots (point-x1 point-y1 point-x2 point-y2) record (let ((dx (- nx x1)) (dy (- ny y1))) (multiple-value-prog1 (call-next-method) (incf point-x1 dx) (incf point-y1 dy) (incf point-x2 dx) (incf point-y2 dy)))))) (defrecord-predicate draw-line-output-record (point-x1 point-y1 point-x2 point-y2) (and (if-supplied (point-x1 coordinate) (coordinate= (slot-value record 'point-x1) point-x1)) (if-supplied (point-y1 coordinate) (coordinate= (slot-value record 'point-y1) point-y1)) (if-supplied (point-x2 coordinate) (coordinate= (slot-value record 'point-x2) point-x2)) (if-supplied (point-y2 coordinate) (coordinate= (slot-value record 'point-y2) point-y2)))) (def-grecording draw-lines ((coord-seq-mixin gs-line-style-mixin) coord-seq) () (let ((transformed-coord-seq (transform-positions (medium-transformation medium) coord-seq)) (border (graphics-state-line-style-border graphic medium))) (setf coord-seq transformed-coord-seq) (coord-seq-bounds transformed-coord-seq border))) ;;; (setf output-record-position) and predicates for draw-lines-output-record ;;; are taken care of by methods on superclasses. ;;; Helper function (defun normalize-coords (dx dy &optional unit) (let ((norm (sqrt (+ (* dx dx) (* dy dy))))) (cond ((= norm 0.0d0) (values 0.0d0 0.0d0)) (unit (let ((scale (/ unit norm))) (values (* dx scale) (* dy scale)))) (t (values (/ dx norm) (/ dy norm)))))) (defun polygon-record-bounding-rectangle (coord-seq closed filled line-style border miter-limit) (cond (filled (coord-seq-bounds coord-seq 0)) ((eq (line-style-joint-shape line-style) :round) (coord-seq-bounds coord-seq border)) (t (let* ((x1 (svref coord-seq 0)) (y1 (svref coord-seq 1)) (min-x x1) (min-y y1) (max-x x1) (max-y y1) (len (length coord-seq))) (unless closed (setq min-x (- x1 border) min-y (- y1 border) max-x (+ x1 border) max-y (+ y1 border))) ;; Setup for iterating over the coordinate vector. If the polygon ;; is closed deal with the extra segment. (multiple-value-bind (initial-xp initial-yp final-xn final-yn initial-index final-index) (if closed (values (svref coord-seq (- len 2)) (svref coord-seq (- len 1)) x1 y1 0 (- len 2)) (values x1 y1 (svref coord-seq (- len 2)) (svref coord-seq (- len 1)) 2 (- len 4))) (ecase (line-style-joint-shape line-style) (:miter ;;FIXME: Remove successive positively proportional segments (loop with sin-limit = (sin (* 0.5 miter-limit)) and xn and yn for i from initial-index to final-index by 2 for xp = initial-xp then x for yp = initial-yp then y for x = (svref coord-seq i) for y = (svref coord-seq (1+ i)) do (setf (values xn yn) (if (eql i final-index) (values final-xn final-yn) (values (svref coord-seq (+ i 2)) (svref coord-seq (+ i 3))))) (multiple-value-bind (ex1 ey1) (normalize-coords (- x xp) (- y yp)) (multiple-value-bind (ex2 ey2) (normalize-coords (- x xn) (- y yn)) (let* ((cos-a (+ (* ex1 ex2) (* ey1 ey2))) (sin-a/2 (sqrt (* 0.5 (- 1.0 cos-a))))) (if (< sin-a/2 sin-limit) (let ((nx (* border (max (abs ey1) (abs ey2)))) (ny (* border (max (abs ex1) (abs ex2))))) (minf min-x (- x nx)) (minf min-y (- y ny)) (maxf max-x (+ x nx)) (maxf max-y (+ y ny))) (let ((length (/ border sin-a/2))) (multiple-value-bind (dx dy) (normalize-coords (+ ex1 ex2) (+ ey1 ey2) length) (minf min-x (+ x dx)) (minf min-y (+ y dy)) (maxf max-x (+ x dx)) (maxf max-y (+ y dy)))))))))) ((:bevel :none) (loop with xn and yn for i from initial-index to final-index by 2 for xp = initial-xp then x for yp = initial-yp then y for x = (svref coord-seq i) for y = (svref coord-seq (1+ i)) do (setf (values xn yn) (if (eql i final-index) (values final-xn final-yn) (values (svref coord-seq (+ i 2)) (svref coord-seq (+ i 3))))) (multiple-value-bind (ex1 ey1) (normalize-coords (- x xp) (- y yp)) (multiple-value-bind (ex2 ey2) (normalize-coords (- x xn) (- y yn)) (let ((nx (* border (max (abs ey1) (abs ey2)))) (ny (* border (max (abs ex1) (abs ex2))))) (minf min-x (- x nx)) (minf min-y (- y ny)) (maxf max-x (+ x nx)) (maxf max-y (+ y ny)))))))) (unless closed (multiple-value-bind (x y) (values (svref coord-seq (- len 2)) (svref coord-seq (- len 1))) (minf min-x (- x border)) (minf min-y (- y border)) (maxf max-x (+ x border)) (maxf max-y (+ y border))))) (values min-x min-y max-x max-y))))) (def-grecording draw-polygon ((coord-seq-mixin gs-line-style-mixin) coord-seq closed filled) () (let ((transformed-coord-seq (transform-positions (medium-transformation medium) coord-seq)) (border (graphics-state-line-style-border graphic medium))) (setf coord-seq transformed-coord-seq) (polygon-record-bounding-rectangle transformed-coord-seq closed filled line-style border (medium-miter-limit medium)))) (defrecord-predicate draw-polygon-output-record (closed filled) (and (if-supplied (closed) (eql (slot-value record 'closed) closed)) (if-supplied (filled) (eql (slot-value record 'filled) filled)))) (def-grecording draw-rectangle ((gs-line-style-mixin) left top right bottom filled) (:medium-fn nil) (let* ((transform (medium-transformation medium)) (border (graphics-state-line-style-border graphic medium)) (pre-coords (expand-rectangle-coords left top right bottom)) (coords (transform-positions transform pre-coords))) (setf (values left top) (transform-position transform left top)) (setf (values right bottom) (transform-position transform right bottom)) (polygon-record-bounding-rectangle coords t filled line-style border (medium-miter-limit medium)))) (defmethod medium-draw-rectangle* :around ((stream output-recording-stream) left top right bottom filled) (let ((tr (medium-transformation stream))) (if (rectilinear-transformation-p tr) (generate-medium-recording-body draw-rectangle-output-record medium-draw-rectangle* (left top right bottom filled)) (medium-draw-polygon* stream (expand-rectangle-coords left top right bottom) t filled)))) (defmethod* (setf output-record-position) :around (nx ny (record draw-rectangle-output-record)) (with-standard-rectangle* (:x1 x1 :y1 y1) record (with-slots (left top right bottom) record (let ((dx (- nx x1)) (dy (- ny y1))) (multiple-value-prog1 (call-next-method) (incf left dx) (incf top dy) (incf right dx) (incf bottom dy)))))) (defrecord-predicate draw-rectangle-output-record (left top right bottom filled) (and (if-supplied (left coordinate) (coordinate= (slot-value record 'left) left)) (if-supplied (top coordinate) (coordinate= (slot-value record 'top) top)) (if-supplied (right coordinate) (coordinate= (slot-value record 'right) right)) (if-supplied (bottom coordinate) (coordinate= (slot-value record 'bottom) bottom)) (if-supplied (filled) (eql (slot-value record 'filled) filled)))) (def-grecording draw-ellipse ((gs-line-style-mixin) center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy start-angle end-angle filled) () (let ((transform (medium-transformation medium))) (setf (values center-x center-y) (transform-position transform center-x center-y)) (setf (values radius-1-dx radius-1-dy) (transform-distance transform radius-1-dx radius-1-dy)) (setf (values radius-2-dx radius-2-dy) (transform-distance transform radius-2-dx radius-2-dy)) ;; I think this should be untransform-angle below, as the ellipse angles ;; go counter-clockwise in screen coordinates, whereas our transformations ;; rotate clockwise in the default coorinate system.. this is quite possibly ;; wrong depending on how one reads the spec, but just reversing it here ;; will break other things. -Hefner (setf start-angle (untransform-angle transform start-angle)) (setf end-angle (untransform-angle transform end-angle)) (when (reflection-transformation-p transform) (rotatef start-angle end-angle)) (multiple-value-bind (min-x min-y max-x max-y) (bounding-rectangle* (make-ellipse* center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy :start-angle start-angle :end-angle end-angle)) (if filled (values min-x min-y max-x max-y) (let ((border (graphics-state-line-style-border graphic medium))) (values (- min-x border) (- min-y border) (+ max-x border) (+ max-y border))))))) (defmethod* (setf output-record-position) :around (nx ny (record draw-ellipse-output-record)) (with-standard-rectangle* (:x1 x1 :y1 y1) record (with-slots (center-x center-y) record (let ((dx (- nx x1)) (dy (- ny y1))) (multiple-value-prog1 (call-next-method) (incf center-x dx) (incf center-y dy)))))) (defrecord-predicate draw-ellipse-output-record (center-x center-y) (and (if-supplied (center-x coordinate) (coordinate= (slot-value record 'center-x) center-x)) (if-supplied (center-y coordinate) (coordinate= (slot-value record 'center-y) center-y)))) ;;;; Patterns ;;; The Spec says that "transformation only affects the position at ;;; which the pattern is drawn, not the pattern itself" (def-grecording draw-pattern (() pattern x y) () (let ((width (pattern-width pattern)) (height (pattern-height pattern)) (transform (medium-transformation medium))) (setf (values x y) (transform-position transform x y)) (values x y (+ x width) (+ y height)))) (defmethod* (setf output-record-position) :around (nx ny (record draw-pattern-output-record)) (with-standard-rectangle* (:x1 x1 :y1 y1) record (with-slots (x y) record (let ((dx (- nx x1)) (dy (- ny y1))) (multiple-value-prog1 (call-next-method) (incf x dx) (incf y dy)))))) (defrecord-predicate draw-pattern-output-record (x y pattern) ;; ### I am not so sure about the correct usage of DEFRECORD-PREDICATE ;; --GB 2003-08-15 (and (if-supplied (x coordinate) (coordinate= (slot-value record 'x) x)) (if-supplied (y coordinate) (coordinate= (slot-value record 'y) y)) (if-supplied (pattern pattern) (eq (slot-value record 'pattern) pattern)))) ;;;; RGB images (def-grecording draw-image-design (() image-design x y) () (let ((width (image-width (image image-design))) (height (image-height (image image-design))) (transform (medium-transformation medium))) (setf (values x y) (transform-position transform x y)) (values x y (+ x width) (+ y height)))) (defmethod* (setf output-record-position) :around (nx ny (record draw-image-design-output-record)) (with-standard-rectangle* (:x1 x1 :y1 y1) record (with-slots (x y) record (let ((dx (- nx x1)) (dy (- ny y1))) (multiple-value-prog1 (call-next-method) (incf x dx) (incf y dy)))))) (defrecord-predicate draw-image-design-output-record (x y image-design) (and (if-supplied (x coordinate) (coordinate= (slot-value record 'x) x)) (if-supplied (y coordinate) (coordinate= (slot-value record 'y) y)) (if-supplied (image-design rgb-image-design) (eq (slot-value record 'image-design) image-design)))) ;;;; Text (def-grecording draw-text ((gs-text-style-mixin) string point-x point-y start end align-x align-y toward-x toward-y transform-glyphs) () ;; FIXME!!! Text direction. ;; FIXME: Multiple lines. (let* ((text-style (graphics-state-text-style graphic)) (width (if (characterp string) (stream-character-width stream string :text-style text-style) (stream-string-width stream string :start start :end end :text-style text-style)) ) (ascent (text-style-ascent text-style (sheet-medium stream))) (descent (text-style-descent text-style (sheet-medium stream))) (transform (medium-transformation medium))) (setf (values point-x point-y) (transform-position transform point-x point-y)) (multiple-value-bind (left top right bottom) (text-bounding-rectangle* medium string :start start :end end :text-style text-style) (ecase align-x (:left (incf left point-x) (incf right point-x)) (:right (incf left (- point-x width)) (incf right (- point-x width))) (:center (incf left (- point-x (round width 2))) (incf right (- point-x (round width 2))))) (ecase align-y (:baseline (incf top point-y) (incf bottom point-y)) (:top (incf top (+ point-y ascent)) (incf bottom (+ point-y ascent))) (:bottom (incf top (- point-y descent)) (incf bottom (- point-y descent))) (:center (incf top (+ point-y (ceiling (- ascent descent) 2))) (incf bottom (+ point-y (ceiling (- ascent descent) 2))))) (values left top right bottom)))) (defmethod* (setf output-record-position) :around (nx ny (record draw-text-output-record)) (with-standard-rectangle* (:x1 x1 :y1 y1) record (with-slots (point-x point-y toward-x toward-y) record (let ((dx (- nx x1)) (dy (- ny y1))) (multiple-value-prog1 (call-next-method) (incf point-x dx) (incf point-y dy) (incf toward-x dx) (incf toward-y dy)))))) (defrecord-predicate draw-text-output-record (string start end point-x point-y align-x align-y toward-x toward-y transform-glyphs) (and (if-supplied (string) (string= (slot-value record 'string) string)) (if-supplied (start) (eql (slot-value record 'start) start)) (if-supplied (end) (eql (slot-value record 'end) end)) (if-supplied (point-x coordinate) (coordinate= (slot-value record 'point-x) point-x)) (if-supplied (point-y coordinate) (coordinate= (slot-value record 'point-y) point-y)) (if-supplied (align-x) (eq (slot-value record 'align-x) align-x)) (if-supplied (align-y) (eq (slot-value record 'align-y) align-y)) (if-supplied (toward-x coordinate) (coordinate= (slot-value record 'toward-x) toward-x)) (if-supplied (toward-y coordinate) (coordinate= (slot-value record 'toward-y) toward-y)) (if-supplied (transform-glyphs) (eq (slot-value record 'transform-glyphs) transform-glyphs)))) ;;; 16.3.3. Text Displayed Output Record (defclass styled-string (gs-text-style-mixin gs-clip-mixin gs-ink-mixin) ((start-x :initarg :start-x) (string :initarg :string :reader styled-string-string))) (defmethod output-record-equal and ((record styled-string) (record2 styled-string)) (and (coordinate= (slot-value record 'start-x) (slot-value record2 'start-x)) (string= (slot-value record 'string) (slot-value record2 'string)))) (defclass standard-text-displayed-output-record (text-displayed-output-record standard-displayed-output-record) ((initial-x1 :initarg :start-x) (initial-y1 :initarg :start-y) (strings :initform nil) (baseline :initform 0) (width :initform 0) (max-height :initform 0) ;; FIXME (or rework this comment): CLIM does not separate the ;; notions of the text width and the bounding box; however, we need ;; to, because some fonts will render outside the logical ;; coordinates defined by the start position and the width. LEFT ;; and RIGHT here (and below) deal with this in a manner completely ;; hidden from the user. (should we export ;; TEXT-BOUNDING-RECTANGLE*?) (left :initarg :start-x) (right :initarg :start-x) (start-x :initarg :start-x) (start-y :initarg :start-y) (end-x :initarg :start-x) (end-y :initarg :start-y) (wrapped :initform nil :accessor text-record-wrapped) (medium :initarg :medium :initform nil))) (defmethod initialize-instance :after ((obj standard-text-displayed-output-record) &key stream) (when stream (setf (slot-value obj 'medium) (sheet-medium stream)))) ;;; Forget match-output-records-1 for standard-text-displayed-output-record; it ;;; doesn't make much sense because these records have state that is not ;;; initialized via initargs. (defmethod output-record-equal and ((record standard-text-displayed-output-record) (record2 standard-text-displayed-output-record)) (with-slots (initial-x1 initial-y1 start-x start-y left right end-x end-y wrapped strings) record2 (and (coordinate= (slot-value record 'initial-x1) initial-x1) (coordinate= (slot-value record 'initial-y1) initial-y1) (coordinate= (slot-value record 'start-x) start-x) (coordinate= (slot-value record 'start-y) start-y) (coordinate= (slot-value record 'left) left) (coordinate= (slot-value record 'right) right) (coordinate= (slot-value record 'end-x) end-x) (coordinate= (slot-value record 'end-y) end-y) (eq (slot-value record 'wrapped) wrapped) (coordinate= (slot-value record 'baseline) (slot-value record2 'baseline)) (eql (length (slot-value record 'strings)) (length strings));XXX (loop for s1 in (slot-value record 'strings) for s2 in strings always (output-record-equal s1 s2))))) (defmethod print-object ((self standard-text-displayed-output-record) stream) (print-unreadable-object (self stream :type t :identity t) (with-slots (start-x start-y strings) self (format stream "~D,~D ~S" start-x start-y (mapcar #'styled-string-string strings))))) (defmethod* (setf output-record-position) :around (nx ny (record standard-text-displayed-output-record)) (with-standard-rectangle* (:x1 x1 :y1 y1) record (with-slots (start-x start-y end-x end-y strings baseline) record (let ((dx (- nx x1)) (dy (- ny y1))) (multiple-value-prog1 (call-next-method) (incf start-x dx) (incf start-y dy) (incf end-x dx) (incf end-y dy) ;(incf baseline dy) (loop for s in strings do (incf (slot-value s 'start-x) dx))))))) (defmethod replay-output-record ((record standard-text-displayed-output-record) stream &optional region (x-offset 0) (y-offset 0)) (declare (ignore region x-offset y-offset)) (with-slots (strings baseline max-height start-y wrapped) record (with-sheet-medium (medium stream) ;is sheet a sheet-with-medium-mixin? --GB ;; FIXME: ;; 1. SLOT-VALUE... ;; 2. It should also save a "current line". (setf (slot-value stream 'baseline) baseline) (loop for substring in strings do (with-slots (start-x string) substring (setf (stream-cursor-position stream) (values start-x start-y)) ;; FIXME: a bit of an abstraction inversion. Should ;; the styled strings here not simply be output ;; records? Then we could just replay them and all ;; would be well. -- CSR, 20060528. ;; But then we'd have to implement the output record ;; protocols for them. Are we allowed no internal ;; structure of our own? -- Hefner, 20080118 ;; Some optimization might be possible here. (with-drawing-options (stream :ink (graphics-state-ink substring) :clipping-region (graphics-state-clip substring) :text-style (graphics-state-text-style substring)) (stream-write-output stream string nil)))) (when wrapped ; FIXME (draw-rectangle* medium (+ wrapped 0) start-y (+ wrapped 4) (+ start-y max-height) :ink +foreground-ink+ :filled t))))) (defmethod output-record-start-cursor-position ((record standard-text-displayed-output-record)) (with-slots (start-x start-y) record (values start-x start-y))) (defmethod output-record-end-cursor-position ((record standard-text-displayed-output-record)) (with-slots (end-x end-y) record (values end-x end-y))) (defmethod tree-recompute-extent ((text-record standard-text-displayed-output-record)) (with-standard-rectangle* (:y1 y1) text-record (with-slots (max-height left right) text-record (setf (rectangle-edges* text-record) (values (coordinate left) y1 (coordinate right) (coordinate (+ y1 max-height)))))) text-record) (defmethod add-character-output-to-text-record ; XXX OAOO with ADD-STRING-... ((text-record standard-text-displayed-output-record) character text-style char-width height new-baseline) (with-slots (strings baseline width max-height left right start-y end-x end-y medium) text-record (if (and strings (let ((string (last1 strings))) (match-output-records string :text-style text-style :ink (medium-ink medium) :clipping-region (medium-clipping-region medium)))) (vector-push-extend character (slot-value (last1 strings) 'string)) (nconcf strings (list (make-instance 'styled-string :start-x end-x :text-style text-style :medium medium ; pick up ink and clipping region :string (make-array 1 :initial-element character :element-type 'character :adjustable t :fill-pointer t))))) (multiple-value-bind (minx miny maxx maxy) (text-bounding-rectangle* medium character :text-style text-style) (declare (ignore miny maxy)) (setq baseline (max baseline new-baseline) ;; KLUDGE: note END-X here is really START-X of the new ;; string left (min left (+ end-x minx)) end-x (+ end-x char-width) right (+ end-x (max 0 (- maxx char-width))) max-height (max max-height height) end-y (max end-y (+ start-y max-height)) width (+ width char-width)))) (tree-recompute-extent text-record)) (defmethod add-string-output-to-text-record ((text-record standard-text-displayed-output-record) string start end text-style string-width height new-baseline) (setf end (or end (length string))) (let ((length (max 0 (- end start)))) (cond ((eql length 1) (add-character-output-to-text-record text-record (aref string start) text-style string-width height new-baseline)) (t (with-slots (strings baseline width max-height left right start-y end-x end-y medium) text-record (let ((styled-string (make-instance 'styled-string :start-x end-x :text-style text-style :medium medium :string (make-array length :element-type 'character :adjustable t :fill-pointer t)))) (nconcf strings (list styled-string)) (replace (styled-string-string styled-string) string :start2 start :end2 end)) (multiple-value-bind (minx miny maxx maxy) (text-bounding-rectangle* medium string :text-style text-style :start start :end end) (declare (ignore miny maxy)) (setq baseline (max baseline new-baseline) ;; KLUDGE: note that END-X here really means ;; START-X of the new string. left (min left (+ end-x minx)) end-x (+ end-x string-width) right (+ end-x (max 0 (- maxx string-width))) max-height (max max-height height) end-y (max end-y (+ start-y max-height)) width (+ width string-width)))) (tree-recompute-extent text-record))))) (defmethod text-displayed-output-record-string ((record standard-text-displayed-output-record)) (with-slots (strings) record (if (= 1 (length strings)) (styled-string-string (first strings)) (with-output-to-string (result) (loop for styled-string in strings do (write-string (styled-string-string styled-string) result)))))) ;;; 16.3.4. Top-Level Output Records (defclass stream-output-history-mixin () ((stream :initarg :stream :reader output-history-stream))) (defclass standard-sequence-output-history (standard-sequence-output-record stream-output-history-mixin) ()) (defclass standard-tree-output-history (standard-tree-output-record stream-output-history-mixin) ()) ;;; 16.4. Output Recording Streams (defclass standard-output-recording-stream (output-recording-stream) ((recording-p :initform t :reader stream-recording-p) (drawing-p :initform t :accessor stream-drawing-p) (output-history :initform (make-instance 'standard-tree-output-history) :reader stream-output-history) (current-output-record :accessor stream-current-output-record) (current-text-output-record :initform nil :accessor stream-current-text-output-record) (local-record-p :initform t :documentation "This flag is used for dealing with streams outputting strings char-by-char."))) (defmethod initialize-instance :after ((stream standard-output-recording-stream) &rest args) (declare (ignore args)) (let ((history (make-instance 'standard-tree-output-history :stream stream))) (setf (slot-value stream 'output-history) history (stream-current-output-record stream) history))) ;;; Used in initializing clim-stream-pane (defmethod reset-output-history ((stream standard-output-recording-stream)) (setf (slot-value stream 'output-history) (make-instance 'standard-tree-output-history :stream stream)) (setf (stream-current-output-record stream) (stream-output-history stream))) ;;; 16.4.1 The Output Recording Stream Protocol (defmethod (setf stream-recording-p) (recording-p (stream standard-output-recording-stream)) (let ((old-val (slot-value stream 'recording-p))) (setf (slot-value stream 'recording-p) recording-p) (when (not (eq old-val recording-p)) (stream-close-text-output-record stream)) recording-p)) (defmethod stream-add-output-record ((stream standard-output-recording-stream) record) (add-output-record record (stream-current-output-record stream))) (defmethod stream-replay ((stream standard-output-recording-stream) &optional region) (replay (stream-output-history stream) stream region)) (defun output-record-ancestor-p (ancestor child) (loop for record = child then parent for parent = (output-record-parent record) when (eq parent nil) do (return nil) when (eq parent ancestor) do (return t))) (defun rounded-bounding-rectangle (region) ;; return a bounding rectangle whose coordinates have been rounded to ;; lock into the pixel grid. Includes some extra safety to make ;; sure antialiasing around the theoretical limits are included, too. (with-bounding-rectangle* (x1 y1 x2 y2) region (make-rectangle* (floor (- x1 0.5)) (floor (- y1 0.5)) (ceiling (+ x2 0.5)) (ceiling (+ y2 0.5))))) (defmethod erase-output-record (record (stream standard-output-recording-stream) &optional (errorp t)) (letf (((stream-recording-p stream) nil)) (let ((region (rounded-bounding-rectangle record))) (with-bounding-rectangle* (x1 y1 x2 y2) region (if (output-record-ancestor-p (stream-output-history stream) record) (progn (delete-output-record record (output-record-parent record)) (with-output-recording-options (stream :record nil) (draw-rectangle* stream x1 y1 x2 y2 :ink +background-ink+)) (stream-replay stream region)) (when errorp (error "~S is not contained in ~S." record stream))))))) ;;; 16.4.3. Text Output Recording (defmethod stream-text-output-record ((stream standard-output-recording-stream) text-style) (declare (ignore text-style)) (let ((record (stream-current-text-output-record stream))) (unless (and record (typep record 'standard-text-displayed-output-record)) (multiple-value-bind (cx cy) (stream-cursor-position stream) (setf record (make-instance 'standard-text-displayed-output-record :x-position cx :y-position cy :start-x cx :start-y cy :stream stream) (stream-current-text-output-record stream) record))) record)) (defmethod stream-close-text-output-record ((stream standard-output-recording-stream)) (let ((record (stream-current-text-output-record stream))) (when record (setf (stream-current-text-output-record stream) nil) #|record stream-current-cursor-position to (end-x record) - already done|# (stream-add-output-record stream record)))) (defmethod stream-add-character-output ((stream standard-output-recording-stream) character text-style width height baseline) (add-character-output-to-text-record (stream-text-output-record stream text-style) character text-style width height baseline)) (defmethod stream-add-string-output ((stream standard-output-recording-stream) string start end text-style width height baseline) (add-string-output-to-text-record (stream-text-output-record stream text-style) string start end text-style width height baseline)) ;;; Text output catching methods (defmacro without-local-recording (stream &body body) `(letf (((slot-value ,stream 'local-record-p) nil)) ,@body)) (defmethod stream-write-output :around ((stream standard-output-recording-stream) line string-width &optional (start 0) end) (when (and (stream-recording-p stream) (slot-value stream 'local-record-p)) (let* ((medium (sheet-medium stream)) (text-style (medium-text-style medium)) (height (text-style-height text-style medium)) (ascent (text-style-ascent text-style medium))) (if (characterp line) (stream-add-character-output stream line text-style (stream-character-width stream line :text-style text-style) height ascent) (stream-add-string-output stream line start end text-style (or string-width (stream-string-width stream line :start start :end end :text-style text-style)) height ascent)))) (when (stream-drawing-p stream) (without-local-recording stream (call-next-method)))) #+nil (defmethod stream-write-char :around ((stream standard-output-recording-stream) char) (when (and (stream-recording-p stream) (slot-value stream 'local-record-p)) (if (or (eql char #\return) (stream-close-text-output-record stream) (let* ((medium (sheet-medium stream)) (text-style (medium-text-style medium))) (stream-add-character-output stream char text-style (stream-character-width stream char :text-style text-style) (text-style-height text-style medium) (text-style-ascent text-style medium))))) (without-local-recording stream (call-next-method)))) #+nil (defmethod stream-write-string :around ((stream standard-output-recording-stream) string &optional (start 0) end) (when (and (stream-recording-p stream) (slot-value stream 'local-record-p)) (let* ((medium (sheet-medium stream)) (text-style (medium-text-style medium))) (stream-add-string-output stream string start end text-style (stream-string-width stream string :start start :end end :text-style text-style) (text-style-height text-style medium) (text-style-ascent text-style medium)))) (without-local-recording stream (call-next-method))) (defmethod stream-finish-output :after ((stream standard-output-recording-stream)) (stream-close-text-output-record stream)) (defmethod stream-force-output :after ((stream standard-output-recording-stream)) (stream-close-text-output-record stream)) (defmethod stream-terpri :after ((stream standard-output-recording-stream)) (stream-close-text-output-record stream)) (defmethod* (setf stream-cursor-position) :after (x y (stream standard-output-recording-stream)) (declare (ignore x y)) (stream-close-text-output-record stream)) ;(defmethod stream-set-cursor-position :after ((stream standard-output-recording-stream)) ; (stream-close-text-output-record stream)) (defmethod stream-wrap-line :before ((stream standard-output-recording-stream)) (when (stream-recording-p stream) (setf (text-record-wrapped (stream-text-output-record stream nil)) ; FIXME! (stream-text-margin stream)))) ;;; 16.4.4. Output Recording Utilities (defmethod invoke-with-output-recording-options ((stream output-recording-stream) continuation record draw) "Calls CONTINUATION on STREAM enabling or disabling recording and drawing according to the flags RECORD and DRAW." (letf (((stream-recording-p stream) record) ((stream-drawing-p stream) draw)) (funcall continuation stream))) (defmethod invoke-with-new-output-record ((stream output-recording-stream) continuation record-type constructor &key parent) (declare (ignore record-type)) (stream-close-text-output-record stream) (let ((new-record (funcall constructor))) (letf (((stream-current-output-record stream) new-record)) ;; Should we switch on recording? -- APD (funcall continuation stream new-record) (force-output stream)) (if parent (add-output-record new-record parent) (stream-add-output-record stream new-record)) new-record)) (defmethod invoke-with-new-output-record ((stream output-recording-stream) continuation record-type (constructor null) &rest initargs &key parent) (with-keywords-removed (initargs (:parent)) (stream-close-text-output-record stream) (let ((new-record (apply #'make-instance record-type initargs))) (letf (((stream-current-output-record stream) new-record)) ;; Should we switch on recording? -- APD (funcall continuation stream new-record) (force-output stream)) (if parent (add-output-record new-record parent) (stream-add-output-record stream new-record)) new-record))) (defmethod invoke-with-output-to-output-record ((stream output-recording-stream) continuation record-type constructor &key) (declare (ignore record-type)) (stream-close-text-output-record stream) (let ((new-record (funcall constructor))) (with-output-recording-options (stream :record t :draw nil) (letf (((stream-current-output-record stream) new-record) ((stream-cursor-position stream) (values 0 0))) (funcall continuation stream new-record) (force-output stream))) new-record)) (defmethod invoke-with-output-to-output-record ((stream output-recording-stream) continuation record-type (constructor null) &rest initargs) (stream-close-text-output-record stream) (let ((new-record (apply #'make-instance record-type initargs))) (with-output-recording-options (stream :record t :draw nil) (letf (((stream-current-output-record stream) new-record) ((stream-cursor-position stream) (values 0 0))) (funcall continuation stream new-record) (force-output stream))) new-record)) (defmethod make-design-from-output-record (record) ;; FIXME (declare (ignore record)) (error "Not implemented.")) ;;; Additional methods (defmethod scroll-vertical :around ((stream output-recording-stream) dy) (declare (ignore dy)) (with-output-recording-options (stream :record nil) (call-next-method))) (defmethod scroll-horizontal :around ((stream output-recording-stream) dx) (declare (ignore dx)) (with-output-recording-options (stream :record nil) (call-next-method))) ;;; FIXME: Change things so the rectangle below is only drawn in response ;;; to explicit repaint requests from the user, not exposes from X ;;; FIXME: Use DRAW-DESIGN*, that is fix DRAW-DESIGN*. (defmethod handle-repaint ((stream output-recording-stream) region) (when (output-recording-stream-p stream) (unless (region-equal region +nowhere+) ; ignore repaint requests for +nowhere+ (let ((region (if (region-equal region +everywhere+) (sheet-region stream) ; fallback to the sheet's region for +everwhere+ (bounding-rectangle region)))) (with-bounding-rectangle* (x1 y1 x2 y2) region (with-output-recording-options (stream :record nil) (draw-rectangle* stream x1 y1 x2 y2 :filled t :ink +background-ink+))) (stream-replay stream region))))) (defmethod scroll-extent :around ((stream output-recording-stream) x y) (declare (ignore x y)) (when (stream-drawing-p stream) (call-next-method))) ;;; ---------------------------------------------------------------------------- ;;; Complicated, underspecified... ;;; ;;; From examining old Genera documentation, I believe that ;;; with-room-for-graphics is supposed to set the medium transformation to ;;; give the desired coordinate system; i.e., it doesn't preserve any ;;; rotation, scaling or translation in the current medium transformation. (defmethod invoke-with-room-for-graphics (cont stream &key (first-quadrant t) height (move-cursor t) (record-type 'standard-sequence-output-record)) ;; I am not sure what exactly :height should do. ;; --GB 2003-05-25 ;; The current behavior is consistent with 'classic' CLIM ;; --Hefner 2004-06-19 ;; Don't know if it still is :) ;; -- Moore 2005-01-26 (multiple-value-bind (cx cy) (stream-cursor-position stream) (with-sheet-medium (medium stream) (letf (((medium-transformation medium) (if first-quadrant (make-scaling-transformation 1 -1) +identity-transformation+))) (let ((record (with-output-to-output-record (stream record-type) (funcall cont stream)))) ;; Bounding rectangle is in sheet coordinates! (with-bounding-rectangle* (x1 y1 x2 y2) record (declare (ignore x2)) (if first-quadrant (setf (output-record-position record) (values (max cx (+ cx x1)) (if height (max cy (+ cy (- height (- y2 y1)))) cy))) (setf (output-record-position record) (values (max cx (+ cx x1)) (max cy (+ cy y1))))) (when (stream-recording-p stream) (stream-add-output-record stream record)) (when (stream-drawing-p stream) (replay record stream)) (if move-cursor (let ((record-height (- y2 y1))) (setf (stream-cursor-position stream) (values cx (if first-quadrant (+ cy (max (- y1) (or height 0) record-height)) (+ cy (max (or height 0) record-height)))))) (setf (stream-cursor-position stream) (values cx cy))) record)))))) ;;; ---------------------------------------------------------------------------- ;;; Baseline ;;; (defmethod output-record-baseline ((record output-record)) "Fall back method" (with-bounding-rectangle* (x1 y1 x2 y2) record (declare (ignore x1 x2)) (values (- y2 y1) nil))) (defmethod output-record-baseline ((record standard-text-displayed-output-record)) (with-slots (baseline) record (values baseline t))) (defmethod output-record-baseline ((record compound-output-record)) (map-over-output-records (lambda (sub-record) (multiple-value-bind (baseline definitive) (output-record-baseline sub-record) (when definitive (return-from output-record-baseline (values baseline t))))) record) (call-next-method)) ;;; ---------------------------------------------------------------------------- ;;; copy-textual-output ;;; (defun copy-textual-output-history (window stream &optional region record) (unless region (setf region +everywhere+)) (unless record (setf record (stream-output-history window))) (let* ((text-style (medium-default-text-style window)) (char-width (stream-character-width window #\n :text-style text-style)) (line-height (+ (stream-line-height window :text-style text-style) (stream-vertical-spacing window)))) #+NIL (print (list char-width line-height (stream-line-height window :text-style text-style) (stream-vertical-spacing window)) *trace-output*) ;; humble first ... (let ((cy nil) (cx 0)) (labels ((grok-record (record) (cond ((typep record 'standard-text-displayed-output-record) (with-slots (start-y start-x end-x strings) record (setf cy (or cy start-y)) #+NIL (print (list (list cx cy) (list start-x end-x start-y)) *trace-output*) (when (> start-y cy) (dotimes (k (round (- start-y cy) line-height)) (terpri stream)) (setf cy start-y cx 0)) (dotimes (k (round (- start-x cx) char-width)) (princ " " stream)) (setf cx end-x) (dolist (string strings) (with-slots (string) string (princ string stream)) #+NIL (print (list start-x start-y string) *trace-output*)))) (t (map-over-output-records-overlapping-region #'grok-record record region))))) (grok-record record))))) ;;; Debugging hacks (defmethod count-records (r) (declare (ignore r)) 1) (defmethod count-records ((r compound-output-record)) (let ((count 0)) (map-over-output-records (lambda (child) (incf count (count-records child))) r) (1+ count))) (defmethod count-displayed-records ((r displayed-output-record)) 1) (defmethod count-displayed-records ((r compound-output-record)) (let ((count 0)) (map-over-output-records (lambda (child) (incf count (count-records child))) r) count)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/presentations.lisp0000644000175000017500000022246211345155772020610 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com) ;;; (c) copyright 2001,2002 by Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Implementation of the presentation type system, presentation generic ;;; functions and methods, presentation translators, finding an applicable ;;;presentation. (in-package :clim-internals) ;;; PRESENTATION class (defvar *allow-sensitive-inferiors* t) (defclass presentation-mixin (presentation) ((object :accessor presentation-object :initarg :object) (type :accessor presentation-type :initarg :type) (view :accessor presentation-view :initarg :view) (single-box :accessor presentation-single-box :initarg :single-box :initform nil) (modifier :reader presentation-modifier :initarg :modifier :initform nil) (is-sensitive :reader is-sensitive :initarg :is-sensitive :initform *allow-sensitive-inferiors*))) (defclass standard-presentation (presentation-mixin standard-sequence-output-record) ()) (defvar *print-presentation-verbose* nil) (defmethod print-object ((self standard-presentation) stream) (print-unreadable-object (self stream :type t :identity t) (with-bounding-rectangle* (x1 y1 x2 y2) self (format stream "~D:~D,~D:~D ~S" x1 x2 y1 y2 (presentation-type self)) (when *print-presentation-verbose* (format stream " ~S" (presentation-object self)))))) (defmacro with-output-as-presentation ((stream object type &rest key-args &key modifier single-box (allow-sensitive-inferiors t) parent (record-type ''standard-presentation) &allow-other-keys) &body body) (declare (ignore parent single-box modifier)) (setq stream (stream-designator-symbol stream '*standard-output*)) (multiple-value-bind (decls with-body) (get-body-declarations body) (with-gensyms (record-arg continuation) (with-keywords-removed (key-args (:record-type :allow-sensitive-inferiors)) `(flet ((,continuation () ,@decls ,@with-body)) (declare (dynamic-extent #',continuation)) (if (and (output-recording-stream-p ,stream) *allow-sensitive-inferiors*) (with-new-output-record (,stream ,record-type ,record-arg :object ,object :type (expand-presentation-type-abbreviation ,type) ,@key-args) (let ((*allow-sensitive-inferiors* ,allow-sensitive-inferiors)) (,continuation))) (,continuation))))))) (defgeneric ptype-specializer (type) (:documentation "The specializer to use for this type in a presentation method lambda list")) ;;; Metaclass for presentation types. For presentation types not associated ;;; with CLOS classes, objects with this metaclass are used as a proxy for the ;;; type during presentation method dispatch. We don't prevent these ;;; presentation proxies from being subclasses of standard-object, ;;; but in presentation method dispatch we remove methods on standard ;;; object for presentation types that are not CLOS classes. The ;;; presentation type metaclass for T is the builtin object T instead ;;; of a presentation-type-class; in this way we can avoid weirdness ;;; with T being a subtype of standard-object! ;;; (defclass presentation-type () ((type-name :accessor type-name :initarg :type-name :documentation "The name assigned to the presentation type, as opposed to the name constructed for the class") (ptype-specializer :accessor ptype-specializer :initarg :ptype-specializer) (parameters :accessor parameters :initarg :parameters :initform nil) (parameters-lambda-list :accessor parameters-lambda-list :initarg :parameters-lambda-list :initform nil :documentation "The parameters lambda list, altered for use in destructuring bind") (options :accessor options :initarg :options :initform nil) (options-lambda-list :accessor options-lambda-list :initarg :options-lambda-list :initform nil :documentation "The options lambda list, altered for use in destructuring bind") (inherit-from :accessor inherit-from :initarg :inherit-from :documentation "Inherit-from form with dummys substituted") (inherit-from-function :accessor inherit-from-function :initarg :inherit-from-function :documentation "Function that returns the inherit-from form") (description :accessor description :initarg :description) (history :accessor history :initarg :history :initform nil :documentation "Who knows?") (parameters-are-types :accessor parameters-are-types :initarg :parameters-are-types :initform nil) (expansion-function :accessor expansion-function :initarg :expansion-function :documentation "A function which expands the typespec fully, including defaulting parameters and options."))) (defmethod initialize-instance :after ((obj presentation-type) &key) (unless (slot-boundp obj 'ptype-specializer) (setf (slot-value obj 'ptype-specializer) (make-presentation-type-name (slot-value obj 'type-name))))) (defclass presentation-type-class (presentation-type standard-class) ()) (defmethod clim-mop:validate-superclass ((class presentation-type-class) (super standard-class)) t) (defclass clos-presentation-type (presentation-type) ((clos-class :accessor clos-class :initarg :clos-class :documentation "Holds the class object of the CLOS class of this presentation type"))) (defmethod initialize-instance :after ((obj clos-presentation-type) &key (ptype-specializer nil ptype-specializer-p)) (declare (ignore ptype-specializer)) (unless ptype-specializer-p (setf (slot-value obj 'ptype-specializer) (slot-value obj 'type-name)))) (defmethod history ((ptype standard-class)) "Default for CLOS types that are not defined explicitly as presentation types." t) (defvar *builtin-t-class* (find-class t)) ;;;Methods for the T presentation type (defmethod type-name ((class (eql *builtin-t-class*))) t) (defmethod ptype-specializer ((class (eql *builtin-t-class*))) t) (defmethod parameters ((class (eql *builtin-t-class*))) nil) (defmethod parameters-lambda-list ((class (eql *builtin-t-class*))) nil) (defmethod options ((class (eql *builtin-t-class*))) nil) (defmethod options-lambda-list ((class (eql *builtin-t-class*))) nil) (defmethod inherit-from ((class (eql *builtin-t-class*))) nil) (defmethod inherit-from-function ((class (eql *builtin-t-class*))) #'(lambda (type) (declare (ignore type)) nil)) (defmethod description ((class (eql *builtin-t-class*))) "The supertype of all presentation types.") (defmethod history ((class (eql *builtin-t-class*))) t) (defmethod parameters-are-types ((class (eql *builtin-t-class*))) nil) (defmethod expansion-function ((class (eql *builtin-t-class*))) #'(lambda (type) (declare (ignore type)) t)) (defun make-presentation-type-name (name) (intern (format nil "(presentation-type ~A::~A)" (package-name (symbol-package name)) (symbol-name name)) :clim-internals)) (defun transform-parameters-lambda-list (ll) "Change the destructuring lambda list so that any optional or key variable that has no default is supplied with '*" (when (atom ll) (return-from transform-parameters-lambda-list ll)) (let ((state 'required)) (loop for lambda-var in ll collect (cond ((member lambda-var lambda-list-keywords :test #'eq) (setq state lambda-var) lambda-var) ((eq state '&optional) (if (atom lambda-var) `(,lambda-var '*) (cons (transform-parameters-lambda-list (car lambda-var)) (or (cdr lambda-var) '('*))))) ((eq state '&key) (cond ((atom lambda-var) `(,lambda-var '*)) ((atom (car lambda-var)) (cons (car lambda-var) (or (cdr lambda-var) '('*)))) (t (destructuring-bind ((var pattern) &optional (default nil default-p) &rest supplied-tail) lambda-var `((,var ,(transform-parameters-lambda-list pattern)) ,(if default-p default '*) ,@supplied-tail))))) ((member state '(required &rest &body &whole)) (when (eq state '&whole) (setq state 'required)) (transform-parameters-lambda-list lambda-var)) (t lambda-var))))) (defun fake-params-args (ll) (let ((state 'required)) (flet ((do-arg (lambda-var) (let ((var-name (symbol-name lambda-var))) (cond ((or (eq state 'required) (eq state '&optional)) (list (gensym var-name))) ((eq state '&key) `(,(intern var-name :keyword) ,(gensym var-name))) (t nil))))) (loop for lambda-var in ll append (cond ((member lambda-var lambda-list-keywords :test #'eq) (setq state lambda-var) nil) ((eq state '&whole) (setq state 'required) nil) ((atom lambda-var) (do-arg lambda-var)) ((consp lambda-var) (let ((var (car lambda-var))) (do-arg (if (and (eq state '&key) (consp var)) (car var) var))))))))) ;;; Yet another variation on a theme... (defun get-all-params (ll) (unless ll (return-from get-all-params nil)) (when (atom ll) (return-from get-all-params (list ll))) (let ((state 'required)) (loop for arg in ll append (cond ((member arg lambda-list-keywords :test #'eq) (setq state arg) nil) ((eq state 'required) (get-all-params arg)) ((or (eq state '&optional) (eq state '&aux)) (if (atom arg) (list arg) (get-all-params (car arg)))) ((eq state '&key) (cond ((atom arg) (list arg)) ((atom (car arg)) (list (car arg))) (t (get-all-params (cadar arg))))) ((member state '(required &rest &body &whole)) (when (eq state '&whole) (setq state 'required)) (get-all-params arg)) (t nil))))) ;;; ...And another. Given a lambda list, return a form that replicates the ;;; structure of the argument with variables filled in. (defun map-over-lambda-list (function ll &key (pass-lambda-list-keywords nil)) (declare (ignore function pass-lambda-list-keywords)) (unless ll (return-from map-over-lambda-list nil)) (when (atom ll) (return-from map-over-lambda-list ll)) (loop for args-tail = ll then (cdr args-tail))) (defun make-keyword (sym) (intern (symbol-name sym) :keyword)) (defun cull-keywords (keys prop-list) (let ((plist (copy-list prop-list))) (loop for key in keys do (remf plist key)) plist)) (defun recreate-lambda-list (ll) "Helper function. Returns a form that, when evaluated inside a DESTRUCTURING-BIND using ll, recreates the argument list with all defaults filled in." (unless ll (return-from recreate-lambda-list nil)) (when (atom ll) (return-from recreate-lambda-list ll)) (let ((state 'required) (rest-var nil) (has-keys nil) (keys nil) (allow-other-keys nil)) (loop for arg in ll append (cond ((member arg lambda-list-keywords :test #'eq) (setq state arg) (when (eq arg '&key) (setq has-keys t)) (when (eq arg '&allow-other-keys) (setq allow-other-keys t)) nil) ((eq state '&whole) nil) ((eq state 'required) (list (recreate-lambda-list arg))) ((eq state '&optional) (if (atom arg) (list arg) (list (recreate-lambda-list (car arg))))) ((or (eq state '&rest) (eq state '&body)) (setq rest-var arg) nil) ((eq state '&key) (let ((key nil) (var nil)) (cond ((atom arg) (setq key (make-keyword arg) var arg)) ((atom (car arg)) (setq key (make-keyword (car arg)) var (car arg))) (t (destructuring-bind ((keyword pattern) &rest tail) arg (declare (ignore tail)) (setq key keyword var (recreate-lambda-list pattern))))) (push key keys) (list key var))) (t nil)) into result-form finally (cond ((or (not rest-var) (and has-keys (not allow-other-keys))) (return `(list ,@result-form))) ((not has-keys) (return `(list* ,@result-form ,rest-var))) (t (return `(list* ,@result-form (cull-keywords ',(nreverse keys) ,rest-var)))))))) (defun transform-options-lambda-list (ll) "Return a legal lambda list given an options specification" (let ((descriptionp nil)) (loop for spec in ll collect (if (atom spec) (progn (when (eq (make-keyword spec) :description) (setq descriptionp t)) spec) (progn (let ((key (if (atom (car spec)) (make-keyword (car spec)) (caar spec)))) (when (eq key :description) (setq descriptionp t))) (ldiff spec (cdddr spec)))) into specs finally (return `(&key ,@specs ,@(unless descriptionp `(((:description ,(gensym)))))))))) ;;; External function (declaim (inline presentation-type-name)) (defun presentation-type-name (type) (cond ((atom type) type) ((atom (car type)) (car type)) (t (caar type)))) (defun decode-parameters (type) (cond ((atom type) nil) ((atom (car type)) (cdr type)) (t (cdar type)))) (defun decode-options (type) (if (or (atom type) (atom (car type))) nil (cdr type))) (defun make-inherit-from-lambda (params-ll options-ll form) (let ((type (gensym "TYPE"))) `(lambda (,type) (destructuring-bind ,params-ll (decode-parameters ,type) (declare (ignorable ,@(get-all-params params-ll))) (destructuring-bind ,options-ll (decode-options ,type) (declare (ignorable ,@(get-all-params options-ll))) ,form))))) (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro with-presentation-type-decoded ((name &optional (params nil params-p) (options nil options-p)) type &body body) (let ((type-var (gensym "TYPE-VAR"))) `(let* ((,type-var ,type) (,name (presentation-type-name ,type-var)) ,@(and params-p `((,params (decode-parameters ,type-var)))) ,@(and options-p `((,options (decode-options ,type-var))))) ,@body))) ) (eval-when (:compile-toplevel :load-toplevel :execute) (defun make-expansion-lambda (params-ll options-ll) (let ((params-form (recreate-lambda-list params-ll)) (options-form (recreate-lambda-list options-ll)) (parameters (gensym)) (options (gensym))) `(lambda (typespec) (with-presentation-type-decoded (name ,parameters ,options) typespec (make-type-spec name (destructuring-bind ,params-ll ,parameters ,params-form) (destructuring-bind ,options-ll ,options ,options-form))))))) (defvar *presentation-type-table* (make-hash-table :test #'eq)) (setf (gethash t *presentation-type-table*) (find-class t)) (defgeneric get-ptype-metaclass (type)) (defmethod get-ptype-metaclass ((type symbol)) (let ((maybe-meta (gethash type *presentation-type-table*))) (if maybe-meta (get-ptype-metaclass maybe-meta) (let ((system-meta (find-class type nil))) (and (typep system-meta 'standard-class) system-meta))))) (defmethod get-ptype-metaclass ((type presentation-type-class)) type) (defmethod get-ptype-metaclass ((type clos-presentation-type)) (clos-class type)) (defmethod get-ptype-metaclass ((type (eql *builtin-t-class*))) type) (defmethod get-ptype-metaclass ((type class)) type) (defmethod get-ptype-metaclass (type) (error "~A is not the name of a presentation type" type)) ;;; external functions (defun find-presentation-type-class (name &optional (errorp t) environment) (declare (ignore environment)) (let ((metaclass (get-ptype-metaclass name))) (cond (metaclass metaclass) (errorp (error "~S is not the name of a presentation type" name)) (t nil)))) (defun class-presentation-type-name (class &optional environment) (declare (ignore environment)) (cond ((typep class 'presentation-type) (type-name class)) (t (class-name class)))) ;;; For the presentation class T, the stand in object must not be a ;;; standard-object. So... why not the symbol T? (defvar *class-t-prototype* t) (defun prototype-or-error (name) (let ((ptype-meta (get-ptype-metaclass name))) (unless ptype-meta (error "~S is an unknown presentation type" name)) (when (eq ptype-meta *builtin-t-class*) (return-from prototype-or-error *class-t-prototype*)) (unless (clim-mop:class-finalized-p ptype-meta) (clim-mop:finalize-inheritance ptype-meta)) (or (clim-mop:class-prototype ptype-meta) (error "Couldn't find a prototype for ~S" name)))) (defun safe-cpl (class) (unless (clim-mop:class-finalized-p class) (clim-mop:finalize-inheritance class)) (clim-mop:class-precedence-list class)) (defun get-ptype (name) (or (gethash name *presentation-type-table*) (let ((meta (find-class name nil))) (and (typep meta 'standard-class) meta)))) (defgeneric presentation-ptype-supers (type) (:documentation "Gets a list of the presentation type objects for those supertypes of TYPE that are presentation types")) (defmethod presentation-ptype-supers ((type symbol)) (let ((ptype (gethash type *presentation-type-table*))) (if ptype (presentation-ptype-supers ptype) nil))) (defmethod presentation-ptype-supers ((type presentation-type-class)) (mapcan #'(lambda (class) (typecase class (presentation-type (list class)) (standard-class (let ((clos-ptype (gethash (class-name class) *presentation-type-table*))) (if clos-ptype (list clos-ptype) nil))) (t nil))) (clim-mop:class-direct-superclasses type))) (defmethod presentation-ptype-supers ((type clos-presentation-type)) (presentation-ptype-supers (clos-class type))) ;;; External function (defun presentation-type-direct-supertypes (type) (with-presentation-type-decoded (name) type (let ((supers (presentation-ptype-supers name))) (mapcar #'class-presentation-type-name supers)))) (eval-when (:compile-toplevel :load-toplevel :execute) (defmethod ptype-specializer ((type symbol)) (let ((ptype (gethash type *presentation-type-table*))) (cond (ptype (ptype-specializer ptype)) ((find-class type nil) (ptype-specializer (find-class type))) ;; Assume it's a forward referenced CLOS class. (t type)))) (defmethod ptype-specializer ((type standard-class)) (class-name type))) ;;; We need to patch defclass in every implementation to record a CLOS ;;; class at compiletime. On the other hand, I think we can assume ;;; that if a CLOS class exists at compile time, it will exist at ;;; load/run time too. (eval-when (:compile-toplevel :load-toplevel :execute) #-(or excl cmu sbcl openmcl) (defun compile-time-clos-p (name) (let ((meta (find-class name nil))) (and meta (typep meta 'standard-class)))) #+(or excl cmu sbcl openmcl) (defun compile-time-clos-p (name) (let ((metaclass (find-class name nil))) (or (and metaclass (typep metaclass 'standard-class)) (clim-lisp-patch::compile-time-clos-class-p name)))) (defun make-default-description (name) "Create a description string from the type name" (let ((downcase-name (string-downcase name))) (setq downcase-name (nsubstitute-if-not #\Space #'alphanumericp downcase-name)) (string-trim " " downcase-name))) (defun record-presentation-type (name parameters params-ll options options-ll inherit-from-func description history parameters-are-types compile-time-p supers expansion-func) (let* ((fake-name (make-presentation-type-name name)) (ptype-class-args (list :type-name name :parameters parameters :parameters-lambda-list params-ll :options options :options-lambda-list options-ll :inherit-from-function inherit-from-func :description description :history history :parameters-are-types parameters-are-types :expansion-function expansion-func)) (ptype-meta (if compile-time-p (apply #'make-instance (if (compile-time-clos-p name) 'clos-presentation-type 'presentation-type) ptype-class-args) (let* ((clos-meta (find-class name nil)) (closp (typep clos-meta 'standard-class))) (if closp (apply #'make-instance 'clos-presentation-type :clos-class clos-meta ptype-class-args) (let ((directs (mapcan #'(lambda (super) (if (eq super t) nil (list (or (get-ptype-metaclass super) super)))) supers))) (apply #'clim-mop:ensure-class fake-name :name fake-name :metaclass 'presentation-type-class :direct-superclasses directs ptype-class-args))))))) (setf (gethash name *presentation-type-table*) ptype-meta) ptype-meta)) ); eval-when (defgeneric massage-type-for-super (type-name super-name type-spec) (:documentation "translate TYPE-SPEC from that of TYPE-NAME to one suitable for SUPER-NAME")) ;;; The default: there ain't no direct specification (defmethod massage-type-for-super ((type-name t) (super-name t) type-spec) (declare (ignore type-spec)) (values nil nil)) ;;; Load-time actions for define-presentation-type (defmacro %define-presentation-type (name parameters params-ll options options-ll inherit-from inherit-from-lambda description history parameters-are-types) (declare (ignore inherit-from)) (let* ((inherit-from-func (coerce inherit-from-lambda 'function)) (inherit-typespec (funcall inherit-from-func (cons name (fake-params-args params-ll)))) (superclasses (if inherit-typespec (with-presentation-type-decoded (super-name super-params) inherit-typespec (if (eq super-name 'and) (mapcar #'presentation-type-name super-params) (list super-name))) nil)) (expansion-lambda (make-expansion-lambda params-ll options-ll))) `(progn (record-presentation-type ',name ',parameters ',params-ll ',options ',options-ll #',inherit-from-lambda ',description ',history ',parameters-are-types nil ',superclasses #',expansion-lambda) ,@(cond ((eq (presentation-type-name inherit-typespec) 'and) (loop for super in superclasses for i from 0 append (unless (or (not (atom super)) (eq super 'satisfies) (eq super 'not)) `((defmethod massage-type-for-super ((type-name (eql ',name)) (super-name (eql ',super)) type) (values (nth ,i (cdr (,inherit-from-lambda type))) t)))))) (superclasses `((defmethod massage-type-for-super ((type-name (eql ',name)) (super-name (eql ',(car superclasses))) type) (values (,inherit-from-lambda type) t)))) (t nil))))) (defmacro define-presentation-type (name parameters &key options inherit-from (description (make-default-description name)) (history t) parameters-are-types) (let* ((params-ll (transform-parameters-lambda-list parameters)) (options-ll (transform-options-lambda-list options)) (inherit-from-func (make-inherit-from-lambda params-ll options-ll inherit-from))) `(progn (eval-when (:compile-toplevel) (record-presentation-type ',name ',parameters ',params-ll ',options ',options-ll #',inherit-from-func ',description ',history ',parameters-are-types t nil nil)) (eval-when (:load-toplevel :execute) (%define-presentation-type ,name ,parameters ,params-ll ,options ,options-ll ,inherit-from ,inherit-from-func ,description ,history ,parameters-are-types))))) ;;; These are used by the presentation method MOP code, but are ;;; actually defined in presentation-defs.lisp after the forms for these ;;; types are executed. (defvar *ptype-t-class*) (defvar *ptype-expression-class*) (defvar *ptype-form-class*) (defun presentation-type-parameters (type-name &optional env) (declare (ignore env)) (let ((ptype (gethash type-name *presentation-type-table*))) (unless ptype (error "~S is not the name of a presentation type" type-name)) (parameters ptype))) (defun presentation-type-options (type-name &optional env) (declare (ignore env)) (let ((ptype (gethash type-name *presentation-type-table*))) (unless ptype (error "~S is not the name of a presentation type" type-name)) (options ptype))) (defmacro with-presentation-type-parameters ((type-name type) &body body) (let ((ptype (get-ptype type-name))) (unless (or ptype (compile-time-clos-p type-name)) (warn "~S is not a presentation type name." type-name)) (if (typep ptype 'presentation-type) (let* ((params-ll (parameters-lambda-list ptype)) (params (gensym "PARAMS")) (type-var (gensym "TYPE-VAR")) (ignorable-vars (get-all-params params-ll))) `(let ((,type-var ,type)) (unless (eq ',type-name (presentation-type-name ,type-var)) (error "Presentation type specifier ~S does not match the name ~S" ,type-var ',type-name)) (let ((,params (decode-parameters ,type-var))) (declare (ignorable ,params)) (destructuring-bind ,params-ll ,params (declare (ignorable ,@ignorable-vars)) ,@body)))) `(let () ,@body)))) (defmacro with-presentation-type-options ((type-name type) &body body) (let ((ptype (get-ptype type-name))) (unless (or ptype (compile-time-clos-p type-name)) (warn "~S is not a presentation type name." type-name)) (if (typep ptype 'presentation-type) (let* ((options-ll (options-lambda-list ptype)) (options (gensym "OPTIONS")) (type-var (gensym "TYPE-VAR")) (ignorable-vars (get-all-params options-ll))) `(let ((,type-var ,type)) (unless (eq ',type-name (presentation-type-name ,type-var)) (error "Presentation type specifier ~S does not match the name ~S" ,type-var ',type-name)) (let ((,options (decode-options ,type-var))) (declare (ignorable ,options)) (destructuring-bind ,options-ll ,options (declare (ignorable ,@ignorable-vars)) ,@body)))) `(let () ,@body)))) (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *presentation-type-abbreviations* (make-hash-table :test #'eq))) (defmacro define-presentation-type-abbreviation (name parameters equivalent-type &key options) `(eval-when (:compile-toplevel :load-toplevel :execute) (setf (gethash ',name *presentation-type-abbreviations*) #',(make-inherit-from-lambda (transform-parameters-lambda-list parameters) (transform-options-lambda-list options) equivalent-type)))) (defun make-type-spec (name parameters options) (cond (options `((,name ,@parameters) ,@options)) (parameters `(,name ,@parameters)) (t name))) (defun expand-presentation-type-abbreviation-1 (type &optional env) (flet ((expand-list (specs) (loop with expand-any-p = nil for spec in specs collect (multiple-value-bind (expansion expanded) (expand-presentation-type-abbreviation-1 spec env) (setq expand-any-p (or expand-any-p expanded)) expansion) into new-params finally (return (if expand-any-p (values new-params t) (values specs nil)))))) (with-presentation-type-decoded (name parms options) type (case name ((and or sequence sequence-enumerated) (multiple-value-bind (expansion expanded) (expand-list parms) (if expanded (values (make-type-spec name expansion options) t) (values type nil)))) (t (let* ((expander (gethash name *presentation-type-abbreviations*))) (flet ((copy-description (expanded-typespec) (with-presentation-type-decoded (expand-name expand-params expand-options) expanded-typespec (let ((description (getf options :description)) (expand-desc (getf expand-options :description))) (if (and description (null expand-desc)) (make-type-spec expand-name expand-params `(:description ,description ,@expand-options)) expanded-typespec))))) (if expander (values (copy-description (funcall expander type)) t) (values type nil))))))))) (defun expand-presentation-type-abbreviation (type &optional env) (let ((expand-any-p nil)) (loop (multiple-value-bind (expansion expanded) (expand-presentation-type-abbreviation-1 type env) (if expanded (progn (setq expand-any-p t) (setq type expansion)) (return (values type expand-any-p))))))) (defun make-presentation-type-specifier (name-and-params &rest options) (with-presentation-type-decoded (name) name-and-params (let ((ptype (gethash name *presentation-type-table*))) (unless ptype (return-from make-presentation-type-specifier name-and-params)) (with-presentation-type-decoded (name parameters defaults) (funcall (expansion-function ptype) name-and-params) (declare (ignore name parameters)) (loop for (key val) on options by #'cddr for default = (getf defaults key) unless (equal val default) nconc (list key val) into needed-options finally (return (if needed-options `(,name-and-params ,@needed-options) name-and-params))))))) ;;; Presentation methods. ;;; ;;; The basic dispatch is performed via CLOS instances that are standins ;;; for the presentation types. There are a couple of complications to ;;; this simple plan. First, methods on the presentation type class ;;;STANDARD-OBJECT -- if there are any -- should not be applicable to ;;;presentation types that are not CLOS classes, even though STANDARD-OBJECT ;;;is in the class precedence list of the standin object. Our own methods on ;;;COMPUTE-APPLICABLE-METHODS-USING-CLASSES and COMPUTE-APPLICABLE-METHODS ;;;remove methods specialized on standard-object. ;;; ;;; The second major complication is the whole raison d'etre of presentation ;;; type methods: type parameters and options are massaged so that ;;; applicable methods written on the supertype of a presentation type get ;;; parameters and options in the expected form. "Real" CLIM apparently ;;; does this massaging in the body of the effective method and passes the ;;; massaged parameters as an argument into the method. We do it with a ;;; function call within the body of the method. This is potentially more ;;; expensive, but caching should help that. Our method has the huge ;;; advantage of working with any method combination. (defclass presentation-gf-info () ((generic-function-name :accessor generic-function-name :initarg :generic-function-name) (lambda-list :accessor lambda-list :initarg :lambda-list) (type-key-arg :accessor type-key-arg :initarg :type-key-arg) (parameters-arg :accessor parameters-arg :initarg :parameters-arg :initform nil) (options-arg :accessor options-arg :initarg :options-arg :initform nil) (type-arg-position :accessor type-arg-position :initarg :type-arg-position))) (defvar *presentation-gf-table* (make-hash-table :test #'eq)) (defclass presentation-generic-function (standard-generic-function) () (:metaclass clim-mop:funcallable-standard-class)) (defvar *standard-object-class* (find-class 'standard-object)) #-scl (defmethod clim-mop:compute-applicable-methods-using-classes :around ((gf presentation-generic-function) classes) (multiple-value-bind (methods success) (call-next-method) (let ((ptype-class (car classes))) (if (or (null success) (not (typep ptype-class 'presentation-type-class))) (values methods success) (values (remove-if #'(lambda (method) (eq (car (clim-mop:method-specializers method)) *standard-object-class*)) methods) t))))) #+scl (defmethod clim-mop:compute-applicable-methods-using-classes :around ((gf presentation-generic-function) classes) (multiple-value-bind (methods success non-class-positions) (call-next-method) (let ((ptype-class (car classes))) (if (or (null success) (not (typep ptype-class 'presentation-type-class))) (values methods non-class-positions non-class-positions) (values (remove-if #'(lambda (method) (eq (car (clim-mop:method-specializers method)) *standard-object-class*)) methods) t non-class-positions))))) (defun method-applicable (method arguments) (loop for arg in arguments for specializer in (clim-mop:method-specializers method) always (cond ((typep specializer 'clim-mop:eql-specializer) (eql arg (clim-mop:eql-specializer-object specializer))) ((typep arg specializer) t) ((and (not (typep (class-of arg) 'presentation-type-class)) (or (eq specializer *ptype-form-class*) (eq specializer *ptype-expression-class*))) t) (t nil)))) (defmethod compute-applicable-methods :around ((gf presentation-generic-function) arguments) (let ((methods (call-next-method))) (if (typep (class-of (car arguments)) 'presentation-type-class) (remove-if #'(lambda (method) (eq (car (clim-mop:method-specializers method)) *standard-object-class*)) methods) methods))) ;;; The hard part of presentation methods: translating the type specifier for ;;; superclasses. ;;; (defmethod type-name ((type standard-class)) (class-name type)) (defmethod expansion-function ((type standard-class)) #'(lambda (typespec) (with-presentation-type-decoded (name) typespec name))) (defmethod presentation-ptype-supers ((type standard-class)) (mapcan #'(lambda (class) (let ((ptype (gethash (class-name class) *presentation-type-table*))) (and ptype (list ptype)))) (clim-mop:class-direct-superclasses type))) (defun translate-specifier-for-type (type-name super-name specifier) (when (eq type-name super-name) (return-from translate-specifier-for-type (values specifier t))) (multiple-value-bind (translation found) (massage-type-for-super type-name super-name specifier) (when found (return-from translate-specifier-for-type (values translation t)))) (loop for super in (presentation-ptype-supers type-name) do (multiple-value-bind (translation found) (translate-specifier-for-type (type-name super) super-name (massage-type-for-super type-name (type-name super) specifier)) (when found (return-from translate-specifier-for-type (values translation t))))) (values super-name nil)) ;;; XXX can options be specified without parameters? I think not. (defmacro define-presentation-generic-function (generic-function-name presentation-function-name lambda-list &rest options) (let ((type-key-arg (car lambda-list)) (parameters-arg (cadr lambda-list)) (options-arg (caddr lambda-list))) (unless (or (eq type-key-arg 'type-key) (eq type-key-arg 'type-class)) (error "The first argument in a presentation generic function must be type-key or type-class")) (unless (eq parameters-arg 'parameters) (setq parameters-arg nil)) (unless (eq options-arg 'options) (setq options-arg nil)) (let* ((gf-lambda-list (cons type-key-arg (cond (options-arg (cdddr lambda-list)) (parameters-arg (cddr lambda-list)) (t (cdr lambda-list))))) ;; XXX should check that it's required (type-arg-pos (position 'type gf-lambda-list))) (unless type-arg-pos (error "type must appear as an argument in a presentation generic function lambda list")) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) (setf (gethash ',presentation-function-name *presentation-gf-table*) (make-instance 'presentation-gf-info :generic-function-name ',generic-function-name :lambda-list ',lambda-list :type-key-arg ',type-key-arg :parameters-arg ',parameters-arg :options-arg ',options-arg :type-arg-position ,type-arg-pos))) (defgeneric ,generic-function-name ,gf-lambda-list (:generic-function-class presentation-generic-function) ,@options))))) (defun parse-method-body (args) (loop for arglist on args for (arg) = arglist while (atom arg) collect arg into qualifiers finally (if (and (consp arglist) (consp (cdr arglist)) (consp (cadr arglist)) (eq (caadr arglist) 'declare)) (return (values qualifiers arg (cadr arglist) (cddr arglist))) (return (values qualifiers arg nil (cdr arglist)))))) (defun type-name-from-type-key (type-key) (if (symbolp type-key) 't (type-name (class-of type-key)))) (defmacro define-presentation-method (name &rest args) (when (eq name 'presentation-subtypep) ;; I feel so unclean! (return-from define-presentation-method `(define-subtypep-method ,@args))) (let ((gf (gethash name *presentation-gf-table*))) (unless gf (error "~S is not a presentation generic function" name)) (with-accessors ((parameters-arg parameters-arg) (options-arg options-arg)) gf (multiple-value-bind (qualifiers lambda-list decls body) (parse-method-body args) (let ((type-arg (nth (1- (type-arg-position gf)) lambda-list))) (unless (consp type-arg) (error "Type argument in presentation method must be specialized")) (unless (eq (car type-arg) 'type) (error "Type argument mismatch with presentation generic function definition")) (destructuring-bind (type-var type-name) type-arg (let* ((method-ll `((,(type-key-arg gf) ,(ptype-specializer type-name)) ,@(copy-list lambda-list))) (real-body body) (massaged-type (gensym "MASSAGED-TYPE"))) (when options-arg (setq real-body `((let ((,options-arg (decode-options ,massaged-type))) (declare (ignorable ,options-arg)) (with-presentation-type-options (,type-name ,massaged-type) ,@real-body))))) (when parameters-arg (setq real-body `((let ((,parameters-arg (decode-parameters ,massaged-type))) (declare (ignorable ,parameters-arg)) (with-presentation-type-parameters (,type-name ,massaged-type) ,@real-body))))) (when (or options-arg parameters-arg) (setq real-body `((let ((,massaged-type (translate-specifier-for-type (type-name-from-type-key ,(type-key-arg gf)) ',type-name ,type-var))) ,@real-body)))) (setf (nth (type-arg-position gf) method-ll) type-var) `(defmethod ,(generic-function-name gf) ,@qualifiers ,method-ll ,@(when decls (list decls)) (block ,name ,@real-body))))))))) (defmacro define-default-presentation-method (name &rest args) (let ((gf (gethash name *presentation-gf-table*))) (unless gf (error "~S is not a presentation generic function" name)) (multiple-value-bind (qualifiers lambda-list decls body) (parse-method-body args) `(defmethod ,(generic-function-name gf) ,@qualifiers (,(type-key-arg gf) ,@lambda-list) (declare (ignorable ,(type-key-arg gf)) ,@(cdr decls)) (block ,name ,@body))))) ;;; Somewhat obsolete, but keep it around for apply-presentation-generic-function. (defun %funcall-presentation-generic-function (name gf type-arg-position &rest args) (declare (ignore name)) (let* ((type-spec (nth (1- type-arg-position) args)) (ptype-name (presentation-type-name type-spec))) (apply gf (prototype-or-error ptype-name) args))) ;;; I wonder if this pattern for preserving order of evaluation is ;;; has a more general use... (defmacro funcall-presentation-generic-function (name &rest args) (let ((gf (gethash name *presentation-gf-table*))) (unless gf (error "~S is not a presentation generic function" name)) (let* ((rebound-args (loop for arg in args unless (symbolp arg) collect (list (gensym "ARG") arg))) (gf-name (generic-function-name gf)) (type-spec-var (nth (1- (type-arg-position gf)) args))) `(let ,rebound-args (,gf-name (prototype-or-error (presentation-type-name ,(or (first (find type-spec-var rebound-args :key #'second)) type-spec-var))) ,@(mapcar #'(lambda (arg) ;; Order of evaluation doesn't matter ;; for symbols, and this shuts up ;; warnings about arguments in a ;; keyword position not being ;; constant. By the way, why do we ;; care about order of evaluation ;; here? -trh (or (first (find arg rebound-args :key #'second)) arg)) args)))))) (defmacro apply-presentation-generic-function (name &rest args) (let ((gf (gethash name *presentation-gf-table*))) (unless gf (error "~S is not a presentation generic function" name)) `(apply #'%funcall-presentation-generic-function ',name #',(generic-function-name gf) ,(type-arg-position gf) ,@args))) ;;; 23.7.1 Defining Presentation Translators (defclass presentation-translator () ((name :reader name :initarg :name) (from-type :reader from-type :initarg :from-type) (to-type :reader to-type :initarg :to-type) (gesture :reader gesture :initarg :gesture) (tester :reader tester :initarg :tester) (tester-definitive :reader tester-definitive :initarg :tester-definitive) (documentation :reader translator-documentation :initarg :documentation) (pointer-documentation :reader pointer-documentation :initarg :pointer-documentation) (menu :reader menu :initarg :menu) (priority :reader priority :initarg :priority :initform 0) (translator-function :reader translator-function :initarg :translator-function))) (defmethod initialize-instance :after ((obj presentation-translator) &key &allow-other-keys) (unless (slot-boundp obj 'pointer-documentation) (setf (slot-value obj 'pointer-documentation) (translator-documentation obj)))) (defmethod print-object ((obj presentation-translator) stream) (print-unreadable-object (obj stream :identity t) (format stream "Translator ~S from ~S to ~S" (name obj) (from-type obj) (to-type obj)))) (defclass presentation-action (presentation-translator) ()) (defmethod initialize-instance :after ((obj presentation-action) &key &allow-other-keys) (setf (slot-value obj 'tester-definitive) t)) (defmethod print-object ((obj presentation-action) stream) (print-unreadable-object (obj stream :identity t) (format stream "Action from ~S to ~S" (from-type obj) (to-type obj)))) ;;; This lives in a command table (defvar *current-translator-cache-generation* 0 "This is incremented whenever presentation translators are defined, and used to ensure that presentation-translators-caches are up to date.") (defclass translator-table () ((translators :accessor translators :initarg :translators :initform (make-hash-table :test #'eq) :documentation "Translators keyed by name.") (simple-type-translators :accessor simple-type-translators :initarg :simple-type-translators :initform (make-hash-table :test #'eq) :documentation "Holds transators with a simple from-type (i.e. doesn't contain \"or\" or \"and\").") (translator-cache-generation :accessor translator-cache-generation :initform 0) (presentation-translators-cache :writer (setf presentation-translators-cache) :initform (make-hash-table :test #'equal)))) (defun invalidate-translator-caches () (incf *current-translator-cache-generation*)) (defmethod presentation-translators-cache ((table translator-table)) (with-slots ((cache presentation-translators-cache) (generation translator-cache-generation)) table (unless (or (= generation *current-translator-cache-generation*) (zerop (hash-table-size cache))) (clrhash cache)) (setf generation *current-translator-cache-generation*) cache)) ;;; Returns function lambda list, ignore forms (defun make-translator-ll (translator-args) (let ((object-arg (find "object" translator-args :test #'string-equal)) (ignore-form nil)) (if object-arg (setq translator-args (remove "object" translator-args :test #'string-equal)) (progn (setq object-arg (gensym "OBJECT-ARG")) (setq ignore-form `(declare (ignore ,object-arg))))) (values `(,object-arg &key ,@translator-args &allow-other-keys) ignore-form))) (defun default-translator-tester (object-arg &key &allow-other-keys) (declare (ignore object-arg)) t) (defun add-translator (table translator) ;; Remove old one. (with-accessors ((translators translators) (simple-type-translators simple-type-translators)) table (let ((old (gethash (name translator) translators))) (when old (setf (gethash (presentation-type-name (from-type old)) simple-type-translators) (remove old (gethash (presentation-type-name (from-type old)) simple-type-translators)))) (invalidate-translator-caches) (setf (gethash (name translator) translators) translator) (push translator (gethash (from-type translator) simple-type-translators)) translator))) (defun make-translator-fun (args body) (multiple-value-bind (ll ignore) (make-translator-ll args) `(lambda ,ll ,@(and ignore (list ignore)) ,@body))) (defun make-documentation-fun (doc-arg) (cond ((and doc-arg (symbolp doc-arg)) doc-arg) ((consp doc-arg) (make-translator-fun (car doc-arg) (cdr doc-arg))) ((stringp doc-arg) `(lambda (object &key stream &allow-other-keys) (declare (ignore object)) (write-string ,doc-arg stream))) ((null doc-arg) `(lambda (object &key presentation stream &allow-other-keys) (present object (presentation-type presentation) :stream stream :sensitive nil))) (t (error "Can't handle doc-arg ~S" doc-arg)))) (defmacro define-presentation-translator (name (from-type to-type command-table &rest translator-options &key (gesture :select) (tester 'default-translator-tester testerp) (tester-definitive (if testerp nil t)) (documentation nil documentationp) (pointer-documentation nil pointer-documentation-p) (menu t) (priority 0) (translator-class 'presentation-translator) &allow-other-keys) arglist &body body) ;; null tester should be the same as no tester (unless tester (setq tester 'default-translator-tester) (setq tester-definitive t)) (let* ((real-from-type (expand-presentation-type-abbreviation from-type)) (real-to-type (expand-presentation-type-abbreviation to-type))) (with-keywords-removed (translator-options (:gesture :tester :tester-definitive :documentation :pointer-documentation :menu :priority :translator-class)) `(add-translator (presentation-translators (find-command-table ',command-table)) (make-instance ',translator-class :name ',name :from-type ',real-from-type :to-type ',real-to-type :gesture ,(if (eq gesture t) t `(gethash ',gesture *gesture-names*)) :tester ,(if (symbolp tester) `',tester `#',(make-translator-fun (car tester) (cdr tester))) :tester-definitive ',tester-definitive :documentation #',(make-documentation-fun (if documentationp documentation (command-name-from-symbol name))) ,@(when pointer-documentation-p `(:pointer-documentation #',(make-documentation-fun pointer-documentation))) :menu ',menu :priority ,priority :translator-function #',(make-translator-fun arglist body) ,@translator-options))))) (defmacro define-presentation-action (name (from-type to-type command-table &key (gesture :select) (tester 'default-translator-tester) (documentation nil documentationp) (pointer-documentation nil pointer-documentation-p) (menu t) (priority 0)) arglist &body body) (let* ((real-from-type (expand-presentation-type-abbreviation from-type)) (real-to-type (expand-presentation-type-abbreviation to-type))) `(add-translator (presentation-translators (find-command-table ',command-table)) (make-instance 'presentation-action :name ',name :from-type ',real-from-type :to-type ',real-to-type :gesture ,(if (eq gesture t) t `(gethash ',gesture *gesture-names*)) :tester ,(if (symbolp tester) `',tester `#',(make-translator-fun (car tester) (cdr tester))) :tester-definitive t :documentation #',(make-documentation-fun (if documentationp documentation (command-name-from-symbol name))) ,@(when pointer-documentation-p `(:pointer-documentation #',(make-documentation-fun pointer-documentation))) :menu ',menu :priority ,priority :translator-function #',(make-translator-fun arglist body))))) ;;; define-presentation-to-command-translator is in commands.lisp ;;; 23.7.2 Presentation Translator Functions ;;; Used by map-over-presentation-type-supertypes as well (defun map-over-ptype-superclasses (function type) (let* ((type-name (presentation-type-name type)) (type-meta (get-ptype-metaclass type-name)) (type-is-ptype (typep type-meta 'presentation-type-class))) (unless type-meta (return-from map-over-ptype-superclasses nil)) (loop for super-meta in (safe-cpl type-meta) ;; structure classes? when (and (or (typep super-meta 'standard-class) (eq super-meta *builtin-t-class*)) (not (and type-is-ptype (eq super-meta *standard-object-class*)))) do (funcall function super-meta)))) ;;; This is to implement the requirement on presentation translators ;;; for doing subtype calculations without reference to type ;;; parameters. We are generous in that we return T when we are ;;; unsure, to give translator testers a chance to accept or reject ;;; the translator. This is essentially ;;; (multiple-value-bind (yesp surep) ;;; (presentation-subtypep maybe-subtype type) ;;; (or yesp (not surep))) ;;; except faster. (defun stupid-subtypep (maybe-subtype type) "Return t if maybe-subtype is a presentation subtype of type, regardless of parameters." (when (or (eq maybe-subtype nil) (eq type t)) (return-from stupid-subtypep t)) (when (eql maybe-subtype type) (return-from stupid-subtypep t)) (let ((maybe-subtype-name (presentation-type-name maybe-subtype)) (type-name (presentation-type-name type))) (cond ;; see DEFUN PRESENTATION-SUBTYPEP for some caveats ((eq maybe-subtype-name 'or) (let ((or-types (decode-parameters maybe-subtype))) (every (lambda (x) (stupid-subtypep x type)) or-types))) ((eq type-name 'and) (stupid-subtypep maybe-subtype (car (decode-parameters type)))) ((eq type-name 'or) (let ((or-types (decode-parameters type))) (some (lambda (x) (stupid-subtypep maybe-subtype x)) or-types))) ((eq maybe-subtype-name 'and) ;; this clause is actually not conservative, but probably in a ;; way that no-one will complain about too much. Basically, we ;; will only return T if the first type in the AND (which is ;; treated specially by CLIM) is subtypep the maybe-supertype (stupid-subtypep (car (decode-parameters maybe-subtype)) type)) (t (let ((subtype-meta (get-ptype-metaclass maybe-subtype-name)) (type-meta (get-ptype-metaclass type-name))) (unless (and subtype-meta type-meta) (return-from stupid-subtypep nil)) (map-over-ptype-superclasses #'(lambda (super) (when (eq type-meta super) (return-from stupid-subtypep t))) maybe-subtype-name) nil))))) (defun find-presentation-translators (from-type to-type command-table) (let* ((command-table (find-command-table command-table)) (from-name (presentation-type-name from-type)) (to-name (presentation-type-name to-type)) (cached-translators (gethash (cons from-name to-name) (presentation-translators-cache (presentation-translators command-table))))) (when cached-translators (return-from find-presentation-translators cached-translators)) (let ((translator-vector (make-array 8 :adjustable t :fill-pointer 0)) (table-counter 0)) (do-command-table-inheritance (table command-table) (let ((translator-map (simple-type-translators (presentation-translators table)))) (flet ((get-translators (type) (let ((translators (gethash type translator-map))) (loop for translator in translators if (stupid-subtypep (to-type translator) to-type) do (vector-push-extend (cons translator table-counter) translator-vector))))) (map-over-ptype-superclasses #'(lambda (super) (get-translators (type-name super))) from-name))) (incf table-counter)) (let ((from-super-names nil)) (map-over-ptype-superclasses #'(lambda (super) (push (type-name super) from-super-names)) from-name) (setq from-super-names (nreverse from-super-names)) ;; The Spec mentions "high order priority" and "low order priority" ;; without saying what that is! Fortunately, the Franz CLIM user guide ;; says that high order priority is (floor priority 10), low order ;; priority is (mod priority 10.) That's pretty wacked... (flet ((translator-lessp (a b) (destructuring-bind (translator-a . table-num-a) a (destructuring-bind (translator-b . table-num-b) b (multiple-value-bind (hi-a low-a) (floor (priority translator-a)) (multiple-value-bind (hi-b low-b) (floor (priority translator-b)) ;; High order priority (cond ((> hi-a hi-b) (return-from translator-lessp t)) ((< hi-a hi-b) (return-from translator-lessp nil))) ;; more specific (let ((a-precedence (position (presentation-type-name (from-type translator-a)) from-super-names)) (b-precedence (position (presentation-type-name (from-type translator-b)) from-super-names))) (cond ((< a-precedence b-precedence) (return-from translator-lessp t)) ((> a-precedence b-precedence) (return-from translator-lessp nil)))) ;; Low order priority (cond ((> low-a low-b) (return-from translator-lessp t)) ((< low-a low-b) (return-from translator-lessp nil))))) ;; Command table inheritance (< table-num-a table-num-b))))) ;; Add translators to their caches. (setf (gethash (cons from-name to-name) (presentation-translators-cache (presentation-translators command-table))) (remove-duplicates (map 'list #'car (sort translator-vector #'translator-lessp))))))))) (defgeneric call-presentation-translator (translator presentation context-type frame event window x y)) (defmethod call-presentation-translator ((translator presentation-translator) presentation context-type frame event window x y) ;; Let the translator return an explict ptype of nil to, in effect, abort the ;; presentation throw. (multiple-value-call #'(lambda (object &optional (ptype context-type) options) (values object ptype options)) (funcall (translator-function translator) (presentation-object presentation) :presentation presentation :context-type context-type :frame frame :event event :window window :x x :y y))) (defmethod call-presentation-translator ((translator presentation-action) presentation context-type frame event window x y) (funcall (translator-function translator) (presentation-object presentation) :presentation presentation :context-type context-type :frame frame :event event :window window :x x :y y) (values nil nil nil)) (defun document-presentation-translator (translator presentation context-type frame event window x y &key (stream *standard-output*) (documentation-type :normal)) (funcall (if (eq documentation-type :normal) (translator-documentation translator) (pointer-documentation translator)) (presentation-object presentation) :presentation presentation :context-type context-type :frame frame :event event :window window :x x :y y :stream stream)) ;;; :button is a pointer button state, for performing matches where we want to ;;; restrict the match to certain gestures but don't have a real event. (defun test-presentation-translator (translator presentation context-type frame window x y &key event (modifier-state 0) for-menu button) (flet ((match-gesture (gesture event modifier-state) (let ((modifiers (if event (event-modifier-state event) modifier-state))) (or (eq gesture t) for-menu (loop for g in gesture thereis (and (eql modifiers (caddr g)) (or (and button (eql button (cadr g))) (and (null button) (or (null event) (eql (pointer-event-button event) (cadr g))))))))))) (let* ((from-type (from-type translator))) (unless (match-gesture (gesture translator) event modifier-state) (return-from test-presentation-translator nil)) (unless (or (null (decode-parameters from-type)) (presentation-typep (presentation-object presentation) from-type)) (return-from test-presentation-translator nil)) (unless (or (null (tester translator)) (funcall (tester translator) (presentation-object presentation) :presentation presentation :context-type context-type :frame frame :window window :x x :y y :event event)) (return-from test-presentation-translator nil)) (unless (or (tester-definitive translator) (null (decode-parameters context-type)) (presentation-typep (call-presentation-translator translator presentation context-type frame event window x y) context-type)) (return-from test-presentation-translator nil)))) t) ;;; presentation-contains-position moved to presentation-defs.lisp (defun map-over-presentations-containing-position (func record x y) "maps recursively over all presentations in record, including record." (map-over-output-records-containing-position #'(lambda (child) (when (output-record-p child) ; ? What else could it be? --moore (map-over-presentations-containing-position func child x y)) #+nil (when (presentationp child) (funcall func child))) record x y) (when (and (presentationp record) (presentation-contains-position record x y)) (funcall func record))) (defvar *null-presentation*) (defun map-applicable-translators (func presentation input-context frame window x y &key event (modifier-state 0) for-menu button) (flet ((process-presentation (context context-ptype presentation) (let ((maybe-translators (find-presentation-translators (presentation-type presentation) context-ptype (frame-command-table frame)))) (loop for translator in maybe-translators when (and (or (not for-menu) (eql for-menu (menu translator))) (test-presentation-translator translator presentation context-ptype frame window x y :event event :modifier-state modifier-state :for-menu for-menu :button button)) do (funcall func translator presentation context))))) (if (and (presentationp presentation) (presentation-subtypep (presentation-type presentation) 'blank-area)) (loop for context in input-context for (context-ptype) = context do (process-presentation context context-ptype presentation)) (loop for context in input-context for (context-ptype) = context do (map-over-presentations-containing-position #'(lambda (p) (process-presentation context context-ptype p)) presentation x y))))) (defun window-modifier-state (window) "Provides default modifier state for presentation translator functions." (let ((pointer (port-pointer (port window)))) (pointer-modifier-state pointer))) (defun find-applicable-translators (presentation input-context frame window x y &key event (modifier-state (window-modifier-state window)) for-menu fastp) (let ((results nil)) (flet ((fast-func (translator presentation context) (declare (ignore translator presentation context)) (return-from find-applicable-translators t)) (slow-func (translator presentation context) (push (list translator presentation (input-context-type context)) results))) (map-applicable-translators (if fastp #'fast-func #'slow-func) presentation input-context frame window x y :event event :modifier-state modifier-state :for-menu for-menu) (nreverse results)))) (defun presentation-matches-context-type (presentation context-type frame window x y &key event (modifier-state 0)) (let* ((ptype (expand-presentation-type-abbreviation (presentation-type presentation))) (ctype (expand-presentation-type-abbreviation context-type)) (translators (find-presentation-translators ptype ctype (frame-command-table frame)))) (loop for translator in translators if (test-presentation-translator translator presentation ctype frame window x y :event event :modifier-state modifier-state) do (return-from presentation-matches-context-type t)) nil)) ;;; 23.7.3 Finding Applicable Presentations (defun find-innermost-presentation-match (input-context top-record frame window x y event modifier-state button) "Helper function that implements the \"innermost-smallest\" input-context presentation matching algorithm. Returns presentation, translator, and matching input context." (let ((result nil) (result-translator nil) (result-context nil) (result-size nil)) (map-applicable-translators #'(lambda (translator presentation context) (if (and result-context (not (eq result-context context))) ;; Return inner presentation (return-from find-innermost-presentation-match (values result result-translator result-context)) (multiple-value-bind (min-x min-y max-x max-y) (output-record-hit-detection-rectangle* presentation) (let ((size (* (- max-x min-x) (- max-y min-y)))) (when (or (not result) (< size result-size)) (setq result presentation) (setq result-translator translator) (setq result-context context) (setq result-size size)))))) top-record input-context frame window x y :event event :modifier-state modifier-state :button button) (when result (return-from find-innermost-presentation-match (values result result-translator result-context))) (map-applicable-translators #'(lambda (translator presentation context) (return-from find-innermost-presentation-match (values presentation translator context))) *null-presentation* input-context frame window x y :event event :modifier-state modifier-state :button button)) nil) (defun find-innermost-applicable-presentation (input-context window x y &key (frame *application-frame*) (modifier-state (window-modifier-state window)) event) (values (find-innermost-presentation-match input-context (stream-output-history window) frame window x y event modifier-state nil))) (defun find-innermost-presentation-context (input-context window x y &key (top-record (stream-output-history window)) (frame *application-frame*) event (modifier-state (window-modifier-state window)) button) (find-innermost-presentation-match input-context top-record frame window x y event modifier-state button)) (defun throw-highlighted-presentation (presentation input-context event) (let ((x (pointer-event-x event)) (y (pointer-event-y event)) (window (event-sheet event))) (multiple-value-bind (p translator context) (find-innermost-presentation-match input-context presentation *application-frame* (event-sheet event) x y event 0 nil) (when p (multiple-value-bind (object ptype options) (call-presentation-translator translator p (input-context-type context) *application-frame* event window x y) (when ptype (funcall (cdr context) object ptype event options))))))) (defvar *input-context*) (defun throw-object-ptype (object type &key (input-context *input-context*) sheet) "Throw an object and presentation type within input-context without a presentation" (throw-highlighted-presentation (make-instance 'standard-presentation :object object :type type :single-box t) input-context (make-instance 'pointer-button-press-event :sheet sheet :x 0 :y 0 :modifier-state 0 :button +pointer-left-button+))) (defstruct presentation-translator-menu-item translator presentation context) (defun call-presentation-menu (presentation input-context frame window x y &key (for-menu t) label) (let (items) (map-applicable-translators #'(lambda (translator presentation context) (push `(,(make-presentation-translator-menu-item :translator translator :presentation presentation :context context) :documentation ,(with-output-to-string (stream) (document-presentation-translator translator presentation input-context frame nil window x y :stream stream))) items)) presentation input-context frame window x y :for-menu for-menu) (when items (setq items (nreverse items)) (multiple-value-bind (item object event) (menu-choose items :label label :associated-window window :printer #'(lambda (item stream) (let ((object (first item))) (document-presentation-translator (presentation-translator-menu-item-translator object) (presentation-translator-menu-item-presentation object) (presentation-translator-menu-item-context object) frame nil window x y :stream stream))) :label label :pointer-documentation *pointer-documentation-output*) (declare (ignore object)) (when item (multiple-value-bind (object ptype options) (call-presentation-translator (presentation-translator-menu-item-translator item) (presentation-translator-menu-item-presentation item) (presentation-translator-menu-item-context item) frame event window x y) (when ptype (funcall (cdr (presentation-translator-menu-item-context item)) object ptype event options)))))))) #+nil (defmethod highlight-output-record ((record standard-presentation) stream state) (map-over-output-records (lambda (child) (highlight-output-record child stream state)) record)) ;;; Context-dependent input ;;; An input context is a cons of a presentation type and a continuation to ;;; call to return a presentation to that input context. (defvar *input-context* nil) (defun input-context-type (context-entry) (car context-entry)) ;;; Many presentation functions, internal and external, take an input ;;; context as an argument, but they really only need to look at one ;;; presentation type. (defun make-fake-input-context (ptype) (list (cons (expand-presentation-type-abbreviation ptype) #'(lambda (object type event options) (declare (ignore event options)) (error "Fake input context called with object ~S type ~S. ~ This shouldn't happen!" object type))))) (defun input-context-wait-test (stream) (let* ((queue (stream-input-buffer stream)) (event (event-queue-peek queue))) (when event (let ((sheet (event-sheet event))) (when (and (output-recording-stream-p sheet) (or (typep event 'pointer-event) (typep event 'keyboard-event)) (not (gadgetp sheet))) (return-from input-context-wait-test t)))) nil)) (defun highlight-applicable-presentation (frame stream input-context &optional (prefer-pointer-window t)) (let* ((queue (stream-input-buffer stream)) (event (event-queue-peek queue))) (when (and event (or (and (typep event 'pointer-event) (or prefer-pointer-window (eq stream (event-sheet event)))) (typep event 'keyboard-event))) ;; Stream only needs to see button press events. ;; XXX Need to think about this more. Should any pointer events be ;; passed through? If there's no presentation, maybe? (unless (typep event 'keyboard-event) (event-queue-read queue)) (progn (frame-input-context-track-pointer frame input-context (event-sheet event) event) (when (typep event 'pointer-button-press-event) (funcall *pointer-button-press-handler* stream event))) #+nil (if (and (typep event 'pointer-motion-event) (pointer-event-button event)) (frame-drag frame input-context (event-sheet event) event) )))) (defun input-context-event-handler (stream) (highlight-applicable-presentation *application-frame* stream *input-context*)) (defun input-context-button-press-handler (stream button-event) (declare (ignore stream)) (frame-input-context-button-press-handler *application-frame* (event-sheet button-event) button-event)) (defun highlight-current-presentation (frame input-context) (let ((event (synthesize-pointer-motion-event (port-pointer (port *application-frame*))))) (when event (frame-input-context-track-pointer frame input-context (event-sheet event) event)))) (defmacro with-input-context ((type &key override) (&optional (object-var (gensym)) (type-var (gensym)) event-var options-var) form &body pointer-cases) (let ((vars `(,object-var ,type-var ,@(and event-var `(,event-var)) ,@(and options-var `(,options-var)))) (return-block (gensym "RETURN-BLOCK")) (context-block (gensym "CONTEXT-BLOCK"))) `(block ,return-block (multiple-value-bind ,vars (block ,context-block (let ((*input-context* (cons (cons (expand-presentation-type-abbreviation ,type) #'(lambda (object type event options) (return-from ,context-block (values object type event options)))) ,(if override nil '*input-context*))) (*pointer-button-press-handler* #'input-context-button-press-handler) (*input-wait-test* #'input-context-wait-test) (*input-wait-handler* #'input-context-event-handler)) (return-from ,return-block ,form ))) (declare (ignorable ,@vars)) (highlight-current-presentation *application-frame* *input-context*) (cond ,@(mapcar #'(lambda (pointer-case) (destructuring-bind (case-type &body case-body) pointer-case `((presentation-subtypep ,type-var ',case-type) ,@case-body))) pointer-cases)))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/decls.lisp0000644000175000017500000012000511345155771016771 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-INTERNALS; -*- ;;; --------------------------------------------------------------------------- ;;; Title: DEFGENERICs and stuff ;;; Created: 2001-08-12 ;;; Author: Gilbert Baumann ;;; License: LGPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2001,2002 by Gilbert Baumann ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) ;;; This is just an ad hoc list. Would it be a good idea to include all ;;; (exported) generic functions here? --GB ;;; ;;; YES! -- CSR ;;; We'll get right on it :) -- moore ;;; Whose numbers are we using here? ;;; The numbers are section numbers from the spec. --GB ;; Since the declaim form for functions looks clumsy and is ;; syntax-wise different from defun, we define us a new declfun, which ;; fixes this. (defmacro declfun (name lambda-list) `(declaim (ftype (function ,(let ((q lambda-list) res) (do () ((or (null q) (member (car q) '(&optional &rest &key)))) (push 't res) (pop q)) (when (eq (car q) '&optional) (push '&optional res) (pop q) (do () ((or (null q) (member (car q) '(&rest &key)))) (pop q) (push 't res))) (when (eq (car q) '&rest) (push '&rest res) (pop q) (push 't res) (pop q)) (when (eq (car q) '&key) (push '&key res) (pop q) (do () ((or (null q) (member (car q) '(&allow-other-keys)))) (push (list (intern (string (if (consp (car q)) (if (consp (caar q)) (caaar q) (caar q)) (car q))) :keyword) 't) res) (pop q))) (when (eq (car q) '&allow-other-keys) (push '&allow-other-keys res) (pop q)) (reverse res)) t) ,name))) ;;;; Early special variables (defvar *application-frame* nil) ;;; 3.2.1.1 The Point Protocol (defgeneric point-x (point)) (defgeneric point-y (point)) ;;; 3.2.2.1 The Polygon and Polyline Protocol (defgeneric polygon-points (polygon-or-polyline)) (defgeneric map-over-polygon-coordinates (function polygon-or-polyline)) (defgeneric map-over-polygon-segments (function polygon-or-polyline)) (defgeneric polyline-closed (polyline)) ;;; 3.2.3.1 The Line Protocol (defgeneric line-start-point* (line)) (defgeneric line-end-point* (line)) (defgeneric line-start-point (line)) (defgeneric line-end-point (line)) ;;; 3.2.4.1 (defgeneric rectangle-edges* (rectangle)) (defgeneric rectangle-min-point (rectangle)) (defgeneric rectangle-max-point (rectangle)) (defgeneric rectangle-min-x (rectangle)) (defgeneric rectangle-min-y (rectangle)) (defgeneric rectangle-max-x (rectangle)) (defgeneric rectangle-max-y (rectangle)) (defgeneric rectangle-width (rectangle)) (defgeneric rectangle-height (rectangle)) (defgeneric rectangle-size (rectangle)) ;;; 3.2.5.1 The Ellipse and Elliptical Arc Protocol (defgeneric ellipse-center-point* (elliptical-object)) (defgeneric ellipse-center-point (elliptical-object)) (defgeneric ellipse-radii (elliptical-object)) (defgeneric ellipse-start-angle (elliptical-object)) (defgeneric ellipse-end-angle (elliptical-object)) ;;; 4.1.1 The Bounding Rectangle Protocol (defgeneric bounding-rectangle* (region)) (defgeneric bounding-rectangle (region)) ;;; 4.1.2 Bounding Rectangle Convenience Functions (defgeneric bounding-rectangle-position (region)) (defgeneric bounding-rectangle-min-x (region)) (defgeneric bounding-rectangle-min-y (region)) (defgeneric bounding-rectangle-max-x (region)) (defgeneric bounding-rectangle-max-y (region)) (defgeneric bounding-rectangle-width (region)) (defgeneric bounding-rectangle-height (region)) (defgeneric bounding-rectangle-size (region)) ;;; 5.3.1 Transformation Predicates (defgeneric transformation-equal (transformation1 transformation2)) (defgeneric identity-transformation-p (transformation)) (defgeneric invertible-transformation-p (transformation)) (defgeneric translation-transformation-p (transformation)) (defgeneric reflection-transformation-p (transformation)) (defgeneric rigid-transformation-p (transformation)) (defgeneric even-scaling-transformation-p (transformation)) (defgeneric scaling-transformation-p (transformation)) (defgeneric rectilinear-transformation-p (transformation)) ;;; 5.3.2 Composition of Transformations (defgeneric compose-transformations (transformation1 transformation2)) (defgeneric invert-transformation (transformation)) (declfun compose-translation-with-transformation (transformation dx dy)) (declfun compose-scaling-with-transformation (transformation sx sy &optional origin)) (declfun compose-rotation-with-transformation (transformation angle &optional origin)) (declfun compose-transformation-with-translation (transformation dx dy)) (declfun compose-transformation-with-scaling (transformation sx sy &optional origin)) (declfun compose-transformation-with-rotation (transformation angle &optional origin)) ;;; 5.3.3 Applying Transformations (defgeneric transform-region (transformation region)) (defgeneric untransform-region (transformation region)) (defgeneric transform-position (transformation x y)) (defgeneric untransform-position (transformation x y)) (defgeneric transform-distance (transformation dx dy)) (defgeneric untransform-distance (transformation dx dy)) (defgeneric transform-rectangle* (transformation x1 y1 x2 y2)) (defgeneric untransform-rectangle* (transformation x1 y1 x2 y2)) ;;; 7.2.1 Sheet Relationship Functions (defgeneric sheet-parent (sheet)) (defgeneric sheet-children (sheet)) (defgeneric sheet-adopt-child (sheet child)) (defgeneric sheet-disown-child (sheet child &key errorp)) (defgeneric sheet-siblings (sheet)) (defgeneric sheet-enabled-children (sheet)) (defgeneric sheet-ancestor-p (sheet putative-ancestor)) (defgeneric raise-sheet (sheet)) (defgeneric bury-sheet (sheet)) (defgeneric reorder-sheets (sheet new-ordering)) (defgeneric sheet-enabled-p (sheet)) (defgeneric (setf sheet-enabled-p) (enabled-p sheet)) (defgeneric sheet-viewable-p (sheet)) (defgeneric sheet-occluding-sheets (sheet child)) (defgeneric map-over-sheets (function sheet)) ;;; 7.3.1 Sheet Geometry Functions [complete] (defgeneric sheet-transformation (sheet)) (defgeneric (setf sheet-transformation) (transformation sheet)) (defgeneric sheet-region (sheet)) (defgeneric (setf sheet-region) (region sheet)) (defgeneric move-sheet (sheet x y)) (defgeneric resize-sheet (sheet width height)) (defgeneric move-and-resize-sheet (sheet x y width height)) (defgeneric map-sheet-position-to-parent (sheet x y)) (defgeneric map-sheet-position-to-child (sheet x y)) (defgeneric map-sheet-rectangle*-to-parent (sheet x1 y1 x2 y2)) (defgeneric map-sheet-rectangle*-to-child (sheet x1 y1 x2 y2)) (defgeneric map-over-sheets-containing-position (function sheet x y)) (defgeneric map-over-sheets-overlapping-region (function sheet region)) (defgeneric child-containing-position (sheet x y)) (defgeneric children-overlapping-region (sheet region)) (defgeneric children-overlapping-rectangle* (sheet x1 y1 x2 y2)) (defgeneric sheet-delta-transformation (sheet ancestor)) (defgeneric sheet-allocated-region (sheet child)) ;;; 7.3.2 ;; sheet-identity-transformation-mixin [class] ;; sheet-translation-mixin [class] ;; sheet-y-inverting-transformation-mixin [class] ;; sheet-transformation-mixin [class] ;;;; 8.1 (defgeneric process-next-event (port &key wait-function timeout)) (defgeneric port-keyboard-input-focus (port)) (defgeneric (setf port-keyboard-input-focus) (focus port)) ;;; 8.2 Standard Device Events (defgeneric event-timestamp (event)) (defgeneric event-type (event)) (defgeneric event-sheet (device-event)) (defgeneric event-modifier-state (device-event)) (defgeneric keyboard-event-key-name (keyboard-event)) (defgeneric keyboard-event-character (keyboard-event)) (defgeneric pointer-event-x (pointer-event)) (defgeneric pointer-event-y (pointer-event)) (defgeneric pointer-event-native-x (pointer-event)) (defgeneric pointer-event-native-y (pointer-event)) (defgeneric pointer-event-pointer (pointer-event)) (defgeneric pointer-event-button (pointer-button-event)) (defgeneric pointer-boundary-event-kind (pointer-boundary-event)) (defgeneric window-event-region (window-event)) (defgeneric window-event-native-region (window-event)) (defgeneric window-event-mirrored-sheet (window-event)) ;;; 8.3.1 Output Properties (defgeneric medium-foreground (medium)) (defgeneric (setf medium-foreground) (design medium)) (defgeneric medium-background (medium)) (defgeneric (setf medium-background) (design medium)) (defgeneric medium-ink (medium)) (defgeneric (setf medium-ink) (design medium)) (defgeneric medium-transformation (medium)) (defgeneric (setf medium-transformation) (transformation medium)) (defgeneric medium-clipping-region (medium)) (defgeneric (setf medium-clipping-region) (region medium)) (defgeneric medium-line-style (medium)) (defgeneric (setf medium-line-style) (line-style medium)) (defgeneric medium-text-style (medium)) (defgeneric (setf medium-text-style) (text-style medium)) (defgeneric medium-default-text-style (medium)) (defgeneric (setf medium-default-text-style) (text-style medium)) (defgeneric medium-merged-text-style (medium)) ;;;; 8.3.4 Associating a Medium with a Sheet ;; with-sheet-medium (medium sheet) &body body [Macro] ;; with-sheet-medium-bound (sheet medium) &body body [Macro] (defgeneric sheet-medium (sheet)) (defgeneric medium-sheet (medium)) (defgeneric medium-drawable (medium)) ;;; 8.3.4.1 Grafting and Degrafting of Mediums (defgeneric allocate-medium (port sheet)) (defgeneric deallocate-medium (port medium)) (defgeneric make-medium (port sheet)) (defgeneric engraft-medium (medium port sheet)) (defgeneric degraft-medium (medium port sheet)) ;;; 8.4.1 Repaint Protocol Functions (defgeneric queue-repaint (sheet repaint-event)) (defgeneric handle-repaint (sheet region)) (defgeneric repaint-sheet (sheet region)) ;;;; 9 Ports, Grafts, and Mirrored Sheets ;; (defgeneric portp (object)) ;; find-port function ;;; 9.2 Ports (defgeneric port (object)) (defgeneric port-server-path (port)) (defgeneric port-name (port)) (defgeneric port-type (port)) (defgeneric port-properties (port indicator)) (defgeneric (setf port-properties) (property port indicator)) (defgeneric restart-port (port)) (defgeneric destroy-port (port)) ;;; 9.3 Grafts (defgeneric sheet-grafted-p (sheet)) (declfun find-graft (&key (server-path *default-server-path*) (port (find-port :server-path server-path)) (orientation :default) (units :device))) (defgeneric graft (object)) (declfun map-over-grafts (function port)) ;; with-graft-locked (graft) &body body [macro] (defgeneric graft-orientation (graft)) (defgeneric graft-units (graft)) (defgeneric graft-width (graft &key units)) (defgeneric graft-height (graft &key units)) (declfun graft-pixels-per-millimeter (graft)) (declfun graft-pixels-per-inch (graft)) ;; 9.4.1 Mirror Functions (defgeneric sheet-direct-mirror (sheet)) (defgeneric sheet-mirrored-ancestor (sheet)) (defgeneric sheet-mirror (sheet)) (defgeneric realize-mirror (port mirrored-sheet)) (defgeneric destroy-mirror (port mirrored-sheet)) (defgeneric raise-mirror (port sheet)) (defgeneric bury-mirror (port sheet)) ;; 9.4.2 Internal Interfaces for Native Coordinates (defgeneric sheet-native-transformation (sheet)) (defgeneric sheet-native-region (sheet)) (defgeneric sheet-device-transformation (sheet)) (defgeneric sheet-device-region (sheet)) (defgeneric invalidate-cached-transformations (sheet)) (defgeneric invalidate-cached-regions (sheet)) ;;; Graphics ops (defgeneric medium-draw-point* (medium x y)) (defgeneric medium-draw-points* (medium coord-seq)) (defgeneric medium-draw-line* (medium x1 y1 x2 y2)) (defgeneric medium-draw-lines* (medium coord-seq)) (defgeneric medium-draw-polygon* (medium coord-seq closed filled)) (defgeneric medium-draw-rectangle* (medium left top right bottom filled)) (defgeneric medium-draw-ellipse* (medium center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy start-angle end-angle filled)) (defgeneric medium-draw-circle* (medium center-x center-y radius start-angle end-angle filled)) (defgeneric medium-draw-text* (medium string x y start end align-x align-y toward-x toward-y transform-glyphs)) ;;; 10.1 Medium Components ;;; ;;; For reasons that are beyond me, many of the medium component ;;; accessors are also specified in section 8.3.1. (defgeneric medium-current-text-style (medium)) ;;;; 10.2 (defgeneric invoke-with-drawing-options (medium continuation &rest drawing-options &key &allow-other-keys)) ;;;; 10.2.1 (defgeneric invoke-with-identity-transformation (medium continuation)) ;;;; 10.2.2 (defgeneric invoke-with-local-coordinates (medium continuation x y)) (defgeneric invoke-with-first-quadrant-coordinates (medium continuation x y)) ;;; 11.1.1 Text Style Protocol and Text Style Suboptions (defgeneric text-style-components (text-style)) (defgeneric text-style-family (text-style)) (defgeneric text-style-face (text-style)) (defgeneric text-style-size (text-style)) (defgeneric merge-text-styles (style1 style2)) (defgeneric text-style-ascent (text-style medium)) (defgeneric text-style-descent (text-style medium)) (defgeneric text-style-height (text-style medium)) (defgeneric text-style-width (text-style medium)) (defgeneric text-style-fixed-width-p (text-style medium)) (defgeneric text-size (medium string &key text-style start end)) ;;; 11.2 Text Style Binding Forms (defgeneric invoke-with-text-style (medium continuation text-style)) ;;; 12.7.3 Other Medium-specific Output Functions (defgeneric medium-finish-output (medium)) (defgeneric medium-force-output (medium)) (defgeneric medium-clear-area (medium left top right bottom)) (defgeneric medium-beep (medium)) ;;;; 14.2 (defgeneric pattern-width (pattern) (:documentation "Return the width of `pattern'.")) (defgeneric pattern-height (pattern) (:documentation "Return the height of `pattern'.")) (defgeneric pattern-array (pattern) (:documentation "Returns the array associated with `pattern'.")) (defgeneric pattern-designs (pattern) (:documentation "Returns the array of designs associated with `pattern'.")) ;;;; 14.5 (defgeneric draw-design (medium design &key ink clipping-region transformation line-style line-thickness line-unit line-dashes line-joint-shape line-cap-shape text-style text-family text-face text-size)) ;;; 15.3 The Text Cursor [complete] ;;; 15.3.1 Text Cursor Protocol [complete] ;; cursor [protocol class] ;; cursorp object [protocol predicate] ;; :sheet [Initarg for cursor] ;; standard-text-cursor [class] (defgeneric cursor-sheet (cursor)) (defgeneric cursor-position (cursor)) ;;(defgeneric (setf* cursor-position) (x y cursor)) (defgeneric cursor-active (cursor)) (defgeneric (setf cursor-active) (value cursor)) (defgeneric cursor-state (cursor)) (defgeneric (setf cursor-state) (value cursor)) (defgeneric cursor-focus (cursor)) (defgeneric cursor-visibility (cursor)) (defgeneric (setf cursor-visibility) (visibility cursor)) ;;; 15.3.2 Stream Text Cursor Protocol [complete] (defgeneric stream-text-cursor (stream)) (defgeneric (setf stream-text-cursor) (cursor stream)) (defgeneric stream-cursor-position (stream)) ;; (defgeneric (setf* stream-cursor-position) (x y stream)) unsure how to declare this, can somebody help? --GB (defgeneric stream-set-cusor-position (stream x y)) ; This is actually in 19.3.1 in CLIM 2.2 (defgeneric stream-increment-cursor-position (stream dx dy)) ;;; 15.4 Text Protocol [complete] (defgeneric stream-character-width (stream character &key text-style)) (defgeneric stream-string-width (stream character &key start end text-style)) (defgeneric stream-text-margin (stream)) (defgeneric (setf stream-text-margin) (margin stream)) (defgeneric stream-line-height (stream &key text-style)) (defgeneric stream-vertical-spacing (stream)) (defgeneric stream-baseline (stream)) ;;; 15.4.1 Mixing Text and Graphics [complete] ;; with-room-for-graphics (&optional stream &key (first-quadrant t) height (move-cursor t) record-type) &body body [Macro] ;;; 15.4.2 Wrapping of Text Lines [complete] (defgeneric stream-end-of-line-action (stream)) (defgeneric (setf stream-end-of-line-action) (action stream)) ;; with-end-of-line-action (stream action) &body body [Macro] (defgeneric stream-end-of-page-action (stream)) (defgeneric (setf stream-end-of-page-action) (action stream)) ;; with-end-of-page-action (stream action) &body body [Macro] ;;; 15.5 Attracting the User's Attention (defgeneric beep (&optional medium)) ;;; 15.6 Buffering of Output (defgeneric medium-buffering-output-p (medium)) (defgeneric (setf medium-buffering-output-p) (buffer-p medium)) ;;; 16.3.3 Text Displayed Output Record (defgeneric add-character-output-to-text-record (text-record character text-style width height baseline)) (defgeneric add-string-output-to-text-record (text-record string start end text-style width height baseline)) (defgeneric text-displayed-output-record-string (text-record)) ;;; 16.4.1. The Output Recording Stream Protocol (defgeneric stream-recording-p (stream)) (defgeneric (setf stream-recording-p) (recording-p stream)) (defgeneric stream-drawing-p (stream)) (defgeneric (setf stream-drawing-p) (drawing-p stream)) (defgeneric stream-output-history (stream)) (defgeneric stream-current-output-record (stream)) (defgeneric (setf stream-current-output-record) (record stream)) (defgeneric stream-add-output-record (stream record)) (defgeneric stream-replay (stream &optional region)) (defgeneric erase-output-record (record stream &optional errorp)) ;;; 16.4.3. Text Output Recording (defgeneric stream-text-output-record (stream text-style)) (defgeneric stream-close-text-output-record (stream)) (defgeneric stream-add-character-output (stream character text-style width height baseline)) (defgeneric stream-add-string-output (stream string start end text-style width height baseline)) ;;; 16.4.4 Output Recording Utilities [complete] ;; with-output-recording-options (stream &key record draw) &body body [Macro] (defgeneric invoke-with-output-recording-options (stream continuation record draw)) ;;; with-new-output-record (stream &optional record-type record &rest initargs) &body body [Macro] ;;; The 'constructor' arg is absent from the CLIM 2.0 spec but is documented ;;; in the Allegro CLIM 2 User Guide and appears to exist in other 'classic' ;;; CLIM implementations. I'm assuming it's an omission from the spec. (defgeneric invoke-with-new-output-record (stream continuation record-type constructor &key &allow-other-keys)) ;;; with-output-to-output-record (stream &optional record-type record &rest initargs)) &body body [Macro] (defgeneric invoke-with-output-to-output-record (stream continuation record-type constructor &rest initargs &key &allow-other-keys)) (defgeneric make-design-from-output-record (record)) ;;;; 21.2 (defgeneric invoke-updating-output (stream continuation record-type unique-id id-test cache-value cache-test &key fixed-position all-new parent-cache)) ;;; 22.2.1 The Extended Stream Input Protocol (defgeneric stream-input-buffer (stream)) (defgeneric (setf stream-input-buffer) (buffer stream)) ;; (defgeneric (setf* stream-pointer-position)) (defgeneric stream-set-input-focus (stream)) (defgeneric stream-read-gesture (stream &key timeout peek-p input-wait-test input-wait-handler pointer-button-press-handler)) (defgeneric stream-input-wait (stream &key timeout input-wait-test)) (defgeneric stream-unread-gesture (stream gesture)) ;;; 22.2.2 Extended Input Stream Conditions (defgeneric abort-gesture-event (condition)) (defgeneric accelerator-gesture-event (condition)) (defgeneric accelerator-gesture-numeric-argument (condition)) ;;; 23.5 Context-dependent (Typed) Input (defgeneric stream-accept (stream type &key view default default-type provide-default insert-default replace-input history active-p prompt prompt-mode display-default query-identifier activation-gestures additional-activation-gestures delimiter-gestures additional-delimiter-gestures)) (defgeneric prompt-for-accept (stream type view &rest accept-args &key)) ;;; 24.1 The Input Editor (defgeneric input-editor-format (stream format-string &rest args) (:documentation "This function is like `format', except that it is intended to be called on input editing streams. It arranges to insert \"noise strings\" in the input editor's input buffer. Programmers can use this to display in-line prompts in `accept' methods. If `stream' is a stream that is not an input editing stream, then `input-editor-format' is equivalent to format.")) (defgeneric redraw-input-buffer (stream &optional start-from) (:documentation "Displays the input editor's buffer starting at the position `start-position' on the interactive stream that is encapsulated by the input editing stream `stream'.")) ;;; 24.1.1 The Input Editing Stream Protocol (defgeneric stream-insertion-pointer (stream) (:documentation "Returns an integer corresponding to the current input position in the input editing stream `stream's buffer, that is, the point in the buffer at which the next user input gesture will be inserted. The insertion pointer will always be less than (fill-pointer (stream-input-buffer stream)). The insertion pointer can also be thought of as an editing cursor.")) (defgeneric (setf stream-insertion-pointer) (pointer stream) (:documentation "Changes the input position of the input editing stream `stream' to `pointer'. `Pointer' is an integer, and must be less than (fill-pointer (stream-input-buffer stream))")) (defgeneric stream-scan-pointer (stream) (:documentation "Returns an integer corresponding to the current scan pointer in the input editing stream `stream's buffer, that is, the point in the buffer at which calls to `accept' have stopped parsing input. The scan pointer will always be less than or equal to (stream-insertion-pointer stream).")) (defgeneric (setf stream-scan-pointer) (pointer stream) (:documentation "Changes the scan pointer of the input editing stream `stream' to `pointer'. `Pointer' is an integer, and must be less than or equal to (stream-insertion-pointer stream)")) (defgeneric stream-rescanning-p (stream) (:documentation "Returns the state of the input editing stream `stream's \"rescan in progress\" flag, which is true if stream is performing a rescan operation, otherwise it is false. All extended input streams must implement a method for this, but non-input editing streams will always returns false.")) (defgeneric reset-scan-pointer (stream &optional scan-pointer) (:documentation "Sets the input editing stream stream's scan pointer to `scan-pointer', and sets the state of `stream-rescanning-p' to true.")) (defgeneric immediate-rescan (stream) (:documentation "Invokes a rescan operation immediately by \"throwing\" out to the most recent invocation of `with-input-editing'.")) (defgeneric queue-rescan (stream) (:documentation "Indicates that a rescan operation on the input editing stream `stream' should take place after the next non-input editing gesture is read by setting the \"rescan queued\" flag to true. ")) (defgeneric rescan-if-necessary (stream &optional inhibit-activation) (:documentation "Invokes a rescan operation on the input editing stream `stream' if `queue-rescan' was called on the same stream and no intervening rescan operation has taken place. Resets the state of the \"rescan queued\" flag to false. If `inhibit-activation' is false, the input line will not be activated even if there is an activation character in it.")) (defgeneric erase-input-buffer (stream &optional start-position) (:documentation "Erases the part of the display that corresponds to the input editor's buffer starting at the position `start-position'.")) ;;; McCLIM relies on a text editor class (by default ;;; DREI-INPUT-EDITING-MIXIN) to perform the user interaction and ;;; display for input editing. Also, that class must update the stream ;;; buffer and the insertion pointer, cause rescans to happen, and ;;; handle activation gestures. (defgeneric stream-process-gesture (stream gesture type) (:documentation "If gesture is an input editing command, stream-process-gesture performs the input editing operation on the input editing stream `stream' and returns NIL. Otherwise, it returns the two values `gesture' and `type'.")) ;;; 24.4 Reading and Writing of Tokens (defgeneric replace-input (stream new-input &key start end buffer-start rescan) ;; XXX: Nonstandard behavior for :rescan. (:documentation "Replaces the part of the input editing stream `stream's input buffer that extends from `buffer-start' to its scan pointer with the string `new-input'. `buffer-start' defaults to the current input position of stream, which is the position at which the current accept \"session\" starts. `start' and `end' can be supplied to specify a subsequence of `new-input'; start defaults to 0 and end defaults to the length of `new-input'. `replace-input' will queue a rescan by calling `queue-rescan' if the new input does not match the old input, or `rescan' is true. If `rescan' is explicitly provided as NIL, no rescan will be queued in any case. The returned value is the position in the input buffer.")) (defgeneric presentation-replace-input (stream object type view &key buffer-start rescan query-identifier for-context-type) (:documentation "Like `replace-input', except that the new input to insert into the input buffer is gotten by presenting `object' with the presentation type `type' and view `view'. `buffer-start' and `rescan' are as for `replace-input', and `query-identifier' and `for-context-type' as as for `present'. Typically, this function will be implemented by calling `present-to-string' on `object', `type', `view', and `for-context-type', and then calling `replace-input' on the resulting string. If the object cannot be transformed into an acceptable textual form, it may be inserted as a special \"accept result\" that is considered a single gesture. These accept result objects have no standardised form.")) ;;; 27.3 Command Menus (defgeneric display-command-table-menu (command-table stream &key max-width max-height n-rows n-columns x-spacing y-spacing initial-spacing row-wise cell-align-x cell-align-y move-cursor) (:documentation "Display a menu of the commands accessible in `command-table' to `stream'. `max-width', `max-height', `n-rows', `n-columns', `x-spacing', `y-spacing', `row-wise', `initial-spacing', `cell-align-x', `cell-align-y', and `move-cursor' are as for `formatting-item-list'.")) ;;; 28.2 Specifying the Panes of a Frame (defgeneric destroy-frame (frame)) (defgeneric raise-frame (frame)) (defgeneric bury-frame (frame)) ;;; 28.3 Application Frame Functions (defgeneric frame-name (frame)) (defgeneric frame-pretty-name (frame)) (defgeneric (setf frame-pretty-name) (name frame)) (defgeneric frame-command-table (frame)) (defgeneric (setf frame-command-table) (command-table frame)) (defgeneric frame-standard-output (frame)) (defgeneric frame-standard-input (frame)) (defgeneric frame-query-io (frame)) (defgeneric frame-error-output (frame)) (defgeneric frame-pointer-documentation-output (frame)) (defgeneric frame-calling-frame (frame)) (defgeneric frame-parent (frame)) (defgeneric frame-panes (frame)) (defgeneric frame-top-level-sheet (frame)) (defgeneric frame-current-panes (frame)) (defgeneric get-frame-pane (frame pane-name)) (defgeneric fine-pane-named (frame pane-name)) (defgeneric frame-current-layout (frame)) (defgeneric (setf frame-current-layout) (layout frame)) (defgeneric frame-all-layouts (frame)) (defgeneric layout-frame (frame &optional width height)) (defgeneric frame-exit-frame (condition)) (defgeneric frame-exit (frame)) (defgeneric pane-needs-redisplay (pane)) (defgeneric (setf pane-needs-redisplay) (value pane)) (defgeneric redisplay-frame-pane (frame pane &key force-p)) (defgeneric redisplay-frame-panes (frame &key force-p)) (defgeneric frame-replay (frame stream &optional region)) (defgeneric notify-user (frame message &key associated-window title documentation exit-boxes name style text-style)) (defgeneric frame-properties (frame property)) (defgeneric (setf frame-properties) (value frame property)) ;;; 28.3.1 Interface with Presentation Types (defgeneric frame-maintain-presentation-histories (frame)) (defgeneric frame-find-innermost-applicable-presentation (frame input-context stream x y &key event)) (defgeneric frame-input-context-button-press-handler (frame stream button-prees-event)) (defgeneric frame-document-highlighted-presentation (frame presentation input-context window-context x y stream)) (defgeneric frame-drag-and-drop-feedback (frame presentation stream initial-x initial-y new-x new-y state)) (defgeneric frame-drag-and-drop-highlighting (frame presentation stream state)) ;;;; 28.4 (defgeneric default-frame-top-level (frame &key command-parser command-unparser partial-command-parser prompt)) (defgeneric read-frame-command (frame &key stream)) (defgeneric run-frame-top-level (frame &key &allow-other-keys)) (defgeneric command-enabled (command-name frame)) (defgeneric (setf command-name) (enabled command-name frame)) (defgeneric display-command-menu (frame stream &key command-table initial-spacing row-wise max-width max-height n-rows n-columns cell-align-x cell-align-y) (:documentation "Display the command table associated with `command-table' on `stream' by calling `display-command-table-menu'. If no command table is provided, (frame-command-table frame) will be used. The arguments `initial-spacing', `row-wise', `max-width', `max-height', `n-rows', `n-columns', `cell-align-x', and `cell-align-y' are as for `formatting-item-list'.")) ;;;; 28.5.2 Frame Manager Operations (defgeneric frame-manager (frame)) (defgeneric (setf frame-manager) (frame-manager frame)) (defgeneric frame-manager-frames (frame-manager)) (defgeneric adopt-frame (frame-manager frame)) (defgeneric disown-frame (frame-manager frame)) (defgeneric frame-state (frame)) (defgeneric enable-frame (frame)) (defgeneric disable-frame (frame)) (defgeneric shrink-frame (frame)) (defgeneric note-frame-enabled (frame-manager frame)) (defgeneric note-frame-disabled (frame-manager frame)) (defgeneric note-frame-iconified (frame-manager frame)) (defgeneric note-frame-deiconified (frame-manager frame)) (defgeneric note-command-enabled (frame-manager frame command-name)) (defgeneric note-command-disabled (frame-manager frame command-name)) (defgeneric frame-manager-notify-user (framem message-string &key frame associated-window title documentation exit-boxes name style text-style)) (defgeneric generate-panes (frame-manager frame)) (defgeneric find-pane-for-frame (frame-manager frame)) ;;; 28.5.3 Frame Manager Settings (defgeneric (setf client-setting) (value frame setting)) (defgeneric reset-frame (frame &rest client-settings)) ;;;; 29.2 ;;;; ;;;; FIXME: should we have &key &allow-other-keys here, to cause ;;;; initarg checking? Probably. (defgeneric make-pane-1 (realizer frame abstract-class-name &rest initargs)) ;;;; 29.2.2 Pane Properties (defgeneric pane-frame (pane)) (defgeneric pane-name (pane)) (defgeneric pane-foreground (pane)) (defgeneric pane-background (pane)) (defgeneric pane-text-style (pane)) ;;;; 29.3.3 Scroller Pane Classes (defgeneric pane-viewport (pane)) (defgeneric pane-viewport-region (pane)) (defgeneric pane-scroller (pane)) (defgeneric scroll-extent (pane x y)) (deftype scroll-bar-spec () '(member t :both :vertical :horizontal nil)) ;;;; 29.3.4 The Layout Protocol ;; (define-protocol-class space-requirement ()) ;; make-space-requirement &key (width 0) (max-width 0) (min-width 0) (height 0) (max-height 0) (min-height 0) [Function] (defgeneric space-requirement-width (space-req)) (defgeneric space-requirement-min-width (space-req)) (defgeneric space-requirement-max-width (space-req)) (defgeneric space-requirement-height (space-req)) (defgeneric space-requirement-min-height (space-req)) (defgeneric space-requirement-max-height (space-req)) (defgeneric space-requirement-components (space-req)) ;; space-requirement-combine function sr1 sr2 [Function] ;; space-requirement+ sr1 sr2 [Function] ;; space-requirement+* space-req &key width min-width max-width height min-height max-height [Function] (defgeneric compose-space (pane &key width height) (:documentation "During the space composition pass, a composite pane will typically ask each of its children how much space it requires by calling COMPOSE-SPACE. They answer by returning space-requirement objects. The composite will then form its own space requirement by composing the space requirements of its children according to its own rules for laying out its children. Returns a SPACE-REQUIREMENT object.")) (defgeneric allocate-space (pane width height)) (defgeneric change-space-requirements (pane &rest space-req-keys &key resize-frame width height min-width min-height max-width max-height)) (defgeneric note-space-requirements-changed (sheet pane)) ;; changing-space-requirements (&key resize-frame layout) &body body [Macro] ;;;; 29.4.4 CLIM Stream Pane Functions (defgeneric window-clear (window)) (defgeneric window-refresh (window)) (defgeneric window-viewport (window)) (defgeneric window-erase-viewport (window)) (defgeneric window-viewport-position (window)) ;; (defgeneric (setf* window-viewport-position) (x y window)) ;;; D.2 Basic Stream Functions ;;; Gray Streamoid functions, but not part of any Gray proposal. (defgeneric stream-pathname (stream)) (defgeneric stream-truename (stream)) ;;;; (defgeneric gadget-value (gadget)) (defgeneric (setf gadget-value) (new-value gadget &key invoke-callback)) (defgeneric gadget-min-value (gadget)) (defgeneric gadget-max-value (gadget)) (defgeneric (setf gadget-max-value) (new-value gadget)) (defgeneric (setf gadget-min-value) (new-value gadget)) (defgeneric (setf scroll-bar-thumb-size) (new-value scroll-bar)) (defgeneric gadget-orientation (gadget)) (defgeneric gadget-client (gadget)) ;;; (defgeneric text-style-mapping (port text-style &optional character-set)) (defgeneric (setf text-style-mapping) (mapping port text-style &optional character-set)) (defgeneric medium-miter-limit (medium) (:documentation "If LINE-STYLE-JOINT-SHAPE is :MITER and the angle between two consequent lines is less than the values return by MEDIUM-MITER-LIMIT, :BEVEL is used instead.")) (defgeneric line-style-effective-thickness (line-style medium) (:documentation "Returns the thickness in device units of a line, rendered on MEDIUM with the style LINE-STYLE.")) ;;; (defgeneric text-style-character-width (text-style medium char)) ;; fall back, where to put this? (defmethod text-style-character-width (text-style medium char) (text-size medium char :text-style text-style)) (declfun draw-rectangle (sheet point1 point2 &rest args &key (filled t) ink clipping-region transformation line-style line-thickness line-unit line-dashes line-joint-shape)) (declfun draw-rectangle* (sheet x1 y1 x2 y2 &rest args &key (filled t) ink clipping-region transformation line-style line-thickness line-unit line-dashes line-joint-shape)) ;;; "exported" from a port (defgeneric mirror-transformation (port mirror)) (defgeneric port-set-sheet-region (port sheet region)) (defgeneric port-set-sheet-transformation (port sheet region)) (defgeneric port-text-style-mappings (port)) (defgeneric port-lookup-mirror (port sheet)) (defgeneric port-register-mirror (port sheet mirror)) (defgeneric port-allocate-pixmap (port sheet width height)) (defgeneric port-deallocate-pixmap (port pixmap)) (defgeneric port-mirror-width (port sheet)) (defgeneric port-mirror-height (port sheet)) (defgeneric port-enable-sheet (port sheet)) (defgeneric port-disable-sheet (port sheet)) (defgeneric port-pointer (port)) (defgeneric pointer-update-state (pointer event) (:documentation "Called by port event dispatching code to update the modifier and button states of the pointer.")) ;;; ;; Used in stream-input.lisp, defined in frames.lisp (defgeneric frame-event-queue (frame)) ;;; Used in presentations.lisp, defined in commands.lisp (defgeneric presentation-translators (command-table)) (defgeneric stream-default-view (stream)) ;;; ---------------------------------------------------------------------- (defgeneric output-record-basline (record) (:documentation "Returns two values: the baseline of an output record and a boolean indicating if this baseline is definitive. McCLIM addition.")) (defgeneric encapsulating-stream-stream (encapsulating-stream) (:documentation "The stream encapsulated by an encapsulating stream")) #|| Further undeclared functions FRAME-EVENT-QUEUE FRAME-EXIT PANE-FRAME ALLOCATE-SPACE COMPOSE-SPACE FIND-INNERMOST-APPLICABLE-PRESENTATION HIGHLIGHT-PRESENTATION-1 PANE-DISPLAY-FUNCTION PANE-DISPLAY-TIME PANE-NAME PRESENTATION-OBJECT PRESENTATION-TYPE SPACE-REQUIREMENT-HEIGHT SPACE-REQUIREMENT-WIDTH THROW-HIGHLIGHTED-PRESENTATION WINDOW-CLEAR (SETF GADGET-MAX-VALUE) (SETF GADGET-MIN-VALUE) (SETF SCROLL-BAR-THUMB-SIZE) SLOT-ACCESSOR-NAME::|CLIM-INTERNALS CLIENT slot READER| DRAW-EDGES-LINES* FORMAT-CHILDREN GADGET-VALUE MAKE-MENU-BAR TABLE-PANE-NUMBER MEDIUM WITH-GRAPHICS-STATE PORT-MIRROR-HEIGHT PORT-MIRROR-WIDTH TEXT-STYLE-CHARACTER-WIDTH FIND-INNERMOST-APPLICABLE-PRESENTATION HIGHLIGHT-PRESENTATION-1 PRESENTATION-OBJECT PRESENTATION-TYPE THROW-HIGHLIGHTED-PRESENTATION FORMAT-CHILDREN TABLE-PANE-NUMBER TEXT-STYLE-CHARACTER-WIDTH PORT-MIRROR-HEIGHT PORT-MIRROR-WIDTH SCROLL-EXTENT TEXT-STYLE-CHARACTER-WIDTH FRAME-EVENT-QUEUE FRAME-EXIT PANE-FRAME ALLOCATE-SPACE COMPOSE-SPACE FIND-INNERMOST-APPLICABLE-PRESENTATION HIGHLIGHT-PRESENTATION-1 PANE-DISPLAY-FUNCTION PANE-DISPLAY-TIME PANE-NAME PRESENTATION-OBJECT PRESENTATION-TYPE SPACE-REQUIREMENT-HEIGHT SPACE-REQUIREMENT-WIDTH THROW-HIGHLIGHTED-PRESENTATION WINDOW-CLEAR (SETF GADGET-MAX-VALUE) (SETF GADGET-MIN-VALUE) (SETF SCROLL-BAR-THUMB-SIZE) SLOT-ACCESSOR-NAME::|CLIM-INTERNALS CLIENT slot READER| DRAW-EDGES-LINES* FORMAT-CHILDREN GADGET-VALUE MAKE-MENU-BAR TABLE-PANE-NUMBER ||# cl-mcclim-0.9.6.dfsg.cvs20100315.orig/ports.lisp0000640000175000017500000003762210705412614017045 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 1998,1999,2000,2001 by Michael McDonald (mikemac@mikemac.com) ;;; (c) copyright 2000 by ;;; Iban Hatchondo (hatchond@emi.u-bordeaux.fr) ;;; Julien Boninfante (boninfan@emi.u-bordeaux.fr) ;;; Robert Strandh (strandh@labri.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) (defvar *default-server-path* nil) ;; - CLX is the de-facto reference backend. ;; - Prefer Graphic-Forms and Gtkairo over CLX, since they get installed only ;; on explicit user request anyway. ;; - If both are present, use Graphics-Forms in favour of Gtkairo, since ;; it is the native Windows backend. ;; - Beagle should be treated like Graphic-Forms in the long term, but is ;; currently lacking a maintainer, so let's leave it near the end. ;; - OpenGL and Null are in this list mostly to document their existence, ;; and neither is currently a complete backend we would want to make ;; a default. Put them after CLX, so that they won't actually be reached. (defvar *server-path-search-order* '(:graphic-forms :gtkairo :clx :opengl :beagle :null)) (defun find-default-server-path () (loop for port in *server-path-search-order* if (get port :port-type) do (return-from find-default-server-path (list port)) finally (error "No CLIM backends have been loaded!"))) (defvar *all-ports* nil) (defclass basic-port (port) ((server-path :initform nil :initarg :server-path :reader port-server-path) (properties :initform nil :initarg :properties) (grafts :initform nil :accessor port-grafts) (frame-managers :initform nil :reader frame-managers) (sheet->mirror :initform (make-hash-table :test #'eq)) (mirror->sheet :initform (make-hash-table :test #'eq)) (pixmap->mirror :initform (make-hash-table :test #'eq)) (mirror->pixmap :initform (make-hash-table :test #'eq)) (event-process :initform nil :initarg :event-process :accessor port-event-process :documentation "In a multiprocessing environment, the particular process reponsible for calling PROCESS-NEXT-EVENT in a loop.") (lock :initform (make-recursive-lock "port lock") :accessor port-lock) (event-count :initform 0) (text-style-mappings :initform (make-hash-table :test #'eq) :reader port-text-style-mappings) (pointer-sheet :initform nil :accessor port-pointer-sheet :documentation "The sheet the pointer is over, if any"))) (defmethod port-keyboard-input-focus (port) (when (null *application-frame*) (error "~S called with null ~S" 'port-keyboard-input-focus '*application-frame*)) (port-frame-keyboard-input-focus port *application-frame*)) (defmethod (setf port-keyboard-input-focus) (focus port) (when (null *application-frame*) (error "~S called with null ~S" '(setf port-keyboard-input-focus) '*application-frame*)) (unless (eq *application-frame* (pane-frame focus)) (error "frame mismatch in ~S" '(setf port-keyboard-input-focus))) (setf (port-frame-keyboard-input-focus port *application-frame*) focus)) (defgeneric port-frame-keyboard-input-focus (port frame)) (defgeneric (setf port-frame-keyboard-input-focus) (focus port frame)) (defun find-port (&key (server-path *default-server-path*)) (if (null server-path) (setq server-path (find-default-server-path))) (if (atom server-path) (setq server-path (list server-path))) (setq server-path (funcall (get (first server-path) :server-path-parser) server-path)) (loop for port in *all-ports* if (equal server-path (port-server-path port)) do (return port) finally (let ((port-type (get (first server-path) :port-type)) port) (if (null port-type) (error "Don't know how to make a port of type ~S" server-path)) (setq port (funcall 'make-instance port-type :server-path server-path)) (push port *all-ports*) (return port)))) (defmethod initialize-instance :after ((port basic-port) &rest args) (declare (ignorable args)) ) (defmethod destroy-port :before ((port basic-port)) (when (and *multiprocessing-p* (port-event-process port)) (destroy-process (port-event-process port)) (setf (port-event-process port) nil))) (defmethod port-lookup-mirror ((port basic-port) (sheet mirrored-sheet-mixin)) (gethash sheet (slot-value port 'sheet->mirror))) (defmethod port-lookup-sheet ((port basic-port) mirror) (gethash mirror (slot-value port 'mirror->sheet))) (defmethod port-register-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror) (setf (gethash sheet (slot-value port 'sheet->mirror)) mirror) (setf (gethash mirror (slot-value port 'mirror->sheet)) sheet) nil) (defmethod port-unregister-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror) (remhash sheet (slot-value port 'sheet->mirror)) (remhash mirror (slot-value port 'mirror->sheet)) nil) (defmethod realize-mirror ((port basic-port) (sheet mirrored-sheet-mixin)) (error "Don't know how to realize the mirror of a generic mirrored-sheet")) (defmethod destroy-mirror ((port basic-port) (sheet mirrored-sheet-mixin)) (error "Don't know how to destroy the mirror of a generic mirrored-sheet")) (defmethod mirror-transformation ((port basic-port) mirror) (declare (ignore mirror)) (error "MIRROR-TRANSFORMATION is not implemented for generic ports")) (defmethod port-properties ((port basic-port) indicator) (with-slots (properties) port (getf properties indicator))) (defmethod (setf port-properties) (value (port basic-port) indicator) (with-slots (properties) port (setf (getf properties indicator) value))) (defmethod get-next-event ((port basic-port) &key wait-function timeout) (declare (ignore wait-function timeout)) (error "Calling GET-NEXT-EVENT on a PORT protocol class")) (defmethod get-next-event :after ((port basic-port) &key wait-function timeout) (declare (ignore wait-function timeout)) (with-slots (event-count) port (incf event-count))) (defmethod process-next-event ((port basic-port) &key wait-function timeout) (let ((event (get-next-event port :wait-function wait-function :timeout timeout))) (cond ((null event) nil) ((eq event :timeout) (values nil :timeout)) (t (distribute-event port event) t)))) (defmethod distribute-event ((port basic-port) event) (cond ((typep event 'keyboard-event) (dispatch-event (event-sheet event) event)) ((typep event 'window-event) ; (dispatch-event (window-event-mirrored-sheet event) event) (dispatch-event (event-sheet event) event)) ((typep event 'pointer-event) (dispatch-event (event-sheet event) event)) ((typep event 'window-manager-delete-event) ;; not sure where this type of event should get sent - mikemac ;; This seems fine; will be handled by the top-level-sheet-pane - moore (dispatch-event (event-sheet event) event)) ((typep event 'timer-event) (error "Where do we send timer-events?")) (t (error "Unknown event ~S received in DISTRIBUTE-EVENT" event)))) (defmacro with-port-locked ((port) &body body) (let ((fn (gensym "CONT."))) `(labels ((,fn () ,@body)) (declare (dynamic-extent #',fn)) (invoke-with-port-locked ,port #',fn)))) (defmethod invoke-with-port-locked ((port basic-port) continuation) (with-recursive-lock-held ((port-lock port)) (funcall continuation))) (defun map-over-ports (function) (mapc function *all-ports*)) (defmethod restart-port ((port basic-port)) (reset-watcher port :restart) nil) (defmethod destroy-port ((port basic-port)) (reset-watcher port :destroy)) (defmethod destroy-port :around ((port basic-port)) (unwind-protect (call-next-method) (setf *all-ports* (remove port *all-ports*)))) (defmethod add-watcher ((port basic-port) watcher) (declare (ignore watcher)) nil) (defmethod delete-watcher ((port basic-port) watcher) (declare (ignore watcher)) nil) (defmethod reset-watcher ((port basic-port) how) (declare (ignore how)) nil) (defmethod make-graft ((port basic-port) &key (orientation :default) (units :device)) (let ((graft (make-instance 'graft :port port :mirror nil :orientation orientation :units units))) (push graft (port-grafts port)) graft)) #|| (defmethod make-medium ((port basic-port) sheet) (make-instance 'basic-medium :port port :graft (graft sheet) :sheet sheet)) ||# ;;; Pixmap (defmethod port-lookup-mirror ((port basic-port) (pixmap pixmap)) (gethash pixmap (slot-value port 'pixmap->mirror))) (defmethod port-lookup-pixmap ((port basic-port) mirror) (gethash mirror (slot-value port 'mirror->pixmap))) (defmethod port-register-mirror ((port basic-port) (pixmap pixmap) mirror) (setf (gethash pixmap (slot-value port 'pixmap->mirror)) mirror) (setf (gethash mirror (slot-value port 'mirror->pixmap)) pixmap) nil) (defmethod port-unregister-mirror ((port basic-port) (pixmap pixmap) mirror) (remhash pixmap (slot-value port 'pixmap->mirror)) (remhash mirror (slot-value port 'mirror->pixmap)) nil) (defmethod realize-mirror ((port basic-port) (pixmap mirrored-pixmap)) (declare (ignorable port pixmap)) (error "Don't know how to realize the mirror on a generic port")) (defmethod destroy-mirror ((port basic-port) (pixmap mirrored-pixmap)) (declare (ignorable port pixmap)) (error "Don't know how to destroy the mirror on a generic port")) (defmethod port-allocate-pixmap ((port basic-port) sheet width height) (declare (ignore sheet width height)) (error "ALLOCATE-PIXMAP is not implemented for generic PORTs")) (defmethod port-deallocate-pixmap ((port basic-port) pixmap) (declare (ignore pixmap)) (error "DEALLOCATE-PIXMAP is not implemented for generic PORTs")) (defgeneric port-force-output (port) (:documentation "Flush the output buffer of PORT, if there is one.")) (defmethod port-force-output ((port basic-port)) (values)) (defgeneric port-grab-pointer (port pointer sheet) (:documentation "Grab the specified pointer, for implementing TRACKING-POINTER.")) (defgeneric port-ungrab-pointer (port pointer sheet) (:documentation "Ungrab the specified pointer, for implementing TRACKING-POINTER.")) (defmethod port-grab-pointer ((port basic-port) pointer sheet) (declare (ignorable port pointer sheet)) (warn "Port ~A has not implemented pointer grabbing." port)) (defmethod port-ungrab-pointer ((port basic-port) pointer sheet) (declare (ignorable port pointer sheet)) (warn "Port ~A has not implemented pointer grabbing." port)) (defgeneric set-sheet-pointer-cursor (port sheet cursor) (:documentation "Sets the cursor associated with SHEET. CURSOR is a symbol, as described in the Franz user's guide.")) (defmethod set-sheet-pointer-cursor ((port basic-port) sheet cursor) (declare (ignore sheet cursor)) (warn "Port ~A has not implemented sheet pointer cursors." port)) ;;;; ;;;; Font listing extension ;;;; (defgeneric port-all-font-families (port &key invalidate-cache &allow-other-keys) (:documentation "Returns the list of all FONT-FAMILY instances known by PORT. With INVALIDATE-CACHE, cached font family information is discarded, if any.")) (defgeneric font-family-name (font-family) (:documentation "Return the font family's name. This name is meant for user display, and does not, at the time of this writing, necessarily the same string used as the text style family for this port.")) (defgeneric font-family-port (font-family) (:documentation "Return the port this font family belongs to.")) (defgeneric font-family-all-faces (font-family) (:documentation "Return the list of all font-face instances for this family.")) (defgeneric font-face-name (font-face) (:documentation "Return the font face's name. This name is meant for user display, and does not, at the time of this writing, necessarily the same string used as the text style face for this port.")) (defgeneric font-face-family (font-face) (:documentation "Return the font family this face belongs to.")) (defgeneric font-face-all-sizes (font-face) (:documentation "Return the list of all font sizes known to be valid for this font, if the font is restricted to particular sizes. For scalable fonts, arbitrary sizes will work, and this list represents only a subset of the valid sizes. See font-face-scalable-p.")) (defgeneric font-face-scalable-p (font-face) (:documentation "Return true if this font is scalable, as opposed to a bitmap font. For a scalable font, arbitrary font sizes are expected to work.")) (defgeneric font-face-text-style (font-face &optional size) (:documentation "Return an extended text style describing this font face in the specified size. If size is nil, the resulting text style does not specify a size.")) (defclass font-family () ((font-family-port :initarg :port :reader font-family-port) (font-family-name :initarg :name :reader font-family-name)) (:documentation "The protocol class for font families. Each backend defines a subclass of font-family and implements its accessors. Font family instances are never created by user code. Use port-all-font-families to list all instances available on a port.")) (defmethod print-object ((object font-family) stream) (print-unreadable-object (object stream :type t :identity nil) (format stream "~A" (font-family-name object)))) (defclass font-face () ((font-face-family :initarg :family :reader font-face-family) (font-face-name :initarg :name :reader font-face-name)) (:documentation "The protocol class for font faces Each backend defines a subclass of font-face and implements its accessors. Font face instances are never created by user code. Use font-family-all-faces to list all faces of a font family.")) (defmethod print-object ((object font-face) stream) (print-unreadable-object (object stream :type t :identity nil) (format stream "~A, ~A" (font-family-name (font-face-family object)) (font-face-name object)))) ;;; fallback font listing implementation: (defclass basic-font-family (font-family) ()) (defclass basic-font-face (font-face) ()) (defmethod port-all-font-families ((port basic-port) &key invalidate-cache) (declare (ignore invalidate-cache)) (flet ((make-basic-font-family (name) (make-instance 'basic-font-family :port port :name name))) (list (make-basic-font-family "FIX") (make-basic-font-family "SERIF") (make-basic-font-family "SANS-SERIF")))) (defmethod font-family-all-faces ((family basic-font-family)) (flet ((make-basic-font-face (name) (make-instance 'basic-font-face :family family :name name))) (list (make-basic-font-face "ROMAN") (make-basic-font-face "BOLD") (make-basic-font-face "BOLD-ITALIC") (make-basic-font-face "ITALIC")))) (defmethod font-face-all-sizes ((face basic-font-face)) (list 1 2 3 4 5 6 7)) (defmethod font-face-scalable-p ((face basic-font-face)) nil) (defmethod font-face-text-style ((face basic-font-face) &optional size) (make-text-style (find-symbol (string-upcase (font-family-name (font-face-family face))) :keyword) (if (string-equal (font-face-name face) "BOLD-ITALIC") '(:bold :italic) (find-symbol (string-upcase (font-face-name face)) :keyword)) (ecase size ((nil) nil) (1 :tiny) (2 :very-small) (3 :small) (4 :normal) (5 :large) (6 :very-large) (7 :huge)))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Tools/0000755000175000017500000000000011347764124016110 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Tools/unimplemented.lisp0000644000175000017500000000262410133745440021643 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-USER -*- ;;; (c) copyright 2004 by Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-user) ;;; Keep track of how we're doing. (defun print-unimplemented (&optional (packages '(:clim))) (let ((packages (mapcar #'find-package packages))) (loop for package in packages do (loop for sym being the external-symbols of package do (unless (or (boundp sym) (fboundp sym) (find-class sym nil) (find-presentation-type-class sym nil) (gethash sym climi::*presentation-type-abbreviations*) (gethash sym climi::*presentation-gf-table*)) (print sym)))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Tools/Emacs/0000755000175000017500000000000011347764106017140 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Tools/Emacs/hyperclim.el0000644000175000017500000020326710065411630021453 0ustar pdmpdm;; hyperclim.el: Looks up symbols in the CLIM spec from inside xemacs. ;; Written and tested using XEmacs. ;; This code is in the public domain. ;; Orginally written by Andy Hefner (andy.hefner@verizon.net) (require 'cl) (require 'browse-url) (require 'thingatpt) (defvar clim-sybmol-table nil "The symbol table for looking up CLIM symbols") ;;; Override base URL of CLIM specification, set this if you want ;;; to use one of the above from your local disk. (setq clim-url-base-override nil) ;;; Selection of CLIM spec according to preference -- uncomment one of the lines below ;; MikeMac conversion of the CLIM specification ;(setq clim-dataset 'clim-mikemac-spec) ;; Gilbert Baumann conversion of the CLIM specification (setq clim-dataset 'clim-gilberth-spec) ;; Alternate URL for Gilbert's spec.. ; (setq clim-url-base-override "http://bauhh.dyndns.org:8000/clim-spec/" ;;; Internal bits (defvar clim-history nil) (defun clim-get-dataset () (symbol-value clim-dataset)) (defun clim-get-symbol-table () (rest (clim-get-dataset))) (defun clim-get-url-base () (first (clim-get-dataset))) (defun clim-find-symbol (string) (assoc (downcase symbol-name) (clim-get-symbol-table))) (defun clim-find-symbol-url (string) (let ((syminfo (clim-find-symbol string))) (when syminfo (concat (or clim-url-base-override (clim-get-url-base)) (cdr syminfo))))) ;;; CLIM-LOOKUP command ;; Look up a symbol in MikeMac's CLIM documentation. ;; By default it looks up the symbol under the point, but if it isn't over ;; something resembling a symbol, it will prompt you. ;; Also, you can use a prefix arg to force prompting. (defun clim-lookup (p) (interactive "p") (let ((symbol-name (thing-at-point 'symbol))) (unless (and (= 1 p) (stringp symbol-name)) (setq symbol-name (read-from-minibuffer "Symbol name: " "" nil nil 'clim-history))) (let ((url (clim-find-symbol-url (downcase symbol-name)))) (if url (browse-url url) (message "Symbol %s not found." symbol-name))))) ;;; CLIM spec datasets (setq clim-gilberth-spec '("http://www.stud.uni-karlsruhe.de/~unk6/clim-spec/" ("+yellow+" . "13-3.html#_700") ("+white+" . "13-3.html#_702") ("+transparent-ink+" . "13-4.html#_710") ("+textual-view+" . "23-6.html#_1218") ("+textual-menu-view+" . "23-6.html#_1219") ("+textual-dialog-view+" . "23-6.html#_1220") ("+super-key+" . "8-2.html#_381") ("+shift-key+" . "8-2.html#_378") ("+red+" . "13-3.html#_695") ("+pointer-right-button+" . "8-2.html#_377") ("+pointer-middle-button+" . "8-2.html#_376") ("+pointer-left-button+" . "8-2.html#_375") ("+pointer-documentation-view+" . "23-6.html#_1224") ("+nowhere+" . "3-1.html#_49") ("+meta-key+" . "8-2.html#_380") ("+magenta+" . "13-3.html#_699") ("+identity-transformation+" . "5-1.html#_174") ("+hyper-key+" . "8-2.html#_382") ("+green+" . "13-3.html#_696") ("+gadget-view+" . "23-6.html#_1221") ("+gadget-menu-view+" . "23-6.html#_1222") ("+gadget-dialog-view+" . "23-6.html#_1223") ("+foreground-ink+" . "13-6.html#_715") ("+flipping-ink+" . "13-7.html#_719") ("+fill+" . "29-3.html#_1611") ("+everywhere+" . "3-1.html#_48") ("+cyan+" . "13-3.html#_698") ("+control-key+" . "8-2.html#_379") ("+blue+" . "13-3.html#_697") ("+black+" . "13-3.html#_701") ("+background-ink+" . "13-6.html#_716") ("*unsupplied-argument-marker*" . "27-6.html#_1448") ("*undefined-text-style*" . "11-1.html#_571") ("*standard-activation-gestures*" . "24-2.html#_1325") ("*possibilities-gestures*" . "24-5.html#_1345") ("*pointer-documentation-output*" . "28-3.html#_1500") ("*pointer-button-press-handler*" . "22-2.html#_1080") ("*partial-command-parser*" . "27-6.html#_1447") ("*original-stream*" . "C-1.html#_1916") ("*numeric-argument-marker*" . "27-6.html#_1449") ("*null-presentation*" . "23-8.html#_1260") ("*multiprocessing-p*" . "B-2.html#_1879") ("*input-wait-test*" . "22-2.html#_1078") ("*input-wait-handler*" . "22-2.html#_1079") ("*input-context*" . "23-5.html#_1199") ("*help-gestures*" . "24-5.html#_1344") ("*delimiter-gestures*" . "24-2.html#_1328") ("*default-text-style*" . "11-1.html#_570") ("*default-server-path*" . "9-2.html#_457") ("*default-frame-manager*" . "28-5.html#_1550") ("*completion-gestures*" . "24-5.html#_1343") ("*command-unparser*" . "27-6.html#_1446") ("*command-parser*" . "27-6.html#_1445") ("*command-name-delimiters*" . "27-6.html#_1450") ("*command-dispatchers*" . "27-6.html#_1456") ("*command-argument-delimiters*" . "27-6.html#_1451") ("*application-frame*" . "28-2.html#_1482") ("*activation-gestures*" . "24-2.html#_1324") ("*accelerator-gestures*" . "22-2.html#_1090") (":y-spacing" . "29-3.html#_1615") (":y-spacing" . "17-3.html#_933") (":y-spacing" . "17-3.html#_965") (":y-position" . "16-2.html#_841") (":x-spacing" . "29-3.html#_1614") (":x-spacing" . "17-3.html#_932") (":x-spacing" . "17-3.html#_964") (":x-position" . "16-2.html#_840") ("write-token" . "24-4.html#_1340") ("without-scheduling" . "B-2.html#_1895") (":within-generation-separation" . "18-2.html#_988") ("with-translation" . "10-2.html#_533") ("with-text-style" . "11-2.html#_589") ("with-text-size" . "11-2.html#_593") ("with-text-family" . "11-2.html#_591") ("with-text-face" . "11-2.html#_592") ("with-sheet-medium-bound" . "8-3.html#_415") ("with-sheet-medium" . "8-3.html#_414") ("with-scaling" . "10-2.html#_534") ("with-rotation" . "10-2.html#_535") ("with-room-for-graphics" . "15-4.html#_815") ("with-recursive-lock-held" . "B-3.html#_1902") ("with-radio-box" . "30-4.html#_1835") ("with-presentation-type-parameters" . "23-3.html#_1179") ("with-presentation-type-options" . "23-3.html#_1180") ("with-presentation-type-decoded" . "23-3.html#_1177") ("with-port-locked" . "9-2.html#_463") ("with-output-to-postscript-stream" . "E-1.html#_1964") ("with-output-to-pixmap" . "12-6.html#_654") ("with-output-to-output-record" . "16-4.html#_914") ("with-output-recording-options" . "16-4.html#_910") ("with-output-buffered" . "15-6.html#_828") ("with-output-as-presentation" . "23-4.html#_1192") ("with-output-as-gadget" . "30-5.html#_1866") ("with-new-output-record" . "16-4.html#_912") ("with-menu" . "25.html#_1362") ("with-look-and-feel-realization" . "29-2.html#_1590") ("with-lock-held" . "B-3.html#_1900") ("with-local-coordinates" . "10-2.html#_538") ("with-input-focus" . "22-2.html#_1077") ("with-input-editor-typeout" . "24-1.html#_1303") ("with-input-editing" . "24-1.html#_1302") ("with-input-context" . "23-5.html#_1201") ("with-identity-transformation" . "10-2.html#_536") ("with-graft-locked" . "9-3.html#_478") ("with-frame-manager" . "28-5.html#_1551") ("with-first-quadrant-coordinates" . "10-2.html#_539") ("with-end-of-page-action" . "15-4.html#_822") ("with-end-of-line-action" . "15-4.html#_819") ("with-drawing-options" . "10-2.html#_525") ("with-delimiter-gestures" . "24-2.html#_1329") ("with-command-table-keystrokes" . "27-6.html#_1438") ("with-bounding-rectangle*" . "4-1.html#_160") ("with-application-frame" . "28-2.html#_1483") ("with-activation-gestures" . "24-2.html#_1326") ("with-accept-help" . "24-5.html#_1352") ("window-viewport-position" . "29-4.html#_1695") ("window-viewport" . "29-4.html#_1693") ("window-repaint-event" . "8-2.html#_370") ("window-refresh" . "29-4.html#_1692") ("window-manager-event" . "8-2.html#_371") ("window-manager-delete-event" . "8-2.html#_373") ("window-event-region" . "8-2.html#_366") ("window-event-native-region" . "8-2.html#_367") ("window-event-mirrored-sheet" . "8-2.html#_368") ("window-event" . "8-2.html#_364") ("window-erase-viewport" . "29-4.html#_1694") ("window-configuration-event" . "8-2.html#_369") ("window-clear" . "29-4.html#_1691") ("window" . "29-4.html#_1690") ("vrack-pane" . "29-3.html#_1623") ("volatile" . "2-4.html#_16") ("viewport" . "29-3.html#_1639") ("viewp" . "23-6.html#_1210") ("view" . "23-6.html#_1209") (":view" . "23-2.html#_1134") ("vertically" . "29-3.html#_1621") (":vertical-spacing" . "29-4.html#_1672") (":vertical-spacing" . "15-2.html#_776") ("vbox-pane" . "29-3.html#_1620") (":value-key" . "30-4.html#_1841") (":value-key" . "30-4.html#_1849") ("value-gadget" . "30-3.html#_1732") (":value-changed-callback" . "30-3.html#_1734") ("value-changed-callback" . "30-3.html#_1738") ("using-resource" . "B-1.html#_1873") ("user-command-table" . "27-2.html#_1412") ("user" . "2-1.html#_5") ("updating-output-record-p" . "21-3.html#_1025") ("updating-output-record" . "21-3.html#_1024") ("updating-output" . "21-2.html#_1019") ("untransform-region" . "5-3.html#_215") ("untransform-rectangle*" . "5-3.html#_221") ("untransform-position" . "5-3.html#_217") ("untransform-distance" . "5-3.html#_219") ("unread-gesture" . "22-2.html#_1084") (":unique-id" . "21-3.html#_1026") ("uniform" . "13-2.html#_678") ("unhighlight-highlighted-presentation" . "23-7.html#_1249") ("unbounded" . "13-2.html#_677") ("type-or-string" . "23-8.html#_1292") (":type" . "23-2.html#_1133") ("tree-recompute-extent" . "16-2.html#_869") ("translucent" . "13-2.html#_681") ("translation-transformation-p" . "5-3.html#_196") ("translating" . "23-7.html#_1228") ("transformationp" . "5-1.html#_173") ("transformation-underspecified" . "5-1.html#_177") ("transformation-error" . "5-1.html#_176") ("transformation-equal" . "5-3.html#_193") ("transformation" . "5-1.html#_172") (":transformation" . "10-2.html#_528") ("transform-region" . "5-3.html#_214") ("transform-rectangle*" . "5-3.html#_220") ("transform-position" . "5-3.html#_216") ("transform-distance" . "5-3.html#_218") ("tracking-pointer" . "22-5.html#_1121") ("token-or-type" . "23-8.html#_1290") ("toggle-button-pane" . "30-4.html#_1776") ("toggle-button-indicator-type" . "30-4.html#_1774") ("toggle-button" . "30-4.html#_1772") ("title-pane" . "29-4.html#_1683") (":timestamp" . "8-2.html#_327") ("timer-event" . "8-2.html#_374") ("tiling" . "14-3.html#_743") ("throw-highlighted-presentation" . "23-7.html#_1246") ("textual-view" . "23-6.html#_1211") ("textual-menu-view" . "23-6.html#_1212") ("textual-dialog-view" . "23-6.html#_1213") ("text-style-width" . "11-1.html#_585") ("text-style-size" . "11-1.html#_579") ("text-style-p" . "11-1.html#_567") ("text-style-mapping" . "11-3.html#_595") ("text-style-height" . "11-1.html#_584") ("text-style-fixed-width-p" . "11-1.html#_586") ("text-style-family" . "11-1.html#_575") ("text-style-face" . "11-1.html#_577") ("text-style-descent" . "11-1.html#_583") ("text-style-components" . "11-1.html#_573") ("text-style-ascent" . "11-1.html#_582") ("text-style" . "11-1.html#_566") (":text-style" . "10-2.html#_531") (":text-style" . "29-2.html#_1594") (":text-style" . "15-2.html#_775") (":text-size" . "11-1.html#_578") ("text-size" . "11-1.html#_587") (":text-margin" . "29-4.html#_1671") (":text-margin" . "15-2.html#_777") ("text-field-pane" . "30-4.html#_1857") ("text-field" . "30-4.html#_1854") (":text-family" . "11-1.html#_574") (":text-face" . "11-1.html#_576") ("text-editor-pane" . "30-4.html#_1863") ("text-editor" . "30-4.html#_1859") ("text-displayed-output-record-string" . "16-3.html#_882") ("text-displayed-output-record-p" . "16-3.html#_879") ("text-displayed-output-record" . "16-3.html#_878") (":text-cursor" . "22-2.html#_1069") ("test-presentation-translator" . "23-7.html#_1238") (":test" . "30-4.html#_1842") (":test" . "30-4.html#_1850") ("temporary-medium-sheet-output-mixin" . "8-3.html#_412") ("tabling" . "29-3.html#_1625") ("table-pane" . "29-3.html#_1624") ("table-output-record-p" . "17-3.html#_931") ("table-output-record" . "17-3.html#_930") ("symbol" . "23-8.html#_1257") ("surrounding-output-with-border" . "19.html#_1006") ("suggest" . "24-5.html#_1349") ("substitute-numeric-argument-marker" . "27-4.html#_1430") ("subset-sequence" . "23-8.html#_1281") ("subset-completion" . "23-8.html#_1279") ("subset-alist" . "23-8.html#_1282") ("subset" . "23-8.html#_1280") ("structured" . "2-3.html#_10") ("string" . "23-8.html#_1271") ("streams" . "D.html#_1918") ("streamp" . "D-1.html#_1923") ("stream-write-string" . "15-1.html#_761") ("stream-write-string" . "D-4.html#_1952") ("stream-write-char" . "15-1.html#_760") ("stream-write-char" . "D-4.html#_1949") ("stream-write-byte" . "D-5.html#_1961") ("stream-vertical-spacing" . "15-4.html#_812") ("stream-unread-gesture" . "24-1.html#_1320") ("stream-unread-gesture" . "22-2.html#_1085") ("stream-unread-char" . "22-1.html#_1059") ("stream-unread-char" . "D-3.html#_1942") ("stream-truename" . "D-2.html#_1939") ("stream-text-output-record" . "16-4.html#_905") ("stream-text-margin" . "15-4.html#_809") ("stream-text-cursor" . "15-3.html#_801") ("stream-terpri" . "15-1.html#_762") ("stream-terpri" . "D-4.html#_1953") ("stream-string-width" . "15-4.html#_808") ("stream-start-line-p" . "15-1.html#_768") ("stream-start-line-p" . "D-4.html#_1951") ("stream-set-input-focus" . "22-2.html#_1076") ("stream-scan-pointer" . "24-1.html#_1309") ("stream-rescanning-p" . "24-1.html#_1311") ("stream-replay" . "16-4.html#_900") ("stream-redisplaying-p" . "21-4.html#_1051") ("stream-recording-p" . "16-4.html#_892") ("stream-read-line" . "22-1.html#_1062") ("stream-read-line" . "D-3.html#_1946") ("stream-read-gesture" . "24-1.html#_1319") ("stream-read-gesture" . "22-2.html#_1082") ("stream-read-char-no-hang" . "22-1.html#_1058") ("stream-read-char-no-hang" . "D-3.html#_1943") ("stream-read-char" . "22-1.html#_1057") ("stream-read-char" . "D-3.html#_1941") ("stream-read-byte" . "D-5.html#_1960") ("stream-process-gesture" . "24-1.html#_1318") ("stream-present" . "23-4.html#_1194") ("stream-pointer-position" . "22-2.html#_1074") ("stream-peek-char" . "22-1.html#_1060") ("stream-peek-char" . "D-3.html#_1944") ("stream-pathname" . "D-2.html#_1938") ("stream-output-history-mixin" . "16-3.html#_884") ("stream-output-history" . "16-4.html#_896") ("stream-listen" . "22-1.html#_1061") ("stream-listen" . "D-3.html#_1945") ("stream-line-height" . "15-4.html#_811") ("stream-line-column" . "15-1.html#_767") ("stream-line-column" . "D-4.html#_1950") ("stream-insertion-pointer" . "24-1.html#_1307") ("stream-input-wait" . "22-2.html#_1083") ("stream-input-buffer" . "24-1.html#_1306") ("stream-input-buffer" . "22-2.html#_1072") ("stream-increment-cursor-position" . "15-3.html#_805") ("stream-fresh-line" . "15-1.html#_763") ("stream-fresh-line" . "D-4.html#_1954") ("stream-force-output" . "15-1.html#_765") ("stream-force-output" . "D-4.html#_1956") ("stream-finish-output" . "15-1.html#_764") ("stream-finish-output" . "D-4.html#_1955") ("stream-end-of-page-action" . "15-4.html#_820") ("stream-end-of-line-action" . "15-4.html#_817") ("stream-element-type" . "D-2.html#_1935") ("stream-drawing-p" . "16-4.html#_894") ("stream-default-view" . "23-6.html#_1225") ("stream-cursor-position" . "15-3.html#_803") ("stream-current-output-record" . "16-4.html#_897") ("stream-close-text-output-record" . "16-4.html#_906") ("stream-clear-output" . "15-1.html#_766") ("stream-clear-output" . "D-4.html#_1957") ("stream-clear-input" . "22-1.html#_1063") ("stream-clear-input" . "D-3.html#_1947") ("stream-character-width" . "15-4.html#_807") ("stream-baseline" . "15-4.html#_813") ("stream-advance-to-column" . "15-1.html#_769") ("stream-advance-to-column" . "D-4.html#_1958") ("stream-add-string-output" . "16-4.html#_908") ("stream-add-output-record" . "16-4.html#_899") ("stream-add-character-output" . "16-4.html#_907") ("stream-accept" . "23-5.html#_1203") (":stream" . "C-1.html#_1911") ("stencil" . "14-2.html#_737") (":state" . "28-2.html#_1477") ("state" . "15-3.html#_785") ("standard-updating-output-record" . "21-3.html#_1031") ("standard-tree-output-record" . "16-3.html#_873") ("standard-tree-output-history" . "16-3.html#_885") ("standard-text-style" . "11-1.html#_568") ("standard-text-cursor" . "15-3.html#_789") ("standard-table-output-record" . "17-3.html#_936") ("standard-sheet-output-mixin" . "8-3.html#_408") ("standard-sheet-input-mixin" . "8-1.html#_316") ("standard-sequence-output-record" . "16-3.html#_872") ("standard-sequence-output-history" . "16-3.html#_886") ("standard-row-output-record" . "17-3.html#_943") ("standard-repainting-mixin" . "8-4.html#_432") ("standard-region-union" . "3-1.html#_59") ("standard-region-intersection" . "3-1.html#_60") ("standard-region-difference" . "3-1.html#_61") ("standard-rectangle" . "3-2.html#_114") ("standard-presentation" . "23-2.html#_1131") ("standard-polyline" . "3-2.html#_87") ("standard-polygon" . "3-2.html#_92") ("standard-pointer" . "22-4.html#_1111") ("standard-point" . "3-2.html#_75") ("standard-output-stream" . "15-1.html#_759") ("standard-output-recording-stream" . "16-4.html#_890") ("standard-line-style" . "10-3.html#_544") ("standard-line" . "3-2.html#_103") ("standard-item-list-output-record" . "17-3.html#_972") ("standard-input-stream" . "22-1.html#_1056") ("standard-input-editing-stream" . "24-1.html#_1301") ("standard-graph-output-record" . "18-2.html#_982") ("standard-graph-node-output-record" . "18-2.html#_998") ("standard-extended-output-stream" . "15-2.html#_781") ("standard-extended-input-stream" . "22-2.html#_1070") ("standard-encapsulating-stream" . "C-1.html#_1912") ("standard-elliptical-arc" . "3-2.html#_139") ("standard-ellipse" . "3-2.html#_134") ("standard-command-table" . "27-2.html#_1387") ("standard-column-output-record" . "17-3.html#_947") ("standard-cell-output-record" . "17-3.html#_956") ("standard-bounding-rectangle" . "4-1.html#_154") ("standard-application-frame" . "28-2.html#_1479") ("spread" . "2-3.html#_11") ("spacing-pane" . "29-3.html#_1627") (":spacing" . "29-3.html#_1616") ("spacing" . "29-3.html#_1628") ("space-requirement-width" . "29-3.html#_1650") ("space-requirement-min-width" . "29-3.html#_1651") ("space-requirement-min-height" . "29-3.html#_1654") ("space-requirement-max-width" . "29-3.html#_1652") ("space-requirement-max-height" . "29-3.html#_1655") ("space-requirement-height" . "29-3.html#_1653") ("space-requirement-components" . "29-3.html#_1656") ("space-requirement-combine" . "29-3.html#_1657") ("space-requirement" . "29-3.html#_1648") ("space-requirement+" . "29-3.html#_1658") ("space-requirement+*" . "29-3.html#_1659") ("solid" . "13-2.html#_680") ("slider-pane" . "30-4.html#_1819") ("slider-drag-callback" . "30-4.html#_1816") ("slider" . "30-4.html#_1806") (":size" . "16-2.html#_843") ("singular-transformation" . "5-1.html#_179") (":single-box" . "23-2.html#_1135") ("simple-parse-error" . "24-3.html#_1333") ("simple-parse-error" . "24-3.html#_1332") ("simple-completion-error" . "24-5.html#_1347") ("shrunk" . "28-5.html#_1544") ("shrink-frame" . "28-5.html#_1563") (":show-value-p" . "30-4.html#_1808") (":show-as-default" . "30-4.html#_1768") ("sheetp" . "7-1.html#_239") ("sheet-y-inverting-transformation-mixin" . "7-3.html#_292") ("sheet-with-medium-mixin" . "8-3.html#_410") ("sheet-viewable-p" . "7-2.html#_261") ("sheet-translation-mixin" . "7-3.html#_291") ("sheet-transformation-mixin" . "7-3.html#_293") ("sheet-transformation" . "7-3.html#_271") ("sheet-single-child-mixin" . "7-2.html#_267") ("sheet-siblings" . "7-2.html#_253") ("sheet-region" . "7-3.html#_273") ("sheet-parent-mixin" . "7-2.html#_265") ("sheet-parent" . "7-2.html#_249") ("sheet-occluding-sheets" . "7-2.html#_262") ("sheet-native-transformation" . "9-4.html#_498") ("sheet-native-region" . "9-4.html#_499") ("sheet-mute-repainting-mixin" . "8-4.html#_434") ("sheet-mute-output-mixin" . "8-3.html#_409") ("sheet-mute-input-mixin" . "8-1.html#_318") ("sheet-multiple-child-mixin" . "7-2.html#_268") ("sheet-mirrored-ancestor" . "9-4.html#_490") ("sheet-mirror" . "9-4.html#_491") ("sheet-medium" . "8-3.html#_416") ("sheet-leaf-mixin" . "7-2.html#_266") ("sheet-identity-transformation-mixin" . "7-3.html#_290") ("sheet-grafted-p" . "9-3.html#_474") ("sheet-event-queue" . "8-1.html#_302") ("sheet-enabled-p" . "7-2.html#_259") ("sheet-enabled-children" . "7-2.html#_254") ("sheet-disown-child" . "7-2.html#_252") ("sheet-direct-mirror" . "9-4.html#_489") ("sheet-device-transformation" . "9-4.html#_500") ("sheet-device-region" . "9-4.html#_501") ("sheet-delta-transformation" . "7-3.html#_287") ("sheet-children" . "7-2.html#_250") ("sheet-ancestor-p" . "7-2.html#_255") ("sheet-allocated-region" . "7-3.html#_288") ("sheet-adopt-child" . "7-2.html#_251") ("sheet" . "7-1.html#_238") (":sheet" . "8-2.html#_331") (":sheet" . "8-2.html#_372") (":sheet" . "15-3.html#_788") ("sheet" . "6-1.html#_226") ("set-highlighted-presentation" . "23-7.html#_1248") ("sequence-enumerated" . "23-8.html#_1285") ("sequence" . "23-8.html#_1284") ("scrolling" . "29-3.html#_1638") ("scroller-pane" . "29-3.html#_1637") (":scroll-up-page-callback" . "30-4.html#_1788") ("scroll-up-page-callback" . "30-4.html#_1800") (":scroll-up-line-callback" . "30-4.html#_1786") ("scroll-up-line-callback" . "30-4.html#_1799") (":scroll-to-top-callback" . "30-4.html#_1784") ("scroll-to-top-callback" . "30-4.html#_1797") (":scroll-to-bottom-callback" . "30-4.html#_1783") ("scroll-to-bottom-callback" . "30-4.html#_1798") ("scroll-extent" . "29-3.html#_1643") (":scroll-down-page-callback" . "30-4.html#_1787") ("scroll-down-page-callback" . "30-4.html#_1802") (":scroll-down-line-callback" . "30-4.html#_1785") ("scroll-down-line-callback" . "30-4.html#_1801") ("scroll-bar-scroll-up-page-callback" . "30-4.html#_1795") ("scroll-bar-scroll-up-line-callback" . "30-4.html#_1793") ("scroll-bar-scroll-to-top-callback" . "30-4.html#_1791") ("scroll-bar-scroll-to-bottom-callback" . "30-4.html#_1790") ("scroll-bar-scroll-down-page-callback" . "30-4.html#_1794") ("scroll-bar-scroll-down-line-callback" . "30-4.html#_1792") ("scroll-bar-pane" . "30-4.html#_1804") ("scroll-bar-drag-callback" . "30-4.html#_1789") ("scroll-bar" . "30-4.html#_1781") ("run-frame-top-level" . "28-4.html#_1532") ("run-frame-top-level" . "28-4.html#_1533") (":row-wise" . "17-3.html#_967") ("row-output-record-p" . "17-3.html#_942") ("row-output-record" . "17-3.html#_941") ("rigid-transformation-p" . "5-3.html#_198") ("right-handed" . "3.html#_32") ("restraining-pane" . "29-3.html#_1631") ("restraining" . "29-3.html#_1632") ("restart-process" . "B-2.html#_1894") ("restart-port" . "9-2.html#_470") ("resources" . "B-1.html#_1871") ("resize-sheet" . "7-3.html#_276") ("reset-scan-pointer" . "24-1.html#_1312") ("reset-frame" . "28-5.html#_1575") ("rescan-if-necessary" . "24-1.html#_1315") ("replay-output-record" . "16-2.html#_853") ("replay" . "16-2.html#_852") ("replace-input" . "24-4.html#_1337") ("repaint-sheet" . "8-4.html#_430") ("reorder-sheets" . "7-2.html#_258") ("remove-presentation-translator-from-command-table" . "27-5.html#_1433") ("remove-menu-item-from-command-table" . "27-3.html#_1415") ("remove-keystroke-from-command-table" . "27-4.html#_1425") ("remove-command-from-command-table" . "27-2.html#_1401") ("regionp" . "3-1.html#_40") ("region-union" . "3-1.html#_65") ("region-set-regions" . "3-1.html#_62") ("region-set-p" . "3-1.html#_58") ("region-set" . "3-1.html#_57") ("region-intersects-region-p" . "3-1.html#_54") ("region-intersection" . "3-1.html#_66") ("region-equal" . "3-1.html#_51") ("region-difference" . "3-1.html#_67") ("region-contains-region-p" . "3-1.html#_52") ("region-contains-position-p" . "3-1.html#_53") ("region" . "3-1.html#_39") (":region" . "8-2.html#_365") ("region" . "3-1.html#_35") ("reflection-underspecified" . "5-1.html#_178") ("reflection-transformation-p" . "5-3.html#_197") ("redraw-input-buffer" . "24-1.html#_1317") ("redisplayable-stream-p" . "21-4.html#_1050") ("redisplay-output-record" . "21-2.html#_1022") ("redisplay-frame-panes" . "28-3.html#_1519") ("redisplay-frame-pane" . "28-3.html#_1518") ("redisplay" . "21-2.html#_1021") ("rectilinear-transformation-p" . "5-3.html#_201") ("rectanglep" . "3-2.html#_113") ("rectangle-width" . "3-2.html#_125") ("rectangle-size" . "3-2.html#_127") ("rectangle-min-y" . "3-2.html#_122") ("rectangle-min-x" . "3-2.html#_121") ("rectangle-min-point" . "3-2.html#_119") ("rectangle-max-y" . "3-2.html#_124") ("rectangle-max-x" . "3-2.html#_123") ("rectangle-max-point" . "3-2.html#_120") ("rectangle-height" . "3-2.html#_126") ("rectangle-edges*" . "3-2.html#_118") ("rectangle" . "3-2.html#_112") (":record" . "29-4.html#_1677") ("recompute-extent-for-new-child" . "16-2.html#_867") ("recompute-extent-for-changed-child" . "16-2.html#_868") ("recompute-contents-ok" . "21-3.html#_1045") ("realize-mirror" . "9-4.html#_492") ("real" . "23-8.html#_1264") ("read-token" . "24-4.html#_1339") ("read-gesture" . "22-2.html#_1081") ("read-frame-command" . "28-4.html#_1535") ("read-command-using-keystrokes" . "27-6.html#_1439") ("read-command" . "27-6.html#_1437") ("read-bitmap-file" . "E-2.html#_1967") ("rational" . "23-8.html#_1265") ("ratio" . "23-8.html#_1267") (":range-label-text-style" . "30-4.html#_1812") ("range-gadget-mixin" . "30-3.html#_1756") ("raise-sheet" . "7-2.html#_256") ("raise-mirror" . "9-4.html#_494") ("raise-frame" . "28-2.html#_1486") ("radio-box-selections" . "30-4.html#_1825") ("radio-box-pane" . "30-4.html#_1827") ("radio-box-current-selection" . "30-4.html#_1823") ("queue-rescan" . "24-1.html#_1314") ("queue-repaint" . "8-4.html#_428") ("queue-event" . "8-1.html#_308") ("push-button-show-as-default" . "30-4.html#_1769") ("push-button-pane" . "30-4.html#_1770") ("push-button" . "30-4.html#_1767") (":properties" . "28-2.html#_1478") ("propagate-output-record-changes-p" . "21-3.html#_1040") ("propagate-output-record-changes" . "21-3.html#_1041") ("prompt-for-accept-1" . "23-5.html#_1207") ("prompt-for-accept" . "23-5.html#_1206") ("programmer" . "2-1.html#_6") ("processp" . "B-2.html#_1884") ("process-yield" . "B-2.html#_1890") ("process-whostate" . "B-2.html#_1887") ("process-wait-with-timeout" . "B-2.html#_1889") ("process-wait" . "B-2.html#_1888") ("process-state" . "B-2.html#_1886") ("process-next-event" . "8-1.html#_303") ("process-name" . "B-2.html#_1885") ("process-interrupt" . "B-2.html#_1891") ("print-menu-item" . "25.html#_1358") (":pretty-name" . "28-2.html#_1471") ("presentationp" . "23-2.html#_1130") ("presentation-typep" . "23-3.html#_1165") ("presentation-typep" . "23-3.html#_1182") ("presentation-type-specifier-p" . "23-3.html#_1164") ("presentation-type-specifier-p" . "23-3.html#_1181") ("presentation-type-parameters" . "23-3.html#_1175") ("presentation-type-options" . "23-3.html#_1176") ("presentation-type-of" . "23-3.html#_1183") ("presentation-type-name" . "23-3.html#_1178") ("presentation-type-history" . "23-3.html#_1169") ("presentation-type-direct-supertypes" . "23-3.html#_1186") ("presentation-type" . "23-2.html#_1140") ("presentation-subtypep" . "23-3.html#_1166") ("presentation-subtypep" . "23-3.html#_1184") ("presentation-single-box" . "23-2.html#_1142") ("presentation-replace-input" . "24-4.html#_1338") ("presentation-refined-position-test" . "23-3.html#_1171") ("presentation-object" . "23-2.html#_1138") ("presentation-modifier" . "23-2.html#_1144") ("presentation-matches-context-type" . "23-7.html#_1240") ("presentation-default-preprocessor" . "23-3.html#_1170") ("presentation" . "23-2.html#_1129") ("presentation" . "23-2.html#_1128") ("present-to-string" . "23-4.html#_1195") ("present" . "23-3.html#_1161") ("present" . "23-4.html#_1193") ("present" . "27-2.html#_1383") ("ports" . "9-1.html#_448") ("ports" . "6-1.html#_232") ("portp" . "9-2.html#_454") ("port-type" . "9-2.html#_467") ("port-server-path" . "9-2.html#_465") ("port-properties" . "9-2.html#_468") ("port-name" . "9-2.html#_466") ("port-keyboard-input-focus" . "8-1.html#_304") ("port" . "9-2.html#_453") ("port" . "8-3.html#_419") ("port" . "9-4.html#_496") ("port" . "22-4.html#_1119") ("port" . "28-5.html#_1558") ("port" . "28-5.html#_1559") (":port" . "22-4.html#_1110") ("port" . "9-2.html#_462") ("port" . "9-2.html#_451") ("polylinep" . "3-2.html#_86") ("polyline-closed" . "3-2.html#_99") ("polyline" . "3-2.html#_85") ("polyline" . "3-2.html#_82") ("polygonp" . "3-2.html#_91") ("polygon-points" . "3-2.html#_96") ("polygon" . "3-2.html#_90") ("polygon" . "3-2.html#_84") ("pointp" . "3-2.html#_74") ("pointerp" . "22-4.html#_1109") ("pointer-sheet" . "22-4.html#_1112") ("pointer-position" . "22-4.html#_1115") ("pointer-motion-event" . "8-2.html#_359") ("pointer-exit-event" . "8-2.html#_363") ("pointer-event-y" . "8-2.html#_347") ("pointer-event-x" . "8-2.html#_346") ("pointer-event-pointer" . "8-2.html#_350") ("pointer-event-native-y" . "8-2.html#_349") ("pointer-event-native-x" . "8-2.html#_348") ("pointer-event-button" . "8-2.html#_352") ("pointer-event" . "8-2.html#_341") ("pointer-enter-event" . "8-2.html#_362") ("pointer-double-click-event" . "8-2.html#_357") ("pointer-documentation-view" . "23-6.html#_1217") ("pointer-documentation-pane" . "29-4.html#_1684") ("pointer-cursor" . "22-4.html#_1117") ("pointer-click-event" . "8-2.html#_356") ("pointer-click-and-hold-event" . "8-2.html#_358") ("pointer-button-state" . "22-4.html#_1114") ("pointer-button-release-event" . "8-2.html#_354") ("pointer-button-press-event" . "8-2.html#_353") ("pointer-button-hold-event" . "8-2.html#_355") ("pointer-button-event" . "8-2.html#_351") ("pointer-boundary-event-kind" . "8-2.html#_361") ("pointer-boundary-event" . "8-2.html#_360") ("pointer" . "22-4.html#_1108") (":pointer" . "8-2.html#_342") (":pointer" . "22-2.html#_1068") ("point-y" . "3-2.html#_80") ("point-x" . "3-2.html#_79") ("point-position" . "3-2.html#_78") ("point" . "3-2.html#_73") ("point" . "3-2.html#_72") ("pixmap-width" . "12-6.html#_647") ("pixmap-height" . "12-6.html#_648") ("pixmap-depth" . "12-6.html#_649") ("pixmap" . "12-6.html#_644") ("permanent-medium-sheet-output-mixin" . "8-3.html#_411") ("patterning" . "14-2.html#_736") ("pattern-width" . "14-2.html#_739") ("pattern-height" . "14-2.html#_740") ("pathp" . "3-1.html#_43") ("pathname" . "23-8.html#_1273") ("path" . "3-1.html#_41") ("partial-command-p" . "27-1.html#_1379") ("parse-text-style" . "11-1.html#_580") (":parent" . "16-2.html#_842") ("parent" . "6-1.html#_228") (":panes" . "28-2.html#_1474") ("panes" . "28-1.html#_1461") ("panep" . "29-2.html#_1586") ("pane-viewport-region" . "29-3.html#_1641") ("pane-viewport" . "29-3.html#_1640") ("pane-text-style" . "29-2.html#_1601") ("pane-scroller" . "29-3.html#_1642") ("pane-needs-redisplay" . "28-3.html#_1516") ("pane-name" . "29-2.html#_1598") ("pane-frame" . "29-2.html#_1597") ("pane-foreground" . "29-2.html#_1599") ("pane-background" . "29-2.html#_1600") ("pane" . "29-2.html#_1585") ("output-stream-p" . "D-1.html#_1927") ("output-recording-stream-p" . "16-4.html#_889") ("output-recording-stream" . "16-4.html#_888") ("output-record-unique-id" . "21-3.html#_1032") ("output-record-start-cursor-position" . "16-2.html#_847") ("output-record-refined-position-test" . "16-2.html#_855") ("output-record-position" . "16-2.html#_845") ("output-record-parent" . "16-2.html#_851") ("output-record-p" . "16-2.html#_837") ("output-record-hit-detection-rectangle*" . "16-2.html#_854") ("output-record-fixed-position" . "21-3.html#_1034") ("output-record-end-cursor-position" . "16-2.html#_849") ("output-record-displayer" . "21-3.html#_1035") ("output-record-count" . "16-2.html#_863") ("output-record-contents-ok" . "21-3.html#_1044") ("output-record-children" . "16-2.html#_859") ("output-record-cache-value" . "21-3.html#_1033") ("output-record" . "16-2.html#_836") (":output-record" . "29-4.html#_1675") ("outlining" . "29-3.html#_1630") ("outlined-pane" . "29-3.html#_1629") ("oriented-gadget-mixin" . "30-3.html#_1743") (":orientation" . "18-2.html#_983") (":orientation" . "30-3.html#_1744") ("or" . "23-8.html#_1287") ("option-pane" . "30-4.html#_1845") (":openlook" . "9-2.html#_460") ("open-window-stream" . "29-4.html#_1698") ("open-stream-p" . "D-2.html#_1936") ("opacityp" . "13-4.html#_708") ("opacity-value" . "13-4.html#_711") ("opacity" . "13-4.html#_707") (":number-of-tick-marks" . "30-4.html#_1813") (":number-of-quanta" . "30-4.html#_1814") ("number" . "23-8.html#_1262") ("null-or-type" . "23-8.html#_1291") ("null" . "23-8.html#_1255") ("notify-user" . "28-3.html#_1521") ("note-space-requirements-changed" . "29-3.html#_1663") ("note-sheet-transformation-changed" . "8-5.html#_445") ("note-sheet-region-changed" . "8-5.html#_444") ("note-sheet-grafted" . "8-5.html#_437") ("note-sheet-enabled" . "8-5.html#_441") ("note-sheet-disowned" . "8-5.html#_440") ("note-sheet-disabled" . "8-5.html#_442") ("note-sheet-degrafted" . "8-5.html#_438") ("note-sheet-adopted" . "8-5.html#_439") ("note-output-record-child-changed" . "21-3.html#_1039") ("note-gadget-deactivated" . "30-3.html#_1731") ("note-gadget-activated" . "30-3.html#_1730") ("note-frame-iconified" . "28-5.html#_1566") ("note-frame-enabled" . "28-5.html#_1564") ("note-frame-disabled" . "28-5.html#_1565") ("note-frame-deiconified" . "28-5.html#_1567") ("note-command-enabled" . "28-5.html#_1568") ("note-command-disabled" . "28-5.html#_1569") ("non-uniform" . "13-2.html#_679") (":nlines" . "30-4.html#_1861") ("nil" . "23-8.html#_1254") ("new-page" . "E-1.html#_1965") (":ncolumns" . "30-4.html#_1860") (":name-key" . "30-4.html#_1840") (":name-key" . "30-4.html#_1848") (":name" . "29-2.html#_1595") (":name" . "28-2.html#_1470") (":n-rows" . "17-3.html#_968") ("mutable" . "2-4.html#_14") (":multiple-columns-x-spacing" . "17-3.html#_934") ("move-sheet" . "7-3.html#_275") ("move-and-resize-sheet" . "7-3.html#_277") (":motif" . "9-2.html#_459") ("modifier-state-matches-gesture-name-p" . "22-3.html#_1104") (":modifier-state" . "8-2.html#_332") (":modifier" . "23-2.html#_1136") (":mode" . "30-4.html#_1838") (":mode" . "30-4.html#_1846") ("mirrored-sheet-mixin" . "9-4.html#_487") (":min-width" . "29-3.html#_1607") (":min-width" . "17-3.html#_954") (":min-value" . "30-3.html#_1757") (":min-label" . "30-4.html#_1810") (":min-height" . "29-3.html#_1610") (":min-height" . "17-3.html#_955") ("merge-text-styles" . "11-1.html#_581") (":merge-duplicates" . "18-2.html#_986") ("menu-read-remaining-arguments-for-partial-command" . "27-6.html#_1444") ("menu-item-value" . "25.html#_1359") ("menu-item-options" . "25.html#_1361") ("menu-item-display" . "25.html#_1360") ("menu-command-parser" . "27-6.html#_1443") ("menu-choose-from-drawer" . "25.html#_1356") ("menu-choose-command-from-command-table" . "27-3.html#_1422") ("menu-choose" . "25.html#_1354") ("menu-button-pane" . "30-4.html#_1779") ("menu-button" . "30-4.html#_1778") (":menu-bar" . "28-2.html#_1475") ("member-sequence" . "23-8.html#_1277") ("member-alist" . "23-8.html#_1278") ("member" . "23-8.html#_1276") ("mediump" . "8-3.html#_387") ("medium-transformation" . "8-3.html#_395") ("medium-transformation" . "10-1.html#_513") ("medium-text-style" . "8-3.html#_401") ("medium-text-style" . "10-1.html#_521") ("medium-sheet" . "8-3.html#_417") ("medium-merged-text-style" . "8-3.html#_405") ("medium-line-style" . "8-3.html#_399") ("medium-line-style" . "10-1.html#_517") ("medium-ink" . "8-3.html#_393") ("medium-ink" . "10-1.html#_511") ("medium-foreground" . "8-3.html#_389") ("medium-foreground" . "10-1.html#_507") ("medium-force-output" . "12-7.html#_669") ("medium-finish-output" . "12-7.html#_668") ("medium-drawable" . "8-3.html#_418") ("medium-draw-text*" . "12-7.html#_666") ("medium-draw-rectangles*" . "12-7.html#_664") ("medium-draw-rectangle*" . "12-7.html#_663") ("medium-draw-polygon*" . "12-7.html#_662") ("medium-draw-points*" . "12-7.html#_659") ("medium-draw-point*" . "12-7.html#_658") ("medium-draw-lines*" . "12-7.html#_661") ("medium-draw-line*" . "12-7.html#_660") ("medium-draw-ellipse*" . "12-7.html#_665") ("medium-default-text-style" . "8-3.html#_403") ("medium-default-text-style" . "10-1.html#_519") ("medium-current-text-style" . "10-1.html#_523") ("medium-copy-area" . "12-6.html#_653") ("medium-clipping-region" . "8-3.html#_397") ("medium-clipping-region" . "10-1.html#_515") ("medium-clear-area" . "12-7.html#_670") ("medium-buffering-output-p" . "15-6.html#_826") ("medium-beep" . "12-7.html#_671") ("medium-background" . "8-3.html#_391") ("medium-background" . "10-1.html#_508") ("medium" . "8-3.html#_386") ("medium" . "8-3.html#_385") (":max-width" . "29-3.html#_1606") (":max-width" . "17-3.html#_970") (":max-value" . "30-3.html#_1758") (":max-label" . "30-4.html#_1811") (":max-height" . "29-3.html#_1609") (":max-height" . "17-3.html#_971") ("matching" . "23-7.html#_1232") ("match-output-records" . "21-3.html#_1042") ("map-sheet-rectangle*-to-parent" . "7-3.html#_280") ("map-sheet-rectangle*-to-child" . "7-3.html#_281") ("map-sheet-position-to-parent" . "7-3.html#_278") ("map-sheet-position-to-child" . "7-3.html#_279") ("map-resource" . "B-1.html#_1877") ("map-over-table-elements" . "17-3.html#_937") ("map-over-sheets-overlapping-region" . "7-3.html#_283") ("map-over-sheets-containing-position" . "7-3.html#_282") ("map-over-sheets" . "7-2.html#_263") ("map-over-row-cells" . "17-3.html#_944") ("map-over-row-cells" . "17-3.html#_948") ("map-over-region-set-regions" . "3-1.html#_63") ("map-over-presentation-type-supertypes" . "23-3.html#_1167") ("map-over-presentation-type-supertypes" . "23-3.html#_1185") ("map-over-ports" . "9-2.html#_464") ("map-over-polygon-segments" . "3-2.html#_98") ("map-over-polygon-coordinates" . "3-2.html#_97") ("map-over-output-records-overlapping-region" . "16-2.html#_865") ("map-over-output-records-containing-position" . "16-2.html#_864") ("map-over-item-list-cells" . "17-3.html#_973") ("map-over-grafts" . "9-3.html#_477") ("map-over-frames" . "28-2.html#_1484") ("map-over-command-table-translators" . "27-5.html#_1434") ("map-over-command-table-names" . "27-2.html#_1405") ("map-over-command-table-menu-items" . "27-3.html#_1416") ("map-over-command-table-keystrokes" . "27-4.html#_1426") ("map-over-command-table-commands" . "27-2.html#_1404") ("make-translation-transformation" . "5-2.html#_181") ("make-transformation" . "5-2.html#_188") ("make-text-style" . "11-1.html#_569") ("make-stencil" . "14-2.html#_741") ("make-space-requirement" . "29-3.html#_1649") ("make-scaling-transformation" . "5-2.html#_184") ("make-scaling-transformation*" . "5-2.html#_185") ("make-rotation-transformation" . "5-2.html#_182") ("make-rotation-transformation*" . "5-2.html#_183") ("make-rgb-color" . "13-3.html#_688") ("make-reflection-transformation" . "5-2.html#_186") ("make-reflection-transformation*" . "5-2.html#_187") ("make-recursive-lock" . "B-3.html#_1901") ("make-rectangular-tile" . "14-3.html#_744") ("make-rectangle" . "3-2.html#_115") ("make-rectangle*" . "3-2.html#_116") ("make-process" . "B-2.html#_1880") ("make-presentation-type-specifier" . "23-3.html#_1190") ("make-polyline" . "3-2.html#_88") ("make-polyline*" . "3-2.html#_89") ("make-polygon" . "3-2.html#_93") ("make-polygon*" . "3-2.html#_94") ("make-point" . "3-2.html#_76") ("make-pattern-from-bitmap-file" . "E-2.html#_1968") ("make-pattern" . "14-2.html#_738") ("make-pane-1" . "29-2.html#_1589") ("make-pane" . "29-2.html#_1588") ("make-opacity" . "13-4.html#_709") ("make-modifier-state" . "22-3.html#_1105") ("make-medium" . "8-3.html#_423") ("make-lock" . "B-3.html#_1899") ("make-line-style" . "10-3.html#_545") ("make-line" . "3-2.html#_104") ("make-line*" . "3-2.html#_105") ("make-ihs-color" . "13-3.html#_689") ("make-gray-color" . "13-3.html#_690") ("make-flipping-ink" . "13-7.html#_718") ("make-elliptical-arc" . "3-2.html#_140") ("make-elliptical-arc*" . "3-2.html#_141") ("make-ellipse" . "3-2.html#_135") ("make-ellipse*" . "3-2.html#_136") ("make-device-font-text-style" . "11-3.html#_597") ("make-design-from-output-record" . "16-4.html#_916") ("make-contrasting-inks" . "13-3.html#_704") ("make-contrasting-dash-patterns" . "10-3.html#_560") ("make-command-table" . "27-2.html#_1392") ("make-clim-stream-pane" . "29-4.html#_1686") ("make-clim-interactor-pane" . "29-4.html#_1687") ("make-clim-application-pane" . "29-4.html#_1688") ("make-bounding-rectangle" . "4-1.html#_155") ("make-application-frame" . "28-2.html#_1481") ("make-3-point-transformation" . "5-2.html#_189") ("lookup-keystroke-item" . "27-4.html#_1428") ("lookup-keystroke-command-item" . "27-4.html#_1429") ("list-pane" . "30-4.html#_1837") ("linep" . "3-2.html#_102") (":line-unit" . "10-3.html#_547") (":line-thickness" . "10-3.html#_549") ("line-style-unit" . "10-3.html#_548") ("line-style-thickness" . "10-3.html#_550") ("line-style-p" . "10-3.html#_543") ("line-style-joint-shape" . "10-3.html#_552") ("line-style-dashes" . "10-3.html#_558") ("line-style-cap-shape" . "10-3.html#_555") ("line-style" . "10-3.html#_542") (":line-style" . "10-2.html#_530") ("line-start-point" . "3-2.html#_109") ("line-start-point*" . "3-2.html#_107") (":line-joint-shape" . "10-3.html#_551") ("line-end-point" . "3-2.html#_110") ("line-end-point*" . "3-2.html#_108") (":line-dashes" . "10-3.html#_557") (":line-cap-shape" . "10-3.html#_554") ("line" . "3-2.html#_101") ("left-handed" . "3.html#_33") ("layout-graph-nodes" . "18-2.html#_994") ("layout-graph-edges" . "18-2.html#_995") ("layout-frame" . "28-3.html#_1512") ("labelling" . "29-3.html#_1635") ("labelled-gadget-mixin" . "30-3.html#_1746") ("label-pane" . "29-3.html#_1634") ("keyword" . "23-8.html#_1258") ("keyboard-event-key-name" . "8-2.html#_337") ("keyboard-event-character" . "8-2.html#_338") ("keyboard-event" . "8-2.html#_335") ("key-release-event" . "8-2.html#_340") ("key-press-event" . "8-2.html#_339") (":items" . "30-4.html#_1839") (":items" . "30-4.html#_1847") ("item-list-output-record-p" . "17-3.html#_963") ("item-list-output-record" . "17-3.html#_962") ("invoke-with-text-style" . "11-2.html#_590") ("invoke-with-output-to-output-record" . "16-4.html#_915") ("invoke-with-output-recording-options" . "16-4.html#_911") ("invoke-with-new-output-record" . "16-4.html#_913") ("invoke-with-drawing-options" . "10-2.html#_526") ("invoke-updating-output" . "21-2.html#_1020") ("invoke-accept-values-command-button" . "26.html#_1370") ("invertible-transformation-p" . "5-3.html#_195") ("invert-transformation" . "5-3.html#_206") ("invalidate-cached-transformations" . "9-4.html#_502") ("invalidate-cached-regions" . "9-4.html#_503") ("interning" . "2-4.html#_15") ("interactor-pane" . "29-4.html#_1680") ("interactive-stream-p" . "24-1.html#_1298") ("integer" . "23-8.html#_1266") ("inside" . "12-4.html#_607") ("input-stream-p" . "D-1.html#_1925") ("input-not-of-required-type" . "24-3.html#_1335") ("input-not-of-required-type" . "24-3.html#_1334") ("input-editor-format" . "24-1.html#_1304") ("input-editing-stream-p" . "24-1.html#_1300") ("input-editing-stream" . "24-1.html#_1299") ("input-context-type" . "23-5.html#_1200") (":input-buffer" . "22-2.html#_1067") (":ink" . "10-2.html#_527") (":initial-spacing" . "17-3.html#_966") (":indicator-type" . "30-4.html#_1773") ("indenting-output" . "20-2.html#_1012") (":incremental-redisplay" . "29-4.html#_1670") ("incremental-redisplay" . "21-4.html#_1052") ("implementor" . "2-1.html#_7") ("immutable" . "2-4.html#_13") ("immediate-sheet-input-mixin" . "8-1.html#_317") ("immediate-rescan" . "24-1.html#_1313") ("immediate-repainting-mixin" . "8-4.html#_433") ("identity-transformation-p" . "5-3.html#_194") (":id-test" . "21-3.html#_1027") ("hrack-pane" . "29-3.html#_1622") ("horizontally" . "29-3.html#_1619") ("highlight-presentation" . "23-3.html#_1172") ("highlight-output-record" . "16-2.html#_856") ("highlight-applicable-presentation" . "23-7.html#_1247") (":height" . "29-3.html#_1608") ("hbox-pane" . "29-3.html#_1618") (":hash-table" . "18-2.html#_989") ("handle-repaint" . "8-4.html#_429") ("grid-pane" . "29-3.html#_1626") ("graphics-displayed-output-record-p" . "16-3.html#_876") ("graphics-displayed-output-record" . "16-3.html#_875") ("graph-root-nodes" . "18-2.html#_991") ("graph-output-record-p" . "18-2.html#_981") ("graph-output-record" . "18-2.html#_980") ("graph-node-parents" . "18-2.html#_999") ("graph-node-output-record-p" . "18-2.html#_997") ("graph-node-output-record" . "18-2.html#_996") ("graph-node-object" . "18-2.html#_1003") ("graph-node-children" . "18-2.html#_1001") ("grafts" . "6-1.html#_233") ("grafts" . "9-1.html#_449") ("grafted" . "7-2.html#_244") ("graft-width" . "9-3.html#_481") ("graft-units" . "9-3.html#_480") ("graft-pixels-per-millimeter" . "9-3.html#_483") ("graft-pixels-per-inch" . "9-3.html#_484") ("graft-orientation" . "9-3.html#_479") ("graft-height" . "9-3.html#_482") ("graft" . "9-3.html#_476") ("graft" . "9-3.html#_473") ("global-command-table" . "27-2.html#_1411") ("get-frame-pane" . "28-3.html#_1507") ("gesture" . "22-3.html#_1095") ("generic-option-pane" . "30-4.html#_1852") ("generic-list-pane" . "30-4.html#_1844") (":generation-separation" . "18-2.html#_987") ("generate-panes" . "28-5.html#_1571") ("generate-graph-nodes" . "18-2.html#_993") (":genera" . "9-2.html#_461") ("gadgets" . "30-1.html#_1704") ("gadgetp" . "30-3.html#_1713") ("gadget-view" . "23-6.html#_1214") ("gadget-value-changed-callback" . "30-3.html#_1737") ("gadget-value" . "30-4.html#_1775") ("gadget-value" . "30-4.html#_1803") ("gadget-value" . "30-4.html#_1818") ("gadget-value" . "30-4.html#_1826") ("gadget-value" . "30-4.html#_1833") ("gadget-value" . "30-4.html#_1843") ("gadget-value" . "30-4.html#_1851") ("gadget-value" . "30-4.html#_1856") ("gadget-value" . "30-4.html#_1862") ("gadget-value" . "30-3.html#_1735") ("gadget-show-value-p" . "30-4.html#_1815") ("gadget-range" . "30-3.html#_1763") ("gadget-range*" . "30-3.html#_1764") ("gadget-output-record" . "30-5.html#_1865") ("gadget-orientation" . "30-3.html#_1745") ("gadget-min-value" . "30-3.html#_1759") ("gadget-menu-view" . "23-6.html#_1215") ("gadget-max-value" . "30-3.html#_1761") ("gadget-label-align-y" . "30-3.html#_1754") ("gadget-label-align-x" . "30-3.html#_1752") ("gadget-label" . "30-3.html#_1750") ("gadget-id" . "30-3.html#_1719") ("gadget-disarmed-callback" . "30-3.html#_1724") ("gadget-dialog-view" . "23-6.html#_1216") ("gadget-client" . "30-3.html#_1721") ("gadget-armed-callback" . "30-3.html#_1723") ("gadget-active-p" . "30-3.html#_1729") ("gadget-activate-callback" . "30-3.html#_1741") ("gadget" . "30-3.html#_1712") ("fundamental-stream" . "D-1.html#_1922") ("fundamental-output-stream" . "D-1.html#_1926") ("fundamental-input-stream" . "D-1.html#_1924") ("fundamental-character-stream" . "D-1.html#_1928") ("fundamental-character-output-stream" . "D-1.html#_1931") ("fundamental-character-input-stream" . "D-1.html#_1930") ("fundamental-binary-stream" . "D-1.html#_1929") ("fundamental-binary-output-stream" . "D-1.html#_1933") ("fundamental-binary-input-stream" . "D-1.html#_1932") ("funcall-presentation-generic-function" . "23-3.html#_1159") ("frames" . "28-1.html#_1460") ("frame-top-level-sheet" . "28-3.html#_1505") ("frame-state" . "28-5.html#_1560") ("frame-standard-output" . "28-3.html#_1496") ("frame-standard-input" . "28-3.html#_1497") ("frame-replay" . "28-3.html#_1520") ("frame-query-io" . "28-3.html#_1498") ("frame-properties" . "28-3.html#_1522") ("frame-pretty-name" . "28-3.html#_1492") ("frame-pointer-documentation-output" . "28-3.html#_1501") ("frame-parent" . "28-3.html#_1503") ("frame-panes" . "28-3.html#_1504") ("frame-name" . "28-3.html#_1491") ("frame-mananger-p" . "28-5.html#_1547") ("frame-manager-notify-user" . "28-5.html#_1570") ("frame-manager-menu-choose" . "25.html#_1355") ("frame-manager-frames" . "28-5.html#_1555") ("frame-manager" . "28-5.html#_1546") ("frame-manager" . "28-5.html#_1553") ("frame-maintain-presentation-histories" . "28-3.html#_1525") ("frame-input-context-button-press-handler" . "28-3.html#_1527") ("frame-find-innermost-applicable-presentation" . "28-3.html#_1526") ("frame-exit-frame" . "28-3.html#_1514") ("frame-exit" . "28-3.html#_1515") ("frame-exit" . "28-3.html#_1513") ("frame-error-output" . "28-3.html#_1499") ("frame-drag-and-drop-highlighting" . "28-3.html#_1530") ("frame-drag-and-drop-feedback" . "28-3.html#_1529") ("frame-document-highlighted-presentation" . "28-3.html#_1528") ("frame-current-panes" . "28-3.html#_1506") ("frame-current-layout" . "28-3.html#_1509") ("frame-command-table" . "28-3.html#_1494") ("frame-calling-frame" . "28-3.html#_1502") ("frame-all-layouts" . "28-3.html#_1511") ("formatting-table" . "17-2.html#_922") ("formatting-row" . "17-2.html#_923") ("formatting-item-list" . "17-2.html#_926") ("formatting-column" . "17-2.html#_924") ("formatting-cell" . "17-2.html#_925") ("format-textual-list" . "20-1.html#_1010") ("format-items" . "17-2.html#_927") ("format-graph-from-roots" . "18-1.html#_978") ("form" . "23-8.html#_1295") (":foreground" . "29-2.html#_1592") (":foreground" . "15-2.html#_773") ("float" . "23-8.html#_1268") (":fixed-position" . "21-3.html#_1030") ("find-presentation-type-class" . "23-3.html#_1187") ("find-presentation-translators" . "23-7.html#_1237") ("find-presentation-translator" . "27-5.html#_1435") ("find-port" . "9-2.html#_456") ("find-pane-named" . "28-3.html#_1508") ("find-pane-for-frame" . "28-5.html#_1572") ("find-menu-item" . "27-3.html#_1417") ("find-keystroke-item" . "27-4.html#_1427") ("find-innermost-applicable-presentation" . "23-7.html#_1245") ("find-graft" . "9-3.html#_475") ("find-frame-manager" . "28-5.html#_1549") ("find-command-table" . "27-2.html#_1393") ("find-command-from-command-line-name" . "27-2.html#_1408") ("find-child-output-record" . "21-3.html#_1043") ("find-cached-output-record" . "21-3.html#_1048") ("find-applicable-translators" . "23-7.html#_1239") ("extended-output-stream-p" . "15-2.html#_772") ("extended-output-stream" . "15-2.html#_771") ("extended-input-stream-p" . "22-2.html#_1066") ("extended-input-stream" . "22-2.html#_1065") ("expression" . "23-8.html#_1294") ("expand-presentation-type-abbreviation-1" . "23-3.html#_1153") ("expand-presentation-type-abbreviation" . "23-3.html#_1154") ("execute-frame-command" . "28-4.html#_1536") ("eventp" . "8-2.html#_326") ("event-unread" . "8-1.html#_313") ("event-type" . "8-2.html#_329") ("event-timestamp" . "8-2.html#_328") ("event-sheet" . "8-2.html#_333") ("event-read-no-hang" . "8-1.html#_311") ("event-read" . "8-1.html#_310") ("event-peek" . "8-1.html#_312") ("event-modifier-state" . "8-2.html#_334") ("event-matches-gesture-name-p" . "22-3.html#_1103") ("event-listen" . "8-1.html#_314") ("event" . "8-2.html#_325") ("event" . "8-2.html#_323") ("even-scaling-transformation-p" . "5-3.html#_199") ("erase-output-record" . "16-4.html#_901") ("erase-input-buffer" . "24-1.html#_1316") (":equalize-column-widths" . "17-3.html#_935") ("engraft-medium" . "8-3.html#_424") (":end-of-page-action" . "29-4.html#_1674") (":end-of-page-action" . "15-2.html#_779") (":end-of-line-action" . "29-4.html#_1673") (":end-of-line-action" . "15-2.html#_778") ("encapsulating-stream-stream" . "C-1.html#_1914") ("encapsulating-stream-p" . "C-1.html#_1910") ("encapsulating-stream" . "C-1.html#_1909") ("enabled" . "7-2.html#_246") ("enabled" . "28-5.html#_1542") ("enable-process" . "B-2.html#_1893") ("enable-frame" . "28-5.html#_1561") ("elliptical-arc-p" . "3-2.html#_138") ("elliptical-arc" . "3-2.html#_137") ("ellipsep" . "3-2.html#_133") ("ellipse-start-angle" . "3-2.html#_146") ("ellipse-radii" . "3-2.html#_145") ("ellipse-end-angle" . "3-2.html#_147") ("ellipse-center-point" . "3-2.html#_144") ("ellipse-center-point*" . "3-2.html#_143") ("ellipse" . "3-2.html#_132") ("ellipse" . "3-2.html#_129") ("draw-text" . "12-5.html#_636") ("draw-text*" . "12-5.html#_637") ("draw-standard-menu" . "25.html#_1357") ("draw-rectangles" . "12-5.html#_630") ("draw-rectangles*" . "12-5.html#_631") ("draw-rectangle" . "12-5.html#_628") ("draw-rectangle*" . "12-5.html#_629") ("draw-polygon" . "12-5.html#_626") ("draw-polygon*" . "12-5.html#_627") ("draw-points" . "12-5.html#_620") ("draw-points*" . "12-5.html#_621") ("draw-point" . "12-5.html#_618") ("draw-point*" . "12-5.html#_619") ("draw-pattern*" . "14-5.html#_749") ("draw-oval" . "12-5.html#_641") ("draw-oval*" . "12-5.html#_642") ("draw-lines" . "12-5.html#_624") ("draw-lines*" . "12-5.html#_625") ("draw-line" . "12-5.html#_622") ("draw-line*" . "12-5.html#_623") ("draw-ellipse" . "12-5.html#_632") ("draw-ellipse*" . "12-5.html#_633") ("draw-design" . "14-5.html#_748") ("draw-circle" . "12-5.html#_634") ("draw-circle*" . "12-5.html#_635") ("draw-arrow" . "12-5.html#_639") ("draw-arrow*" . "12-5.html#_640") (":draw" . "29-4.html#_1676") ("dragging-output" . "22-5.html#_1123") ("drag-output-record" . "22-5.html#_1122") (":drag-callback" . "30-4.html#_1782") (":drag-callback" . "30-4.html#_1807") ("drag-callback" . "30-4.html#_1796") ("drag-callback" . "30-4.html#_1817") ("document-presentation-translator" . "23-7.html#_1242") ("do-command-table-inheritance" . "27-2.html#_1403") ("distributing" . "8-1.html#_297") ("distribute-event" . "8-1.html#_306") ("displayed-output-record-p" . "16-2.html#_839") ("displayed-output-record-ink" . "16-2.html#_857") ("displayed-output-record" . "16-2.html#_838") (":display-time" . "29-4.html#_1669") (":display-function" . "29-4.html#_1668") ("display-exit-boxes" . "26.html#_1367") ("display-command-table-menu" . "27-3.html#_1421") ("display-command-menu" . "28-4.html#_1539") ("dispatches" . "8-1.html#_298") ("dispatch-event" . "8-1.html#_307") ("disowned" . "7-2.html#_243") ("disowned" . "28-5.html#_1545") ("disown-frame" . "28-5.html#_1557") (":disarmed-callback" . "30-3.html#_1718") ("disarmed-callback" . "30-3.html#_1726") (":disabled-commands" . "28-2.html#_1473") ("disabled" . "7-2.html#_247") ("disabled" . "28-5.html#_1543") ("disable-process" . "B-2.html#_1892") ("disable-frame" . "28-5.html#_1562") ("dimensionality" . "3-1.html#_42") ("device-event" . "8-2.html#_330") ("destroy-process" . "B-2.html#_1881") ("destroy-port" . "9-2.html#_471") ("destroy-mirror" . "9-4.html#_493") ("destroy-frame" . "28-2.html#_1485") ("designp" . "13-2.html#_684") ("design" . "13-2.html#_675") ("design" . "3-1.html#_38") ("describe-presentation-type" . "23-3.html#_1163") ("describe-presentation-type" . "23-3.html#_1174") ("delimiter-gesture-p" . "24-2.html#_1330") ("delete-output-record" . "16-2.html#_861") ("delete-gesture-name" . "22-3.html#_1102") ("delegate-sheet-input-mixin" . "8-1.html#_319") ("delegate-sheet-delegate" . "8-1.html#_320") ("degrafted" . "7-2.html#_245") ("degraft-medium" . "8-3.html#_425") ("defresource" . "B-1.html#_1872") ("defmethod*" . "B-4.html#_1905") ("define-presentation-type-abbreviation" . "23-3.html#_1151") ("define-presentation-type" . "23-3.html#_1149") ("define-presentation-translator" . "23-7.html#_1230") ("define-presentation-to-command-translator" . "23-7.html#_1233") ("define-presentation-method" . "23-3.html#_1157") ("define-presentation-generic-function" . "23-3.html#_1156") ("define-presentation-action" . "23-7.html#_1234") ("define-graph-type" . "18-2.html#_990") ("define-gesture-name" . "22-3.html#_1100") ("define-drag-and-drop-translator" . "23-7.html#_1235") ("define-default-presentation-method" . "23-3.html#_1158") ("define-command-table" . "27-2.html#_1390") ("define-command" . "27-1.html#_1380") ("define-border-type" . "19.html#_1007") ("define-application-frame" . "28-2.html#_1480") ("defgeneric*" . "B-4.html#_1904") (":default-view" . "15-2.html#_780") ("default-frame-top-level" . "28-4.html#_1534") ("default-describe-presentation-type" . "23-3.html#_1189") (":decimal-places" . "30-4.html#_1809") ("decache-child-output-record" . "21-3.html#_1047") ("deallocate-resource" . "B-1.html#_1875") ("deallocate-pixmap" . "12-6.html#_646") ("deallocate-medium" . "8-3.html#_422") (":cutoff-depth" . "18-2.html#_985") ("cursorp" . "15-3.html#_787") ("cursor-visibility" . "15-3.html#_798") ("cursor-state" . "15-3.html#_795") ("cursor-sheet" . "15-3.html#_790") ("cursor-position" . "15-3.html#_791") ("cursor-focus" . "15-3.html#_797") ("cursor-active" . "15-3.html#_793") ("cursor" . "15-3.html#_786") (":current-selection" . "30-4.html#_1822") (":current-selection" . "30-4.html#_1829") ("current-process" . "B-2.html#_1882") ("copy-to-pixmap" . "12-6.html#_650") ("copy-textual-output-history" . "16-4.html#_902") ("copy-from-pixmap" . "12-6.html#_651") ("copy-area" . "12-6.html#_652") ("coordinate" . "3-1.html#_46") ("coordinate" . "3-1.html#_47") ("contrasting-inks-limit" . "13-3.html#_705") ("contrasting-dash-pattern-limit" . "10-3.html#_561") (":contents" . "29-3.html#_1604") ("compute-new-output-records" . "21-3.html#_1036") ("compute-difference-set" . "21-3.html#_1037") ("compositing" . "14-1.html#_727") ("composing" . "5-3.html#_204") ("compose-translation-with-transformation" . "5-3.html#_207") ("compose-transformations" . "5-3.html#_205") ("compose-transformation-with-translation" . "5-3.html#_210") ("compose-transformation-with-scaling" . "5-3.html#_211") ("compose-transformation-with-rotation" . "5-3.html#_212") ("compose-space" . "29-3.html#_1660") ("compose-scaling-with-transformation" . "5-3.html#_208") ("compose-rotation-with-transformation" . "5-3.html#_209") ("compose-over" . "14-1.html#_731") ("compose-out" . "14-1.html#_734") ("compose-in" . "14-1.html#_732") ("complex" . "23-8.html#_1263") ("completion" . "23-8.html#_1275") ("completion" . "24-5.html#_1342") ("completing-from-suggestions" . "24-5.html#_1348") ("complete-input" . "24-5.html#_1346") ("complete-from-possibilities" . "24-5.html#_1351") ("complete-from-generator" . "24-5.html#_1350") ("command-table-p" . "27-2.html#_1386") ("command-table-not-found" . "27-2.html#_1395") ("command-table-name" . "27-2.html#_1388") ("command-table-inherit-from" . "27-2.html#_1389") ("command-table-error" . "27-2.html#_1394") ("command-table-complete-input" . "27-2.html#_1410") ("command-table-already-exists" . "27-2.html#_1396") ("command-table" . "27-2.html#_1385") (":command-table" . "28-2.html#_1472") ("command-present-in-command-table-p" . "27-2.html#_1406") ("command-or-form" . "27-6.html#_1455") ("command-not-present" . "27-2.html#_1397") ("command-not-accessible" . "27-2.html#_1398") ("command-name-from-symbol" . "27-2.html#_1402") ("command-name" . "27-6.html#_1454") ("command-name" . "27-1.html#_1377") ("command-menu-pane" . "29-4.html#_1682") ("command-menu-item-value" . "27-3.html#_1419") ("command-menu-item-type" . "27-3.html#_1418") ("command-menu-item-options" . "27-3.html#_1420") ("command-line-read-remaining-arguments-for-partial-command" . "27-6.html#_1442") ("command-line-name-for-command" . "27-2.html#_1409") ("command-line-command-unparser" . "27-6.html#_1441") ("command-line-command-parser" . "27-6.html#_1440") ("command-enabled" . "28-4.html#_1537") ("command-arguments" . "27-1.html#_1378") ("command-already-present" . "27-2.html#_1399") ("command-accessible-in-command-table-p" . "27-2.html#_1407") ("command" . "27-6.html#_1453") ("command" . "27-1.html#_1374") ("column-output-record-p" . "17-3.html#_946") ("column-output-record" . "17-3.html#_945") ("colorp" . "13-3.html#_687") ("colorless" . "13-2.html#_682") ("colored" . "13-2.html#_683") ("color-rgb" . "13-3.html#_691") ("color-ihs" . "13-3.html#_692") ("color" . "13-3.html#_686") (":clx" . "9-2.html#_458") ("closed" . "3-2.html#_83") ("close" . "D-2.html#_1937") (":clipping-region" . "10-2.html#_529") ("clim-stream-pane" . "29-4.html#_1679") (":client" . "30-3.html#_1716") ("client" . "8-1.html#_296") ("client" . "30-2.html#_1708") ("clear-resource" . "B-1.html#_1876") ("clear-output-record" . "16-2.html#_862") ("class-presentation-type-name" . "23-3.html#_1188") ("children-overlapping-region" . "7-3.html#_285") ("children-overlapping-rectangle*" . "7-3.html#_286") ("children" . "6-1.html#_229") ("children" . "16-1.html#_833") ("child-containing-position" . "7-3.html#_284") ("check-box-selections" . "30-4.html#_1832") ("check-box-pane" . "30-4.html#_1834") ("check-box-current-selection" . "30-4.html#_1830") ("check-box" . "30-4.html#_1828") ("character" . "23-8.html#_1270") ("changing-space-requirements" . "29-3.html#_1664") ("change-space-requirements" . "29-3.html#_1662") (":center-nodes" . "18-2.html#_984") ("cell-output-record-p" . "17-3.html#_951") ("cell-output-record" . "17-3.html#_950") ("cell-min-width" . "17-3.html#_959") ("cell-min-height" . "17-3.html#_960") ("cell-align-y" . "17-3.html#_958") ("cell-align-x" . "17-3.html#_957") (":calling-frame" . "28-2.html#_1476") ("call-presentation-translator" . "23-7.html#_1241") ("call-presentation-menu" . "23-7.html#_1243") (":cache-value" . "21-3.html#_1028") (":cache-test" . "21-3.html#_1029") (":button" . "8-2.html#_343") ("bury-sheet" . "7-2.html#_257") ("bury-mirror" . "9-4.html#_495") ("bury-frame" . "28-2.html#_1487") ("bounding-rectangle-width" . "4-1.html#_166") ("bounding-rectangle-size" . "4-1.html#_168") ("bounding-rectangle-position" . "4-1.html#_161") ("bounding-rectangle-p" . "4-1.html#_153") ("bounding-rectangle-min-y" . "4-1.html#_163") ("bounding-rectangle-min-x" . "4-1.html#_162") ("bounding-rectangle-max-y" . "4-1.html#_165") ("bounding-rectangle-max-x" . "4-1.html#_164") ("bounding-rectangle-height" . "4-1.html#_167") ("bounding-rectangle" . "4-1.html#_152") ("bounding-rectangle" . "4-1.html#_158") ("bounding-rectangle*" . "4-1.html#_157") ("bounded" . "13-2.html#_676") ("boolean" . "23-8.html#_1256") ("blank-area" . "23-8.html#_1259") ("beep" . "15-5.html#_824") ("bboard-pane" . "29-3.html#_1633") ("basic-sheet" . "7-1.html#_240") ("basic-port" . "9-2.html#_455") ("basic-pane" . "29-2.html#_1587") ("basic-medium" . "8-3.html#_388") ("basic-gadget" . "30-3.html#_1714") (":background" . "29-2.html#_1593") ("augment-draw-set" . "21-3.html#_1038") ("atomic-incf" . "B-2.html#_1896") ("atomic-decf" . "B-2.html#_1897") (":armed-callback" . "30-3.html#_1717") ("armed-callback" . "30-3.html#_1725") ("areap" . "3-1.html#_45") ("area" . "3-1.html#_44") ("apply-presentation-generic-function" . "23-3.html#_1160") ("application-pane" . "29-4.html#_1681") ("application-frame-p" . "28-2.html#_1469") ("application-frame" . "28-2.html#_1468") ("applicability" . "23-7.html#_1231") ("anti-aliasing" . "12-4.html#_606") ("and" . "23-8.html#_1288") ("allocate-space" . "29-3.html#_1661") ("allocate-resource" . "B-1.html#_1874") ("allocate-pixmap" . "12-6.html#_645") ("allocate-medium" . "8-3.html#_421") ("all-processes" . "B-2.html#_1883") (":align-y" . "29-3.html#_1613") (":align-y" . "17-3.html#_953") (":align-y" . "30-3.html#_1749") (":align-x" . "29-3.html#_1612") (":align-x" . "17-3.html#_952") (":align-x" . "30-3.html#_1748") ("adopted" . "7-2.html#_242") ("adopted" . "28-5.html#_1541") ("adopt-frame" . "28-5.html#_1556") ("adjust-table-cells" . "17-3.html#_938") ("adjust-multiple-columns" . "17-3.html#_939") ("adjust-item-list-cells" . "17-3.html#_974") ("add-string-output-to-text-record" . "16-3.html#_881") ("add-presentation-translator-to-command-table" . "27-5.html#_1432") ("add-output-record" . "16-2.html#_860") ("add-menu-item-to-command-table" . "27-3.html#_1414") ("add-keystroke-to-command-table" . "27-4.html#_1424") ("add-input-editor-command" . "24-1.html#_1322") ("add-gesture-name" . "22-3.html#_1101") ("add-command-to-command-table" . "27-2.html#_1400") ("add-character-output-to-text-record" . "16-3.html#_880") ("active" . "15-3.html#_784") ("activation-gesture-p" . "24-2.html#_1327") ("activate-gadget" . "30-3.html#_1727") (":activate-callback" . "30-3.html#_1740") ("activate-callback" . "30-3.html#_1742") ("action-gadget" . "30-3.html#_1739") ("accessible" . "27-2.html#_1384") ("accepting-values" . "26.html#_1364") ("accept-values-resynchronize" . "26.html#_1368") ("accept-values-command-button" . "26.html#_1369") ("accept-values" . "26.html#_1366") ("accept-present-default" . "23-3.html#_1168") ("accept-from-string" . "23-5.html#_1205") ("accept-1" . "23-5.html#_1204") ("accept" . "23-3.html#_1162") ("accept" . "23-5.html#_1202") ("accelerator-gesture-numeric-argument" . "22-2.html#_1093") ("accelerator-gesture-event" . "22-2.html#_1092") ("accelerator-gesture" . "22-2.html#_1091") ("abort-gesture-event" . "22-2.html#_1089") ("abort-gesture" . "22-2.html#_1088"))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/pointer-tracking.lisp0000640000175000017500000004704610705412614021157 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2002 by Alexey Dejneka (adejneka@comail.ru) ;;; (c) copyright 2004 by Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; TODO: ;;; ;;; - Keyboard gestures. ;;; ;;; - Optimization ;;; ;;; - - too many repeated checks within a loop; ;;; ;;; - - remove invoke-tracking-pointer; remove unnecessary checks. (in-package :clim-internals) ;;; The Spec specifies the tracking-pointer clause arguments as, e.g., ;;; (&key presentation event x y), implying that the user must write ;;; the &key keyword, but real code doesn't do that. Check if &key is in ;;; the arg list and add it if it is not. (eval-when (:compile-toplevel :load-toplevel :execute) (defun fix-tracking-pointer-args (args) (unless (member '&allow-other-keys args) (setq args (append args '(&allow-other-keys)))) (if (eq (car args) '&key) args (cons '&key args)))) (defmacro with-pointer-grabbed ((port sheet &key pointer) &body body) (with-gensyms (the-port the-sheet the-pointer grabbed) `(let* ((,the-port ,port) (,the-sheet ,sheet) (,the-pointer (or ,pointer (port-pointer ,the-port))) (,grabbed nil)) ;; Don't end up in the debugger with the pointer grabbed! (handler-bind ((error #'(lambda (c) (declare (ignore c)) (when ,grabbed (port-ungrab-pointer ,the-port ,the-pointer ,the-sheet) (setq ,grabbed nil))))) (unwind-protect (when (port-grab-pointer ,the-port ,the-pointer ,the-sheet) (setq ,grabbed t) ,@body) (when ,grabbed (port-ungrab-pointer ,the-port ,the-pointer ,the-sheet))))))) ;;; tracking-pointer. The functionality that deals with presentations has been ;;; split off into frames.lisp. (defgeneric tracking-pointer-loop (state frame sheet &key pointer multiple-window transformp context-type highlight &allow-other-keys)) (defgeneric tracking-pointer-loop-step (tracking-state event x y)) (defgeneric make-tracking-pointer-state (frame sheet args)) (defmacro tracking-pointer ((sheet &rest args &key pointer multiple-window transformp context-type (highlight nil highlight-p)) &body body) (declare (ignorable multiple-window pointer transformp context-type highlight)) (setq sheet (stream-designator-symbol sheet '*standard-output*)) (loop for (event-name handler-args . handler-body) in body for handler-name = (gensym (symbol-name event-name)) collect `(,handler-name ,(fix-tracking-pointer-args handler-args) ,@handler-body) into bindings collect `#',handler-name into fn-names append `(,event-name #',handler-name) into tracking-pointer-args finally (return `(flet ,bindings (declare (dynamic-extent ,@fn-names)) (invoke-tracking-pointer-loop *application-frame* ,sheet ,@tracking-pointer-args ,@args #-cmu18e :allow-other-keys #-cmu18e t))))) (defun invoke-tracking-pointer-loop (frame sheet &rest args) (apply #'tracking-pointer-loop (make-tracking-pointer-state frame sheet args) frame sheet args)) (defun default-tracking-handler (&rest args) (declare (ignore args)) nil) (defclass tracking-pointer-state () ((motion-handler :reader motion-handler :initarg :pointer-motion) (button-press-handler :reader button-press-handler :initarg :pointer-button-press) (buttton-release-handler :reader button-release-handler :initarg :pointer-button-release) (keyboard-handler :reader keyboard-handler :initarg :keyboard)) (:default-initargs :pointer-motion #'default-tracking-handler :pointer-button-press #'default-tracking-handler :pointer-button-release #'default-tracking-handler :keyboard #'default-tracking-handler)) (defmethod tracking-pointer-loop ((state tracking-pointer-state) frame sheet &rest args &key pointer multiple-window transformp context-type highlight) (declare (ignore args pointer context-type highlight frame)) (with-sheet-medium (medium sheet) (flet ((do-tracking () (loop for event = (event-read sheet) do (if (typep event 'pointer-event) (multiple-value-bind (sheet-x sheet-y) (pointer-event-position* event) (multiple-value-bind (x y) (if transformp (transform-position (medium-transformation medium) sheet-x sheet-y) (values sheet-x sheet-y)) (tracking-pointer-loop-step state event x y))) (tracking-pointer-loop-step state event 0 0))))) (if multiple-window (with-pointer-grabbed ((port medium) sheet) (do-tracking)) (do-tracking))))) (defmethod tracking-pointer-loop-step ((state tracking-pointer-state) (event pointer-motion-event) x y) (funcall (motion-handler state) :event event :window (event-sheet event) :x x :y y)) (defmethod tracking-pointer-loop-step ((state tracking-pointer-state) (event pointer-button-press-event) x y) (funcall (button-press-handler state) :event event :window (event-sheet event) :x x :y y)) (defmethod tracking-pointer-loop-step ((state tracking-pointer-state) (event pointer-button-release-event) x y) (funcall (button-release-handler state) :event event :window (event-sheet event) :x x :y y)) (defmethod tracking-pointer-loop-step ((state tracking-pointer-state) (event t) x y) (declare (ignore x y)) (if (typep event '(or keyboard-event character symbol)) (funcall (keyboard-handler state) :gesture event) (handle-event (event-sheet event) event))) ;;; DRAG-OUTPUT-RECORD and DRAGGING-OUTPUT. ;;; ;;; XXX Unresolved issues: ;;; multiple-window is completely unsupported. ;;; window-repaint events while dragging. (defun bound-rectangles (r1-x1 r1-y1 r1-x2 r1-y2 r2-x1 r2-y1 r2-x2 r2-y2) (values (min r1-x1 r2-x1) (min r1-y1 r2-y1) (max r1-x2 r2-x2) (max r1-y2 r2-y2))) (defgeneric drag-output-record (stream output &key repaint erase feedback finish-on-release multiple-window)) ;;; Fancy double-buffered feedback function (defun make-buffered-feedback-function (record finish-on-release erase-final) (multiple-value-bind (record-x record-y) (output-record-position record) (lambda (record stream initial-x initial-y x y event) (flet ((simple-erase () (when erase-final (when (output-record-parent record) (delete-output-record record (output-record-parent record))) (with-double-buffering ((stream record) (buffer-rectangle)) (stream-replay stream buffer-rectangle))))) (let ((dx (- record-x initial-x)) (dy (- record-y initial-y))) (typecase event (null (setf (output-record-position record) (values (+ dx x) (+ dy y))) (stream-add-output-record stream record) (stream-replay stream record)) (pointer-motion-event ;; Don't do an explicit erase. Instead, update the position of the ;; output record and redraw the union of the old and new ;; positions. (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record (when (output-record-parent record) (delete-output-record record (output-record-parent record))) (setf (output-record-position record) (values (+ dx x) (+ dy y))) (stream-add-output-record stream record) (with-bounding-rectangle* (new-x1 new-y1 new-x2 new-y2) record (multiple-value-bind (area-x1 area-y1 area-x2 area-y2) (bound-rectangles old-x1 old-y1 old-x2 old-y2 new-x1 new-y1 new-x2 new-y2) (with-double-buffering ((stream area-x1 area-y1 area-x2 area-y2) (buffer-rectangle)) (stream-replay stream buffer-rectangle)))))) (pointer-button-press-event (unless finish-on-release (simple-erase))) (pointer-button-release-event (when finish-on-release (simple-erase))) (t nil))))))) ;;; If the user supplies a feedback function, create a function to ;;; call it with the simple :draw / :erase arguments. (defun make-simple-feedback-function (record feedback finish-on-release erase-final) (declare (ignore record)) (lambda (record stream initial-x initial-y x y event) (typecase event (null (funcall feedback record stream initial-x initial-y x y :draw)) (pointer-motion-event (funcall feedback record stream initial-x initial-y x y :erase) (funcall feedback record stream initial-x initial-y x y :draw)) (pointer-button-press-event (unless finish-on-release (when erase-final (funcall feedback record stream initial-x initial-y x y :erase)))) (pointer-button-release-event (when (and finish-on-release erase-final) (funcall feedback record stream initial-x initial-y x y :erase))) (t nil)))) (defmethod drag-output-record ((stream output-recording-stream) (record output-record) &key (repaint t) (erase #'erase-output-record) feedback finish-on-release multiple-window feedback-event erase-final) (declare (ignore erase repaint multiple-window)) (let ((feedback-event-fn (cond (feedback-event feedback-event) (feedback (make-simple-feedback-function record feedback finish-on-release erase-final)) (t (make-buffered-feedback-function record finish-on-release erase-final))))) (setf (stream-current-output-record stream) (stream-output-history stream)) (let* ((pointer (port-pointer (port stream))) (pointer-state (pointer-button-state pointer))) (multiple-value-bind (x0 y0) (stream-pointer-position stream) (funcall feedback-event-fn record stream x0 y0 x0 y0 nil) (tracking-pointer (stream) (:pointer-motion (&key event x y) ;; XXX What about the sheet? (funcall feedback-event-fn record stream x0 y0 x y event) (funcall feedback-event-fn record stream x0 y0 x y event)) (:pointer-button-press (&key event x y) (unless finish-on-release (funcall feedback-event-fn record stream x0 y0 x y event) (return-from drag-output-record (values x y)))) (:pointer-button-release (&key event x y) ;; If the button released was one of those held down on entry to ;; drag-output-record, we're done. (when (and finish-on-release (not (zerop (logand pointer-state (pointer-event-button event))))) (funcall feedback-event-fn record stream x0 y0 x y event) (return-from drag-output-record (values x y))))))))) (defmacro dragging-output ((&optional (stream '*standard-output*) &rest args &key (repaint t) finish-on-release multiple-window) &body body) (declare (ignore repaint finish-on-release multiple-window)) (setq stream (stream-designator-symbol stream '*standard-output*)) (with-gensyms (record) `(let ((,record (with-output-to-output-record (,stream) ,@body))) (drag-output-record ,stream ,record :erase-final t ,@args)))) (defun dragging-drawing (stream drawer &key (finish-on-release t) (pointer (port-pointer (port stream))) multiple-window) "Draws something simple in response to pointer events for `pointer' and returns the coordinates of the pointer when the function finishes. The function finishes when mouse button one is no longer held down if `finish-on-release' is true; if it is false, it finishes when the mouse is clicked. `Drawer' should draw something on `stream', and is called with tree arguments: two integers, the X and the Y coordinates for the pointer motion triggering the draw, and either the symbol `:draw' or `:erase' signalling what the function should do. `Drawer' will be called with the previously used coordinates whenever pointer motion occurs, so it can erase the previous output (elegantly done by using `+flipping-ink+' for drawing and ignoring the state symbol)." (with-output-recording-options (stream :draw t :record nil) (let ((ox nil) (oy nil)) ; So we can erase the old line. (labels ((draw (x y) (funcall drawer x y :draw)) (erase (x y) (funcall drawer x y :erase)) (motion (x y) (when ox (erase ox oy)) (draw x y) (setf ox x oy y)) (end (event x y) (when (eql (event-sheet event) stream) (when ox (draw ox oy)) (return-from dragging-drawing (values x y))))) ;; Make an initial draw. We need to convert the screen ;; coordinates from the pointer into sheet-local coordinates. (multiple-value-call #'transform-position (sheet-native-transformation stream) (pointer-position pointer)) (tracking-pointer (stream :pointer pointer :multiple-window multiple-window) (:pointer-motion (window x y) (when (eql window stream) (motion x y))) (:pointer-button-press (event x y) (end event x y)) (:pointer-button-release (event x y) (when finish-on-release (end event x y)))))))) (defun pointer-place-rubber-band-line* (&key (stream *standard-output*) (pointer (port-pointer (port stream))) multiple-window start-x start-y (finish-on-release t)) "Let the user drag a line on `stream', returning the coordinates of the line ends as four values. `Pointer' is the pointer that will be tracked (the default should be used unless the port has multiple pointing devices), `multiple-window' is currently unimplemented and `start-x'/`start-y', if provided (and both or none must be provided) are the coordinates for one end of the line. If these arguments are not provided, the user will have to press a mouse button to specify the beginning of the line. If `finish-on-release' is true, the function will end when the user releases the mouse button. If false, the user will have to click to finish inputting the line." (assert (not (eq (not (not start-x)) (not start-y))) nil "You must provide either both `:start-x' and `:start-y' or none at all") (or start-x (block nil (tracking-pointer (stream :pointer pointer :multiple-window multiple-window) (:pointer-button-press (event x y) (declare (ignore event)) (setf start-x x) (setf start-y y) (return))))) (assert (and (>= start-x 0) (>= start-y 0))) (labels ((draw (x y state) (declare (ignore state)) (with-drawing-options (stream :ink +flipping-ink+) (draw-line* stream start-x start-y x y)))) (multiple-value-call #'values (values start-x start-y) (dragging-drawing stream #'draw :finish-on-release finish-on-release :pointer pointer :multiple-window multiple-window)))) ;; The CLIM 2.2 spec is slightly unclear about how the next two ;; functions are supposed to behave, especially wrt. the user ;; experience. I think these functions are supposed to present a ;; rectangle on screen and let the user drag around the edges - this ;; would make supporting both left/top and right/bottom make sense, ;; and provide a way for the :rectangle argument to ;; `pointer-input-rectangle' to make sense. However, this would be a ;; very weird user experience, so I (Troels) have instead chosen to ;; consider left/top and right/bottom to be the same thing, preferring ;; left/top if both are specified. The :rectangle argument to ;; `pointer-input-rectangle' is ignored. The user is meant to drag out ;; a rectangle with the mouse, possibly by first providing a starting ;; point. This is intuitive behavior and I see no point in supporting ;; something more complicated. These changes should be invisible to ;; the calling program. (defun pointer-input-rectangle* (&key (stream *standard-output*) (pointer (port-pointer (port stream))) multiple-window left top right bottom (finish-on-release t)) "Let the user drag a rectangle on `stream' and return four values, the coordinates of the rectangle. `Pointer' is the pointer that will be tracked (the default should be used unless the port has multiple pointing devices), `multiple-window' is currently unimplemented and both `left'/`top' and `right'/`bottom' specify an initial position for a rectangle corner. You must provide either both parts of any of these two coordinate pairs or none at all. If you provide both `left'/`top' and `right'/`bottom', the `left'/`top' values will be used, otherwise, the non-nil set will be used. If neither is specified, the user will be able to specify the origin corner of the rectangle by clicking the mouse. If `finish-on-release' is true, the function will end when the user releases the mouse button. If false, the user will have to click to finish inputting the rectangle." (assert (not (eq (not (not top)) (not left))) nil "You must provide either none or both of `:top' and `:left'") (assert (not (eq (not (not right)) (not bottom))) nil "You must provide either none or both of `:right' and `:bottom'") (setf top (or top bottom) left (or left right)) (unless top (block nil (tracking-pointer (stream :pointer pointer :multiple-window multiple-window) (:pointer-button-press (event x y) (declare (ignore event)) (setf left x) (setf top y) (return))))) (multiple-value-bind (x y) (labels ((draw (x y state) (declare (ignore state)) (with-drawing-options (stream :ink +flipping-ink+) (draw-rectangle* stream left top x y :filled nil)))) (dragging-drawing stream #'draw :finish-on-release finish-on-release :pointer pointer :multiple-window multiple-window)) ;; Normalise so that x1 < x2 ^ y1 < y2. (values (min left x) (min top y) (max left x) (max top y)))) (defun pointer-input-rectangle (&rest args &key (stream *standard-output*) (pointer (port-pointer (port stream))) multiple-window rectangle (finish-on-release t)) "Like `pointer-input-rectangle*', but returns a bounding rectangle instead of coordinates." (declare (ignore pointer multiple-window rectangle finish-on-release)) (with-keywords-removed (args (:rectangle)) (apply #'make-bounding-rectangle (apply #'pointer-input-rectangle args)))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/mcclim.asd0000644000175000017500000007310011345155771016746 0ustar pdmpdm;;; -*- Mode: Lisp -*- ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com) ;;; (c) copyright 2000 by ;;; Robert Strandh (strandh@labri.u-bordeaux.fr) ;;; (c) copyright 2005 by ;;; Andreas Fuchs (asf@boinkor.net) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Really, I wouldn't bother with anything but ASDF. Almost every lisp ;;; ships with it, and it has the added benefit of ASDF-INSTALL. ;;; Get ASDF, and be welcome to the 21st century. -- [2005-01-31:asf] (defpackage :mcclim.system (:use :asdf :cl)) (in-package :mcclim.system) (defparameter *clim-directory* (directory-namestring *load-truename*)) (eval-when (:compile-toplevel :load-toplevel :execute) (defun find-swank-package () (find-package :swank)) (defun find-swank-system () (handler-case (asdf:find-system :swank) (asdf:missing-component ()))) (defun find-swank () (or (find-swank-package) (find-swank-system))) (defun dep-on-swank () (if (and (find-swank-system) (not (find-package :swank))) '(:and) '(:or))) (defun ifswank () (if (find-swank) '(:and) '(:or)))) ;;; Legacy CMUCL support stuff #+cmu (progn (unless (fboundp 'ext:stream-read-char) (unless (ignore-errors (ext:search-list "gray-streams:")) (setf (ext:search-list "gray-streams:") '("target:pcl/" "library:subsystems/"))) (if (fboundp 'extensions:without-package-locks) (extensions:without-package-locks (load "gray-streams:gray-streams-library")) (load "gray-streams:gray-streams-library"))) #-(or clx clim-gtkairo clim-graphic-forms) (require :clx) #+mp (when (eq mp::*initial-process* mp::*current-process*) (format t "~%~%You need to run (mp::startup-idle-and-top-level-loops) to start up the multiprocessing support.~%~%"))) ;;; Make CLX asdf-loadable on Allegro 6.2 ;;; possibly this should be further refined to funciton properly for ;;; Allegro on Windows platforms. [2005/04/18:rpg] #+allegro (progn (defclass requireable-system (asdf:system) ()) (defmethod asdf:perform ((op asdf:load-op) (system requireable-system)) (require (intern (slot-value system 'asdf::name) :keyword))) (defmethod asdf::traverse ((op asdf:load-op) (system requireable-system)) (list (cons op system))) (defsystem :clx :class requireable-system)) ;;; Clozure CL native GUI stuff #+clim-beagle (require :cocoa) (defmacro clim-defsystem ((module &key depends-on) &rest components) `(progn (asdf:defsystem ,module ,@(and depends-on `(:depends-on ,depends-on)) :serial t :components (,@(loop for c in components for p = (merge-pathnames (parse-namestring c) (make-pathname :type "lisp" :defaults *clim-directory*)) collect `(:file ,(namestring p) :pathname ,p)))))) (defsystem :clim-lisp :components (;; First possible patches (:file "patch") (:module "Lisp-Dep" :depends-on ("patch") :components ((:file #+cmu "fix-cmu" #+scl "fix-scl" #+excl "fix-acl" #+sbcl "fix-sbcl" #+openmcl "fix-openmcl" #+lispworks "fix-lispworks" #+clisp "fix-clisp"))) (:file "package" :depends-on ("Lisp-Dep" "patch")))) (defsystem :clim-basic :depends-on (:clim-lisp :spatial-trees (:version "flexichain" "1.5.1")) :components ((:file "decls") (:file "protocol-classes" :depends-on ("decls")) (:module "Lisp-Dep" :depends-on ("decls") :components ((:file #.(first (list #+(and :cmu :mp (not :pthread)) "mp-cmu" #+scl "mp-scl" #+sb-thread "mp-sbcl" #+excl "mp-acl" #+openmcl "mp-openmcl" #+lispworks "mp-lw" #| fall back |# "mp-nil"))))) (:file "utils" :depends-on ("decls" "Lisp-Dep")) (:file "design" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "utils")) (:file "X11-colors" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "design")) (:file "coordinates" :depends-on ("decls" "protocol-classes" "Lisp-Dep")) (:file "setf-star" :depends-on ("decls" "Lisp-Dep")) (:file "transforms" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "coordinates" "utils")) (:file "dead-keys" :depends-on ("decls")) (:file "regions" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "coordinates" "utils" "transforms" "setf-star" "design")) (:file "sheets" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "utils" "transforms" "regions")) (:file "pixmap" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "sheets" "transforms" "regions")) (:file "events" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "transforms" "sheets" "utils")) (:file "ports" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "events" "sheets" "pixmap" "utils")) (:file "grafts" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "sheets" "ports" "transforms" "regions")) (:file "medium" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "ports" "X11-colors" "utils" "pixmap" "regions" "transforms" "design")) (:file "output" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "medium")) (:file "input" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "events" "regions" "sheets")) (:file "repaint" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "sheets" "events")) (:file "graphics" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "output" "utils" "medium" "sheets" "pixmap" "regions" "design" "transforms")) (:file "views" :depends-on ("utils" "protocol-classes")) (:file "stream-output" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "design" "utils" "X11-colors" "views" "output" "sheets" "regions" "graphics" "medium" "setf-star")) (:file "recording" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "output" "coordinates" "graphics" "design" "medium" "transforms" "regions" "sheets" "utils" "stream-output")) (:file "encapsulate" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "sheets" "graphics" "utils" "medium" "input" "stream-output" "recording")) (:file "stream-input" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "input" "ports" "sheets" "events" "encapsulate" "transforms" "utils" "dead-keys")) (:file "text-selection" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "X11-colors" "medium" "output" "transforms" "sheets" "stream-output" "ports" "recording" "regions" "events")) (:file "bezier" :depends-on ("recording")))) (defsystem :goatee-core :depends-on (:clim-basic) :components ((:module "Goatee" :components ((:file "conditions") (:file "dbl-list") (:file "flexivector" :depends-on ("conditions" "dbl-list")) (:file "buffer" :depends-on ("conditions" "flexivector" "dbl-list")) (:file "editable-buffer" :depends-on ("dbl-list" "flexivector" "buffer")) (:file "editable-area" :depends-on ("flexivector" "editable-buffer" "dbl-list" "buffer")) (:file "clim-area" :depends-on ("flexivector" "dbl-list" "buffer" "editable-area" "editable-buffer")) (:file "kill-ring" :depends-on ("editable-buffer" "dbl-list" "flexivector" "buffer")) (:file "goatee-command" :depends-on ("conditions" "clim-area" "dbl-list" "editable-buffer" "kill-ring" "editable-area" "buffer" "flexivector")) (:file "editing-stream" :depends-on ("goatee-command" "kill-ring" "dbl-list" "conditions" "editable-buffer" "flexivector" "clim-area" "buffer")) (:file "presentation-history" :depends-on ("editing-stream" "buffer" "flexivector" "editable-buffer" "goatee-command")))))) ;;; CLIM-PostScript is not a backend in the normal sense. ;;; It is an extension (Chap. 35.1 of the spec) and is an ;;; "included" part of McCLIM. Hence the defsystem is here. (defsystem :clim-postscript :depends-on (:clim-basic) :components ((:module "Backends/PostScript" :pathname #.(make-pathname :directory '(:relative "Backends" "PostScript")) :components ((:file "package") (:file "encoding" :depends-on ("package")) (:file "paper" :depends-on ("package")) (:file "class" :depends-on ("paper" "package")) (:file "font" :depends-on ("encoding" "class" "paper" "package")) (:file "graphics" :depends-on ("encoding" "paper" "class" "font" "package")) (:file "sheet" :depends-on ("paper" "class" "graphics" "package")) (:file "afm" :depends-on ("class" "paper" "font" "package")) (:file "standard-metrics" :depends-on ("font" "package")))))) (defsystem :clim-core :depends-on (:clim-basic :goatee-core :clim-postscript) :components ((:file "text-formatting") (:file "defresource") (:file "presentations") (:file "xpm") (:file "bordered-output" :depends-on ("presentations")) (:file "table-formatting" :depends-on ("presentations")) (:file "input-editing" :depends-on ("presentations" "bordered-output" "table-formatting")) (:file "pointer-tracking" :depends-on ("input-editing")) (:file "graph-formatting") (:file "frames" :depends-on ("commands" "presentations" "presentation-defs" "pointer-tracking" "incremental-redisplay")) (:file "dialog-views" :depends-on ("presentations" "incremental-redisplay" "bordered-output" "presentation-defs")) (:file "presentation-defs" :depends-on ("input-editing" "presentations")) (:file "gadgets" :depends-on ("commands" "pointer-tracking" "input-editing" "frames" "incremental-redisplay" "panes")) (:file "describe" :depends-on ("presentations" "presentation-defs" "table-formatting")) (:file "commands" :depends-on ("input-editing" "presentations" "presentation-defs")) (:file "incremental-redisplay" :depends-on ("presentation-defs")) (:file "menu-choose" :depends-on ("commands" "table-formatting" "presentation-defs" "panes" "frames" "pointer-tracking" "presentations")) (:file "menu" :depends-on ("panes" "commands" "gadgets" "presentations" "frames")) (:file "panes" :depends-on ("incremental-redisplay" "presentations" "presentation-defs" "input-editing" "frames")) (:file "dialog" :depends-on ("panes" "frames" "incremental-redisplay" "table-formatting" "presentations" "bordered-output" "presentation-defs" "dialog-views" "input-editing" "commands")) (:file "builtin-commands" :depends-on ("table-formatting" "commands" "presentations" "dialog" "presentation-defs" "input-editing")))) (defsystem :esa-mcclim :depends-on (:clim-core) :components ((:module "ESA" :components ((:file "packages") (:file "utils" :depends-on ("packages")) (:file "colors" :depends-on ("packages")) (:file "esa" :depends-on ("colors" "packages" "utils")) (:file "esa-buffer" :depends-on ("packages" "esa")) (:file "esa-io" :depends-on ("packages" "esa" "esa-buffer")) (:file "esa-command-parser" :depends-on ("packages" "esa")))))) (defsystem :drei-mcclim :depends-on ((:version "flexichain" "1.5.1") :esa-mcclim :clim-core #+#.(mcclim.system::dep-on-swank) :swank) :components ((:module "cl-automaton" :pathname #.(make-pathname :directory '(:relative "Drei" "cl-automaton")) :components ((:file "automaton-package") (:file "eqv-hash" :depends-on ("automaton-package")) (:file "state-and-transition" :depends-on ("eqv-hash")) (:file "automaton" :depends-on ("state-and-transition" "eqv-hash")) (:file "regexp" :depends-on ("automaton")))) (:module "Persistent" :pathname #.(make-pathname :directory '(:relative "Drei" "Persistent")) :components ((:file "binseq-package") (:file "binseq" :depends-on ("binseq-package")) (:file "obinseq" :depends-on ("binseq-package" "binseq")) (:file "binseq2" :depends-on ("binseq-package" "obinseq" "binseq")))) (:module "Drei" :depends-on ("cl-automaton" "Persistent") :components ((:file "packages") (:file "buffer" :depends-on ("packages")) (:file "delegating-buffer" :depends-on ("packages" "buffer")) (:file "motion" :depends-on ("packages" "buffer" "syntax")) (:file "editing" :depends-on ("packages" "buffer" "syntax" "motion" "kill-ring")) (:file "base" :depends-on ("packages" "buffer" "persistent-buffer" "kill-ring" "delegating-buffer")) (:file "syntax" :depends-on ("packages" "buffer" "base")) (:file "modes" :depends-on ("packages" "syntax")) (:file "views" :depends-on ("packages" "buffer" "base" "syntax" "persistent-undo" "persistent-buffer" "undo" "abbrev" "delegating-buffer" "modes")) (:file "drei" :depends-on ("packages" "views" "motion" "editing")) (:file "drei-clim" :depends-on ("drei")) (:file "drei-redisplay" :depends-on ("drei-clim")) (:file "drawing-options" :depends-on ("drei-redisplay")) (:file "input-editor" :depends-on ("drei-redisplay" "lisp-syntax" "core")) (:file "abbrev" :depends-on ("packages")) (:file "kill-ring" :depends-on ("packages")) (:file "undo" :depends-on ("packages")) (:file "basic-commands" :depends-on ("drei-clim" "motion" "editing")) (:file "core" :depends-on ("drei")) (:file "fundamental-syntax" :depends-on ("packages" "drei-redisplay" "core")) (:file "buffer-streams" :depends-on ("core")) (:file "rectangle" :depends-on ("core")) (:file "targets" :depends-on ("core")) (:file "core-commands" :depends-on ("core" "rectangle" "drei-clim")) (:file "persistent-buffer" :pathname #.(make-pathname :directory '(:relative "Persistent") :name "persistent-buffer" :type "lisp") :depends-on ("packages")) (:file "persistent-undo" :pathname #p"Persistent/persistent-undo.lisp" :depends-on ("packages" "buffer" "persistent-buffer" "undo")) (:file "misc-commands" :depends-on ("basic-commands")) (:file "search-commands" :depends-on ("core" "targets" "drei-clim")) (:file "lr-syntax" :depends-on ("fundamental-syntax" "core" "drawing-options")) (:file "lisp-syntax" :depends-on ("lr-syntax" "motion" "core")) (:file "lisp-syntax-swine" :depends-on ("lisp-syntax")) (:file "lisp-syntax-commands" :depends-on ("lisp-syntax-swine" "misc-commands")) #+#.(mcclim.system::ifswank) (:file "lisp-syntax-swank" :depends-on ("lisp-syntax")))))) (defsystem :drei-tests :depends-on (:drei-mcclim :fiveam) :components ((:module "Tests" :pathname #.(make-pathname :directory '(:relative "Drei" "Tests")) :components ((:module "cl-automaton" :depends-on ("testing") :components ((:file "automaton-tests") (:file "state-and-transition-tests" :depends-on ("automaton-tests")) (:file "eqv-hash-tests" :depends-on ("automaton-tests")) (:file "regexp-tests" :depends-on ("automaton-tests")))) (:file "packages") (:file "testing" :depends-on ("packages")) (:file "buffer-tests" :depends-on ("testing")) (:file "base-tests" :depends-on ("testing")) (:file "kill-ring-tests" :depends-on ("testing")) (:file "motion-tests" :depends-on ("testing")) (:file "editing-tests" :depends-on ("testing")) (:file "core-tests" :depends-on ("testing")) (:file "buffer-streams-tests" :depends-on ("testing")) (:file "rectangle-tests" :depends-on ("testing")) (:file "undo-tests" :depends-on ("testing")) (:file "lisp-syntax-tests" :depends-on ("testing" "motion-tests")) (:file "lisp-syntax-swine-tests" :depends-on ("lisp-syntax-tests")))))) (defsystem :clim :depends-on (:clim-core :goatee-core :clim-postscript :drei-mcclim) :components ((:file "Goatee/presentation-history" ; XXX: this is loaded as part of the Goatee system. huh? :pathname #.(make-pathname :directory '(:relative "Goatee") :name "presentation-history" :type "lisp")) (:file "input-editing-goatee") (:file "input-editing-drei") (:file "text-editor-gadget") (:file "Extensions/tab-layout" :pathname #.(make-pathname :directory '(:relative "Extensions") :name "tab-layout")))) (defsystem :clim-clx :depends-on (:clim #+(or sbcl openmcl ecl allegro) :clx) :components ((:module "Backends/CLX" :pathname #.(make-pathname :directory '(:relative "Backends" "CLX")) :components ((:file "package") (:file "image" :depends-on ("package")) (:file "keysyms-common" :depends-on ("package")) (:file "keysyms" :depends-on ("keysyms-common" "package")) (:file "keysymdef" :depends-on ("keysyms-common" "package")) (:file "port" :depends-on ("keysyms-common" "keysyms" "package")) (:file "medium" :depends-on ("port" "keysyms" "package")) (:file "graft" :depends-on ("port" "package")) (:file "frame-manager" :depends-on ("medium" "port" "package")))))) #+clisp (defmethod asdf::traverse :around ((op compile-op) (c (eql (find-system :clim-clx)))) ;; Just some random symbol I know is unexported in CLISP's CLX. (if (eq (nth-value 1 (find-symbol "SET-SELECTION-OWNER" :xlib)) :external) (call-next-method) (restart-case (error "Your CLX is not capable of running the McCLIM CLX backend") (load-clx-via-asdf () :report "Try replacing your CLX with a CLX loaded through ASDF, hopefully this will be Telent CLX." (ext:without-package-lock ("XLIB") (delete-package :xlib) (asdf:oos 'asdf:load-op :clx)) (call-next-method))))) (defsystem :clim-beagle :depends-on (clim) :components ((:module "Backends" :components ((:module "beagle" :serial t :components ((:file "package") (:file "cocoa-util") (:module "native" :components ((:file "lisp-bezier-path") (:file "lisp-window") (:file "lisp-window-delegate") (:file "lisp-view" :depends-on ("lisp-bezier-path")) (:file "lisp-view-additional" :depends-on ("lisp-view")) (:file "lisp-scroller") (:file "lisp-slider") (:file "lisp-button") (:file "lisp-image"))) (:module "windowing" :depends-on ("native") :components ((:file "port") (:file "frame-manager") (:file "mirror") (:file "graft"))) (:module "native-panes" :components ((:file "beagle-scroll-bar-pane") (:file "beagle-slider-pane") ;; Basic buttons - not collections of buttons (:file "beagle-fundamental-button-pane") ;; Button collections (radio + checkbox) ;; (:file "beagle-button-collection-pane") (:file "scroller-pane-fix"))) (:module "output" :depends-on ("windowing") :components ((:file "medium") (:file "fonts"))) (:module "input" :depends-on ("windowing") :components ((:file "events") (:file "keysymdef"))) (:module "glimpse" :components ((:file "glimpse") (:file "glimpse-support") (:file "glimpse-command-tables") (:file "glimpse-present-process" :depends-on ("glimpse" "glimpse-support")) (:file "glimpse-present-window" :depends-on ("glimpse" "glimpse-support")) (:file "glimpse-modeless-commands" :depends-on ("glimpse" "glimpse-support")) (:file "glimpse-process-commands" :depends-on ("glimpse" "glimpse-support")) (:file "glimpse-window-commands" :depends-on ("glimpse" "glimpse-support")))) (:module "profile" :components ((:file "profile"))) (:module "tests" :components ((:file "drawing-tests") (:file "graft-tests")))))))) ) (defsystem :clim-null :depends-on (:clim) :components ((:module "Backends/Null" :pathname #.(make-pathname :directory '(:relative "Backends" "Null")) :components ((:file "package") (:file "port" :depends-on ("package")) (:file "medium" :depends-on ("port" "package")) (:file "graft" :depends-on ("port" "package")) (:file "frame-manager" :depends-on ("medium" "port" "package")))))) (defsystem :clim-gtkairo :depends-on (:clim :cffi) :components ((:module "Backends/gtkairo" :pathname #.(make-pathname :directory '(:relative "Backends" "gtkairo")) :serial t ;asf wird's ja richten :components ((:file "clim-fix") (:file "package") (:file "gtk-ffi") (:file "cairo-ffi") (:file "ffi") (:file "graft") (:file "port") (:file "event") (:file "keys") (:file "medium") (:file "pango") (:file "cairo") (:file "gdk") (:file "pixmap") (:file "frame-manager") (:file "gadgets"))))) (defsystem :clim-graphic-forms :depends-on (:clim :graphic-forms-uitoolkit) :components ((:module "Backends/Graphic-Forms" :pathname #.(make-pathname :directory '(:relative "Backends" "Graphic-Forms")) :components ((:file "package") (:file "utils" :depends-on ("package")) (:file "graft" :depends-on ("package")) (:file "port" :depends-on ("utils" "graft")) (:file "medium" :depends-on ("port")) (:file "pixmap" :depends-on ("medium")) (:file "frame-manager" :depends-on ("medium")) (:file "gadgets" :depends-on ("port")))))) ;;; TODO/asf: I don't have the required libs to get :clim-opengl to load. tough. (clim-defsystem (:clim-opengl :depends-on (:clim)) "Backends/OpenGL/opengl-x-frame-manager" "Backends/OpenGL/opengl-frame-manager" "Backends/OpenGL/opengl-x-port-before" "Backends/OpenGL/opengl-port" "Backends/OpenGL/opengl-x-port-after" "Backends/OpenGL/opengl-medium" "Backends/OpenGL/opengl-x-graft") ;;; A system that loads the appropriate backend for the current ;;; platform. (defsystem :clim-looks :depends-on (:clim :clim-postscript ;; If we're on an implementation that ships CLX, use ;; it. Same if the user has loaded CLX already. #+(and (or sbcl scl openmcl ecl clx allegro) (not (or clim-gtkairo clim-graphic-forms clim-beagle))) :clim-clx #+clim-graphic-forms :clim-graphic-forms #+clim-gl :clim-opengl ;; OpenMCL and MCL support the beagle backend (native ;; OS X look&feel on OS X). #+clim-beagle :clim-beagle #+clim-gtkairo :clim-gtkairo ;; null backend :clim-null ) :components (#-(or clim-gtkairo clim-graphic-forms clim-beagle) (:file "Looks/pixie" :pathname #.(make-pathname :directory '(:relative "Looks") :name "pixie" :type "lisp")))) ;;; The actual McCLIM system that people should to use in their ASDF ;;; package dependency lists. (defsystem :mcclim :version "0.9.7-dev" :depends-on (:clim-looks)) (defmethod perform :after ((op load-op) (c (eql (find-system :clim)))) (pushnew :clim *features*) (pushnew :mcclim *features*)) (defmethod perform :after ((op load-op) (c (eql (find-system :mcclim)))) (pushnew :clim *features*) (pushnew :mcclim *features*)) ;; XXX This is very ugly, but ESA and Drei need to know whether they ;; are being compiled as part of McCLIM, or in another CLIM ;; implementation. (defmethod perform :around (op c) (if (and (or (eql (component-system c) (find-system :esa-mcclim)) (eql (component-system c) (find-system :drei-mcclim))) (not (find :building-mcclim *features*))) (unwind-protect (progn (push :building-mcclim *features*) (call-next-method)) (setf *features* (delete :building-mcclim *features*))) (call-next-method))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/graph-formatting.lisp0000644000175000017500000011367711345155771021171 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-INTERNALS; -*- ;;; --------------------------------------------------------------------------- ;;; Title: Graph Formatting ;;; Created: 2002-08-13 ;;; License: LGPL (See file COPYING for details). ;;; $Id: graph-formatting.lisp,v 1.23 2008-11-09 19:58:26 ahefner Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann ;;; (c) copyright 2005 by Robert P. Goldman ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) ;;;; Notes ;; - Now what exactly are layout-graph-nodes and layout-graph-edges ;; supposed to do? If LAYOUT-GRAPH-NODES is only responsible for ;; laying out the node output records, why does it get the ;; arc-drawer? If it should also draw the edges why then is there ;; the other function? --GB 2002-08-13 ;; - There is this hash table initarg to graph-output-records? Should ;; FORMAT-GRAPH-FROM-ROOTS pass a suitable hash table for the given ;; 'duplicate-test', if so why it is passed down and why is it not ;; restricted to the set of hash test functions? --GB 2002-08-13 ;; - What is the purpose of (SETF GRAPH-NODE-CHILDREN) and ;; (SETF GRAPH-NODE-PARENTS)? --GB 2002-08-14 ;; - FORMAT-GRAPH-FROM-ROOTS passes the various options on to the ;; instantiation of the graph-output-record class, so that the ;; individual classes can choose appropriate defaults. --GB 2002-08-14 ;; - In the same spirit, a non given ARC-DRAWER option is passed as it ;; is, that is being NIL, to LAYOUT-GRAPH-EDGES so that the concrete ;; graph-output-record can choose a default. --GB 2002-08-14 ;;;; Declarations ;; format-graph-from-roots (defgeneric graph-root-nodes (graph-output-record)) (defgeneric (setf graph-root-nodes) (new-value graph-output-record)) (defgeneric generate-graph-nodes (graph-output-record stream root-objects object-printer inferior-producer &key duplicate-key duplicate-test)) (defgeneric layout-graph-nodes (graph-output-record stream arc-drawer arc-drawing-options)) (defgeneric layout-graph-edges (graph-output-record stream arc-drawer arc-drawing-options)) ;;; NOTE: Which calls which? --GB 2002-08-13 (defgeneric graph-node-parents (graph-node-record)) (defgeneric (setf graph-node-parents) (new-value graph-node-record)) (defgeneric graph-node-children (graph-node-record)) (defgeneric (setf graph-node-children) (new-value graph-node-record)) (defgeneric graph-node-object (graph-node-record)) ;;;; Machinery for graph types (defconstant +built-in-graph-types+ '(:tree :directed-graph :digraph :directed-acyclic-graph :dag) "List of graph types builtin by CLIM.") (defvar *graph-types-hash* (make-hash-table :test #'eq) "A hash table which maps from symbols that name graph-types to class names; Filled by CLIM:DEFINE-GRAPH-TYPE") (defun register-graph-type (graph-type class) "Registers a new graph-type." (setf (gethash graph-type *graph-types-hash*) class)) (defun find-graph-type (graph-type) "Find the a graph type; when it does not exist barks at the user." (or (gethash graph-type *graph-types-hash*) (progn (cerror "Specify another graph type to use instead." "There is no such graph type defined: ~S.~%The defined ones are: ~{~S~^, ~@_~}." graph-type (loop for key being each hash-key of *graph-types-hash* collect key)) ;; accept anyone? (princ "Graph Type? ") (find-graph-type (read))))) (defmacro define-graph-type (graph-type class) (check-type graph-type symbol) (check-type class symbol) (unless (eq *package* (find-package :climi)) (when (member graph-type +built-in-graph-types+) (cerror "Do it anyway" "You are about to redefine the builtin graph type ~S." graph-type))) ;; Note: I would really like this to obey to package locks and stuff. `(progn (register-graph-type ',graph-type ',class) ',graph-type)) (define-graph-type :tree tree-graph-output-record) (define-graph-type :directed-acyclic-graph dag-graph-output-record) (define-graph-type :dag dag-graph-output-record) (define-graph-type :directed-graph digraph-graph-output-record) (define-graph-type :digraph digraph-graph-output-record) ;;;; Entry (defun format-graph-from-root (root-object &rest other-args) (apply #'format-graph-from-roots (list root-object) other-args)) (defun format-graph-from-roots (root-objects object-printer inferior-producer &rest rest-args &key stream orientation cutoff-depth merge-duplicates duplicate-key duplicate-test generation-separation within-generation-separation center-nodes (arc-drawer #'clim-internals::standard-arc-drawer) arc-drawing-options graph-type (move-cursor t) &allow-other-keys) (declare (ignore orientation generation-separation within-generation-separation center-nodes)) ;; don't destructively modify the &rest arg (let ((graph-options (copy-list rest-args))) ;; Munge some arguments (check-type cutoff-depth (or null integer)) (check-type root-objects sequence) (setf stream (or stream *standard-output*) graph-type (or graph-type (if merge-duplicates :digraph :tree)) duplicate-key (or duplicate-key #'identity) duplicate-test (or duplicate-test #'eql) ) ;; I'm not sure what to do here. Saying you want a tree, but want ;; duplicates merged seems wrong. OTOH, if you go out of your way ;; to do it, at your own risk, is it our place to say "no"? ;; [2005/08/11:rpg] ;;; (when (and (eq graph-type :tree) merge-duplicates) ;;; (cerror "Substitute NIL for merge-duplicates" ;;; "Merge duplicates specified to be true when using :tree layout.") ;;; (setf merge-duplicates nil)) ;; clean the options (remf graph-options :stream) (remf graph-options :duplicate-key) (remf graph-options :duplicate-test) (remf graph-options :arc-drawer) (remf graph-options :arc-drawing-options) (remf graph-options :graph-type) (remf graph-options :move-cursor) (multiple-value-bind (cursor-old-x cursor-old-y) (stream-cursor-position stream) (let ((graph-output-record (labels ((cont (stream graph-output-record) (with-output-recording-options (stream :draw nil :record t) (generate-graph-nodes graph-output-record stream root-objects object-printer inferior-producer :duplicate-key duplicate-key :duplicate-test duplicate-test) (layout-graph-nodes graph-output-record stream arc-drawer arc-drawing-options) (layout-graph-edges graph-output-record stream arc-drawer arc-drawing-options)) )) (apply #'invoke-with-new-output-record stream #'cont (find-graph-type graph-type) nil ;; moved to local variable... [2005/07/25:rpg] ;; :hash-table (make-hash-table :test duplicate-test) graph-options )))) (setf (output-record-position graph-output-record) (values cursor-old-x cursor-old-y)) (when (and (stream-drawing-p stream) (output-record-ancestor-p (stream-output-history stream) graph-output-record)) (with-output-recording-options (stream :draw t :record nil) (replay graph-output-record stream))) (when move-cursor (setf (stream-cursor-position stream) (values (bounding-rectangle-max-x graph-output-record) (bounding-rectangle-max-y graph-output-record)))) (fit-pane-to-output stream) graph-output-record)))) ;;;; Graph Output Records (defclass standard-graph-output-record (graph-output-record standard-sequence-output-record) ((orientation :initarg :orientation :initform :horizontal) (center-nodes :initarg :center-nodes :initform nil) (cutoff-depth :initarg :cutoff-depth :initform nil) (merge-duplicates :initarg :merge-duplicates :initform nil) (generation-separation :initarg :generation-separation :initform '(4 :character)) (within-generation-separation :initarg :within-generation-separation :initform '(1/2 :line)) ;; removed HASH-TABLE slot and stuffed it into ;; GENERATE-GRAPH-NODES method definition [2005/07/25:rpg] (root-nodes :accessor graph-root-nodes) )) (defclass tree-graph-output-record (standard-graph-output-record) ()) ;;;(defmethod initialize-instance :after ((obj tree-graph-output-record) &key merge-duplicates) ;;; (when merge-duplicates ;;; (warn "Cannot use a TREE layout for graphs while merging duplicates."))) (defclass dag-graph-output-record (standard-graph-output-record) ( )) (defclass digraph-graph-output-record (standard-graph-output-record) ()) ;;;; Nodes (defclass standard-graph-node-output-record (graph-node-output-record standard-sequence-output-record) ((graph-parents :initarg :graph-parents :initform nil :accessor graph-node-parents) (graph-children :initarg :graph-children :initform nil :accessor graph-node-children) (edges-from :initform (make-hash-table)) (edges-to :initform (make-hash-table)) (object :initarg :object :reader graph-node-object) ;; internal slots for the graph layout algorithm (minor-size :initform nil :accessor graph-node-minor-size :documentation "Space requirement for this node and its children. Also used as a mark.") )) ;;;; ;;; Modified to make this obey the spec better by using a hash-table ;;; for detecting previous nodes only when the duplicate-test argument ;;; permits it. [2005/08/10:rpg] (defmethod generate-graph-nodes ((graph-output-record standard-graph-output-record) stream root-objects object-printer inferior-producer &key duplicate-key duplicate-test) (with-slots (cutoff-depth merge-duplicates) graph-output-record (let* ((hash-table (when (and merge-duplicates (member duplicate-test (list #'eq #'eql #'equal #'equalp))) (make-hash-table :test duplicate-test))) node-list (hashed hash-table)) (labels ((previous-node (obj) ;; is there a previous node for obj? if so, return it. (when merge-duplicates (if hashed (locally (declare (type hash-table hash-table)) (gethash obj hash-table)) (cdr (assoc obj node-list :test duplicate-test))))) ((setf previous-node) (val obj) (if hashed (locally (declare (type hash-table hash-table)) (setf (gethash obj hash-table) val)) (setf node-list (push (cons obj val) node-list)))) (traverse-objects (node objects depth) (unless (and cutoff-depth (>= depth cutoff-depth)) (remove nil (map 'list (lambda (child) (let* ((key (funcall duplicate-key child)) (child-node (previous-node key))) (cond (child-node (when node (push node (graph-node-parents child-node))) child-node) (t (let ((child-node (with-output-to-output-record (stream 'standard-graph-node-output-record new-node :object child) (funcall object-printer child stream)))) (when merge-duplicates (setf (previous-node key) child-node) ;; (setf (gethash key hash-table) child-node) ) (when node (push node (graph-node-parents child-node))) (setf (graph-node-children child-node) (traverse-objects child-node (funcall inferior-producer child) (+ depth 1))) child-node))))) objects))))) ;; (setf (graph-root-nodes graph-output-record) (traverse-objects nil root-objects 0)) (values))))) (defun traverse-graph-nodes (graph continuation) ;; continuation: node x children x cont -> some value (let ((hash (make-hash-table :test #'eq))) (labels ((walk (node) (unless (gethash node hash) (setf (gethash node hash) t) (funcall continuation node (graph-node-children node) #'walk)))) (funcall continuation graph (graph-root-nodes graph) #'walk)))) (defmethod layout-graph-nodes ((graph-output-record tree-graph-output-record) stream arc-drawer arc-drawing-options) ;; work in progress! --GB 2002-08-14 (declare (ignore arc-drawer arc-drawing-options)) (with-slots (orientation center-nodes generation-separation within-generation-separation root-nodes) graph-output-record (check-type orientation (member :horizontal :vertical)) ;xxx move to init.-inst. ;; here major dimension is the dimension in which we grow the ;; tree. (let ((within-generation-separation (parse-space stream within-generation-separation (case orientation (:horizontal :vertical) (:vertical :horizontal)))) (generation-separation (parse-space stream generation-separation orientation))) ;; generation sizes is an adjustable array that tracks the major ;; dimension of each of the generations [2005/07/18:rpg] (let ((generation-sizes (make-array 10 :adjustable t :initial-element 0))) (labels ((node-major-dimension (node) (if (eq orientation :vertical) (bounding-rectangle-height node) (bounding-rectangle-width node))) (node-minor-dimension (node) (if (eq orientation :vertical) (bounding-rectangle-width node) (bounding-rectangle-height node))) ;; WALK returns a node minor dimension for the node, ;; AFAICT, allowing space for that node's children ;; along the minor dimension. [2005/07/18:rpg] (walk (node depth) (unless (graph-node-minor-size node) (when (>= depth (length generation-sizes)) (setf generation-sizes (adjust-array generation-sizes (ceiling (* depth 1.2)) :initial-element 0))) (setf (aref generation-sizes depth) (max (aref generation-sizes depth) (node-major-dimension node))) (setf (graph-node-minor-size node) 0) (max (node-minor-dimension node) (setf (graph-node-minor-size node) (let ((sum 0) (n 0)) (map nil (lambda (child) (let ((x (walk child (+ depth 1)))) (when x (incf sum x) (incf n)))) (graph-node-children node)) (+ sum (* (max 0 (- n 1)) within-generation-separation)))))))) (map nil #'(lambda (x) (walk x 0)) root-nodes) (let ((hash (make-hash-table :test #'eq))) (labels ((foo (node majors u0 v0) (cond ((gethash node hash) v0) (t (setf (gethash node hash) t) (let ((d (- (node-minor-dimension node) (graph-node-minor-size node)))) (let ((v (+ v0 (/ (min 0 d) -2)))) (setf (output-record-position node) (if (eq orientation :vertical) (transform-position (medium-transformation stream) v u0) (transform-position (medium-transformation stream) u0 v))) (add-output-record node graph-output-record)) ;; (let ((u (+ u0 (car majors))) (v (+ v0 (max 0 (/ d 2)))) (firstp t)) (map nil (lambda (q) (unless (gethash q hash) (if firstp (setf firstp nil) (incf v within-generation-separation)) (setf v (foo q (cdr majors) u v)))) (graph-node-children node))) ;; (+ v0 (max (node-minor-dimension node) (graph-node-minor-size node)))))))) ;; (let ((majors (mapcar (lambda (x) (+ x generation-separation)) (coerce generation-sizes 'list)))) (let ((u (+ 0 (car majors))) (v 0)) (maplist (lambda (rest) (setf v (foo (car rest) majors u v)) (unless (null rest) (incf v within-generation-separation))) (graph-root-nodes graph-output-record))))))))))) ;;;; Edges (defclass standard-edge-output-record (standard-sequence-output-record) ((stream) (arc-drawer) (arc-drawing-options) (from-node :initarg :from-node) (to-node :initarg :to-node))) (defmethod layout-graph-nodes ((graph-output-record dag-graph-output-record) stream arc-drawer arc-drawing-options) "This is a first shot at a DAG layout. First does a TOPO sort that associates each node with a depth, then lays out by depth. Tries to reuse a maximum of the tree graph layout code. PRECONDITION: This code assumes that we have generated only nodes up to the cutoff-depth. GENERATE-GRAPH-NODES seems to obey this precondition." (declare (ignore arc-drawer arc-drawing-options)) (with-slots (orientation center-nodes generation-separation within-generation-separation root-nodes merge-duplicates) graph-output-record ;; this code is snarly enough, handling merge-duplicates. If ;; you're not merging duplicates, you're out of luck, at least for ;; now... [2005/07/18:rpg] (unless merge-duplicates (cerror "Set to T and continue?" "DAG graph-layout type only supports merge-duplicates to be T") (setf merge-duplicates t)) (check-type orientation (member :horizontal :vertical)) ;xxx move to init.-inst. ;; here major dimension is the dimension in which we grow the ;; tree. (let ((within-generation-separation (parse-space stream within-generation-separation (case orientation (:horizontal :vertical) (:vertical :horizontal)))) (generation-separation (parse-space stream generation-separation orientation))) ;; generation sizes is an adjustable array that tracks the major ;; dimension of each of the generations [2005/07/18:rpg] (let ((generation-sizes (make-array 10 :adjustable t :initial-element 0)) (visited (make-hash-table :test #'eq)) (parent-hash (make-hash-table :test #'eq))) (labels ((node-major-dimension (node) (if (eq orientation :vertical) (bounding-rectangle-height node) (bounding-rectangle-width node))) (node-minor-dimension (node) (if (eq orientation :vertical) (bounding-rectangle-width node) (bounding-rectangle-height node))) ;; WALK returns a node minor dimension for the node, ;; AFAICT, allowing space for that node's children ;; along the minor dimension. [2005/07/18:rpg] (walk (node depth &optional parent) (unless (gethash node visited) (setf (gethash node visited) depth) (when parent (setf (gethash node parent-hash) parent)) (unless (graph-node-minor-size node) (when (>= depth (length generation-sizes)) (setf generation-sizes (adjust-array generation-sizes (ceiling (* depth 1.2)) :initial-element 0))) (setf (aref generation-sizes depth) (max (aref generation-sizes depth) (node-major-dimension node))) (setf (graph-node-minor-size node) 0) (max (node-minor-dimension node) (setf (graph-node-minor-size node) (let ((sum 0) (n 0)) (map nil (lambda (child) (let ((x (walk child (+ depth 1) node))) (when x (incf sum x) (incf n)))) (graph-node-children node)) (+ sum (* (max 0 (- n 1)) within-generation-separation))))))))) (map nil #'(lambda (x) (walk x 0)) root-nodes) (let ((hash (make-hash-table :test #'eq))) (labels ((foo (node majors u0 v0) (cond ((gethash node hash) v0) (t (setf (gethash node hash) t) (let ((d (- (node-minor-dimension node) (graph-node-minor-size node)))) (let ((v (+ v0 (/ (min 0 d) -2)))) (setf (output-record-position node) (if (eq orientation :vertical) (transform-position (medium-transformation stream) v u0) (transform-position (medium-transformation stream) u0 v))) (add-output-record node graph-output-record)) ;; (let ((u (+ u0 (car majors))) (v (+ v0 (max 0 (/ d 2)))) (firstp t)) (map nil (lambda (q) (unless (gethash q hash) (if firstp (setf firstp nil) (incf v within-generation-separation)) (setf v (foo q (cdr majors) u v)))) ;; when computing the sizes, to ;; make the tree-style layout ;; work, we have to have each ;; node have a unique ;; parent. [2005/07/18:rpg] (remove-if-not #'(lambda (x) (eq (gethash x parent-hash) node)) (graph-node-children node)))) ;; (+ v0 (max (node-minor-dimension node) (graph-node-minor-size node)))))))) ;; (let ((majors (mapcar (lambda (x) (+ x generation-separation)) (coerce generation-sizes 'list)))) (let ((u (+ 0 (car majors))) (v 0)) (maplist (lambda (rest) (setf v (foo (car rest) majors u v)) (unless (null rest) (incf v within-generation-separation))) (graph-root-nodes graph-output-record))))))))))) #+ignore (defmethod layout-graph-edges ((graph-output-record standard-graph-output-record) stream arc-drawer arc-drawing-options) (with-slots (root-nodes orientation) graph-output-record (let ((hash (make-hash-table))) (labels ((walk (node) (unless (gethash node hash) (setf (gethash node hash) t) (dolist (k (graph-node-children node)) (with-bounding-rectangle* (x1 y1 x2 y2) node (with-bounding-rectangle* (u1 v1 u2 v2) k (ecase orientation ((:horizontal) (multiple-value-bind (from to) (if (< x1 u1) (values x2 u1) (values x1 u2)) (apply arc-drawer stream node k from (/ (+ y1 y2) 2) to (/ (+ v1 v2) 2) arc-drawing-options))) ((:vertical) (multiple-value-bind (from to) (if (< y1 v1) (values y2 v1) (values y1 v2)) (apply arc-drawer stream node k (/ (+ x1 x2) 2) from (/ (+ u1 u2) 2) to arc-drawing-options)) )))) (walk k))))) (map nil #'walk root-nodes))))) (defun layout-edges (graph node stream arc-drawer arc-drawing-options) (dolist (k (graph-node-children node)) (layout-edge graph node k stream arc-drawer arc-drawing-options))) (defun ensure-edge-record (graph major-node minor-node) (let ((edges-from (slot-value major-node 'edges-from)) (edges-to (slot-value minor-node 'edges-to))) (assert (eq (gethash minor-node edges-from) (gethash major-node edges-to))) (or (gethash minor-node edges-from) (let ((record (make-instance 'standard-edge-output-record :from-node major-node :to-node minor-node))) (setf (gethash minor-node edges-from) record (gethash major-node edges-to) record) (add-output-record record graph) record)))) (defun layout-edge-1 (graph major-node minor-node) (let ((edge-record (ensure-edge-record graph major-node minor-node))) (with-slots (stream arc-drawer arc-drawing-options) edge-record (with-bounding-rectangle* (x1 y1 x2 y2) major-node (with-bounding-rectangle* (u1 v1 u2 v2) minor-node (clear-output-record edge-record) ;;; FIXME: repaint? (letf (((stream-current-output-record stream) edge-record)) (ecase (slot-value graph 'orientation) ((:horizontal) (multiple-value-bind (from to) (if (< x1 u1) (values x2 u1) (values x1 u2)) (apply arc-drawer stream major-node minor-node from (/ (+ y1 y2) 2) to (/ (+ v1 v2) 2) arc-drawing-options))) ((:vertical) (multiple-value-bind (from to) (if (< y1 v1) (values y2 v1) (values y1 v2)) (apply arc-drawer stream major-node minor-node (/ (+ x1 x2) 2) from (/ (+ u1 u2) 2) to arc-drawing-options)))))))))) (defun layout-edge (graph major-node minor-node stream arc-drawer arc-drawing-options) (let ((edge-record (ensure-edge-record graph major-node minor-node))) (setf (slot-value edge-record 'stream) stream (slot-value edge-record 'arc-drawer) arc-drawer (slot-value edge-record 'arc-drawing-options) arc-drawing-options) (layout-edge-1 graph major-node minor-node))) (defmethod layout-graph-edges ((graph standard-graph-output-record) stream arc-drawer arc-drawing-options) (with-slots (orientation) graph ;; We tranformed the position of the nodes when we inserted them into ;; output history, so the bounding rectangles queried below will be ;; transformed. Therefore, disable the transformation now, otherwise ;; the transformation is effectively applied twice to the edges. (with-identity-transformation (stream) (traverse-graph-nodes graph (lambda (node children continuation) (unless (eq node graph) (layout-edges graph node stream arc-drawer arc-drawing-options)) (map nil continuation children)))))) (defmethod layout-graph-edges :around ((graph-output-record tree-graph-output-record) stream arc-drawer arc-drawing-options) (setf arc-drawer (or arc-drawer #'standard-arc-drawer)) (call-next-method graph-output-record stream arc-drawer arc-drawing-options)) (defmethod layout-graph-edges :around ((graph-output-record digraph-graph-output-record) stream arc-drawer arc-drawing-options) (setf arc-drawer (or arc-drawer #'arrow-arc-drawer)) (call-next-method graph-output-record stream arc-drawer arc-drawing-options)) (defmethod layout-graph-edges :around ((graph-output-record dag-graph-output-record) stream arc-drawer arc-drawing-options) (setf arc-drawer (or arc-drawer #'standard-arc-drawer)) (call-next-method graph-output-record stream arc-drawer arc-drawing-options)) (defun standard-arc-drawer (stream from-node to-node x1 y1 x2 y2 &rest drawing-options &key &allow-other-keys) (declare (ignore from-node to-node)) (apply #'draw-line* stream x1 y1 x2 y2 drawing-options)) (defun arrow-arc-drawer (stream from-node to-node x1 y1 x2 y2 &rest drawing-options &key &allow-other-keys) (declare (ignore from-node to-node)) (apply #'draw-arrow* stream x1 y1 x2 y2 drawing-options)) #|| ;; Experimental version for rectangular graphs (defmethod layout-graph-edges ((graph-output-record tree-graph-output-record) stream arc-drawer arc-drawing-options) (with-slots (root-nodes orientation) graph-output-record (let ((hash (make-hash-table))) (labels ((walk (node &aux (vlast nil) uu) (unless (gethash node hash) (setf (gethash node hash) t) (with-bounding-rectangle* (x1 y1 x2 y2) node (dolist (k (graph-node-children node)) (with-bounding-rectangle* (u1 v1 u2 v2) k (case orientation (:horizontal (draw-line* stream (/ (+ x2 u1) 2) (/ (+ v1 v2) 2) (- u1 2) (/ (+ v1 v2) 2)) (setf uu u1) (setf vlast (max (or vlast 0) (/ (+ v1 v2) 2)))) (:vertical (draw-line* stream (/ (+ x1 x2) 2) y2 (/ (+ u1 u2) 2) v1)))) (walk k)) (when vlast (draw-line* stream (+ x2 2) (/ (+ y1 y2) 2) (/ (+ x2 uu) 2) (/ (+ y1 y2) 2)) (draw-line* stream (/ (+ x2 uu) 2) (/ (+ y1 y2) 2) (/ (+ x2 uu) 2) vlast)))))) (map nil #'walk root-nodes))))) ||# #|| ;;; Testing --GB 2002-08-14 (define-application-frame graph-test () () (:panes (interactor :interactor :width 800 :height 400 :max-width +fill+ :max-height +fill+)) (:layouts (default interactor))) (define-graph-test-command foo () (with-text-style (*query-io* (make-text-style :sans-serif nil 12)) (let ((*print-case* :downcase)) (format-graph-from-roots (list `(define-graph-test-command test () (let ((stream *query-io*) (orientation :horizontal)) (fresh-line stream) (macrolet ((make-node (&key name children) `(list* ,name ,children))) (flet ((node-name (node) (car node)) (node-children (node) (cdr node))) (let* ((2a (make-node :name "2A")) (2b (make-node :name "2B")) (2c (make-node :name "2C")) (1a (make-node :name "1A" :children (list 2a 2b))) (1b (make-node :name "1B" :children (list 2b 2c))) (root (make-node :name "0" :children (list 1a 1b)))) (format-graph-from-roots (list root) #'(lambda (node s) (write-string (node-name node) s)) #'node-children :orientation orientation :stream stream))))))) #'(lambda (x s) (with-output-as-presentation (s x 'command) (let ((*print-level* 1)) (princ (if (consp x) (car x) x) s)))) #'(lambda (x) (and (consp x) (cdr x))) :stream *query-io* :orientation :horizontal)))) (defun external-symbol-p (sym) ;; *cough* *cough* (< (count #\: (let ((*package* (find-package :keyword))) (prin1-to-string sym))) 2)) (define-graph-test-command bar () (with-text-style (*query-io* (make-text-style :sans-serif nil 10)) (let ((*print-case* :downcase)) (format-graph-from-roots (list (clim-mop:find-class 'climi::basic-output-record)) #'(lambda (x s) (progn ;;surrounding-output-with-border (s :shape :oval) (with-text-style (s (make-text-style nil (if (external-symbol-p (class-name x)) :bold nil) nil)) (prin1 (class-name x) s)))) #'(lambda (x) (clim-mop:class-direct-subclasses x)) :generation-separation '(4 :line) :within-generation-separation '(2 :character) :stream *query-io* :orientation :vertical)))) (define-graph-test-command bar () (with-text-style (*query-io* (make-text-style :sans-serif nil 10)) (format-graph-from-roots (list '(:foo (:bar) (:baaaaaaaaaaaaaaz (:a) (:b)) (:q (:x) (:y))) ) #'(lambda (x s) (prin1 (first x) s)) #'(lambda (x) (cdr x)) :generation-separation '(4 :line) :within-generation-separation '(2 :character) :stream *query-io* :orientation :vertical))) (define-graph-test-command baz () (with-text-style (*query-io* (make-text-style :sans-serif nil 10)) (let ((*print-case* :downcase)) (format-graph-from-roots (list (clim-mop:find-class 'standard-graph-output-record) ;;(clim-mop:find-class 'climi::basic-output-record) ;;(clim-mop:find-class 'climi::graph-output-record) ) #'(lambda (x s) (with-text-style (s (make-text-style nil (if (external-symbol-p (class-name x)) :bold nil) nil)) (prin1 (class-name x) s))) #'(lambda (x) (reverse(clim-mop:class-direct-superclasses x))) ;; :duplicate-key #'(lambda (x) 't) :merge-duplicates t :graph-type :tree :arc-drawer #'arrow-arc-drawer :stream *query-io* :orientation :vertical)))) (define-graph-test-command test () (let ((stream *query-io*) (orientation :vertical)) (fresh-line stream) (macrolet ((make-node (&key name children) `(list* ,name ,children))) (flet ((node-name (node) (car node)) (node-children (node) (cdr node))) (let* ((2a (make-node :name "2A")) (2b (make-node :name "2B")) (2c (make-node :name "2C")) (1a (make-node :name "1A" :children (list 2a 2b))) (1b (make-node :name "1B" :children (list 2b 2c))) (root (make-node :name "0" :children (list 1a 1b)))) (format-graph-from-roots (list root) #'(lambda (node s) (write-string (node-name node) s)) #'node-children :arc-drawer #'arrow-arc-drawer :arc-drawing-options (list :ink +red+ :line-thickness 1) :orientation orientation :stream stream)))))) (defun make-circ-list (list) (nconc list list)) (define-graph-test-command test2 () (let ((stream *query-io*) (orientation :vertical)) (fresh-line stream) (format-graph-from-roots (list '(defun dcons (x) (cons x x)) (make-circ-list (list 1 '(2 . 4) 3))) #'(lambda (node s) (if (consp node) (progn (draw-circle* s 5 5 5 :filled nil)) (princ node s))) #'(lambda (x) (if (consp x) (list (car x) (cdr x)))) :cutoff-depth nil :graph-type :tree :merge-duplicates t :arc-drawer #'arrow-arc-drawer :arc-drawing-options (list :ink +red+ :line-thickness 1) :orientation orientation :stream stream))) ||#cl-mcclim-0.9.6.dfsg.cvs20100315.orig/text-editor-gadget.lisp0000644000175000017500000004300111345155772021401 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2000 by ;;; Arthur Lemmens (lemmens@simplex.nl), ;;; Iban Hatchondo (hatchond@emi.u-bordeaux.fr) ;;; and Julien Boninfante (boninfan@emi.u-bordeaux.fr) ;;; (c) copyright 2001 by ;;; Lionel Salabartan (salabart@emi.u-bordeaux.fr) ;;; (c) copyright 2001 by Michael McDonald (mikemac@mikemac.com) ;;; (c) copyright 2001 by Gilbert Baumann ;;; (c) copyright 2006 by Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; This file contains the concrete implementation of the text-field ;;; and text-editor gadgets. It is loaded rather late, because it ;;; requires Drei. Half of the complexity here is about working around ;;; annoying Goatee quirks, generalising it to three editor substrates ;;; is nontrivial. (in-package :clim-internals) ;;; The text editor gadget(s) is implemented as a class implementing ;;; the text editor gadget protocol, but containing an editor ;;; substrate object that takes care of the actual editing logic, ;;; redisplay, etc. The substrates need to be gadgets themselves and ;;; are defined here. (defparameter *default-text-field-text-style* (make-text-style :fix :roman :normal)) (defclass editor-substrate-mixin (value-gadget) ((activation-gestures :reader activation-gestures :initarg :activation-gestures) (user :reader user-gadget :initarg :user-gadget :documentation "The editor gadget using this editor substrate." :initform (error "Editor substrates must have a user."))) (:documentation "A mixin class for text editor gadget substrates.") (:default-initargs :activation-gestures '())) (defmethod gadget-id ((gadget editor-substrate-mixin)) (gadget-id (user-gadget gadget))) (defmethod (setf gadget-id) (value (gadget editor-substrate-mixin)) (setf (gadget-id (user-gadget gadget)) value)) (defmethod gadget-client ((gadget editor-substrate-mixin)) (gadget-client (user-gadget gadget))) (defmethod (setf gadget-client) (value (gadget editor-substrate-mixin)) (setf (gadget-client (user-gadget gadget)) value)) (defmethod gadget-armed-callback ((gadget editor-substrate-mixin)) (gadget-armed-callback (user-gadget gadget))) (defmethod gadget-disarmed-callback ((gadget editor-substrate-mixin)) (gadget-disarmed-callback (user-gadget gadget))) (defclass text-field-substrate-mixin (editor-substrate-mixin) () (:documentation "A mixin class for editor substrates used for text field gadgets.")) (defclass text-editor-substrate-mixin (editor-substrate-mixin) ((ncolumns :reader text-editor-ncolumns :initarg :ncolumns :initform nil :type (or null integer)) (nlines :reader text-editor-nlines :initarg :nlines :initform nil :type (or null integer))) (:documentation "A mixin class for editor substrates used for text editor gadgets.")) ;;; Now, define the Drei substrate. (defclass drei-editor-substrate (drei:drei-gadget-pane editor-substrate-mixin) () (:metaclass esa-utils:modual-class) (:documentation "A class for Drei-based editor substrates.")) (defmethod (setf gadget-value) :after (value (gadget drei-editor-substrate) &key invoke-callback) (declare (ignore invoke-callback)) ;; Hm! I wonder if this can cause trouble. I think not. (drei:display-drei gadget)) (defclass drei-text-field-substrate (text-field-substrate-mixin drei-editor-substrate) () (:metaclass esa-utils:modual-class) (:documentation "The class for Drei-based text field substrates.")) (defmethod drei:handle-gesture ((drei drei-text-field-substrate) gesture) (if (with-activation-gestures ((activation-gestures drei)) (activation-gesture-p gesture)) (activate-callback drei (gadget-client drei) (gadget-id drei)) (call-next-method))) (defmethod compose-space ((pane drei-text-field-substrate) &key width height) (declare (ignore width height)) (with-sheet-medium (medium pane) (let ((as (text-style-ascent (medium-text-style medium) medium)) (ds (text-style-descent (medium-text-style medium) medium)) (w (text-size medium (gadget-value pane)))) (let ((width w) (height (+ as ds))) (make-space-requirement :height height :max-height height :min-height height :min-width width :width width))))) (defclass drei-text-editor-substrate (text-editor-substrate-mixin drei-editor-substrate) () (:metaclass esa-utils:modual-class) (:documentation "The class for Drei-based text editor substrates.")) (defmethod compose-space ((pane drei-text-editor-substrate) &key width height) (with-sheet-medium (medium pane) (let* ((text-style (medium-text-style medium)) (line-height (+ (text-style-height text-style medium) (stream-vertical-spacing pane))) (column-width (text-style-width text-style medium))) (with-accessors ((ncolumns text-editor-ncolumns) (nlines text-editor-nlines)) pane (apply #'space-requirement-combine* #'(lambda (req1 req2) (or req2 req1)) (call-next-method) (let ((width (if ncolumns (+ (* ncolumns column-width)) width)) (height (if nlines (+ (* nlines line-height)) height))) (list :width width :max-width width :min-width width :height height :max-height height :min-height height))))))) (defmethod allocate-space ((pane drei-text-editor-substrate) w h) (resize-sheet pane w h)) ;;; Now, define the Goatee substrate. (defclass goatee-editor-substrate (editor-substrate-mixin text-field clim-stream-pane) ((area :accessor area :initform nil :documentation "The Goatee area used for text editing.") ;; This hack is necessary because the Goatee editing area is not ;; created until the first redisplay... yuck. (value :documentation "The initial value for the Goatee area.")) (:default-initargs :text-style *default-text-field-text-style*)) (defmethod initialize-instance :after ((pane goatee-editor-substrate) &rest rest) (declare (ignore rest)) (setf (medium-text-style (sheet-medium pane)) (slot-value pane 'text-style))) ;; Is there really a benefit to waiting until the first painting to ;; create the goatee instance? Why not use INITIALIZE-INSTANCE? (defmethod handle-repaint :before ((pane goatee-editor-substrate) region) (declare (ignore region)) (unless (area pane) (multiple-value-bind (cx cy) (stream-cursor-position pane) (setf (cursor-visibility (stream-text-cursor pane)) nil) (setf (area pane) (make-instance 'goatee:simple-screen-area :area-stream pane :x-position cx :y-position cy :initial-contents (slot-value pane 'value)))) (stream-add-output-record pane (area pane)))) ;;; This implements click-to-focus-keyboard-and-pass-click-through ;;; behaviour. (defmethod handle-event :before ((gadget goatee-editor-substrate) (event pointer-button-press-event)) (let ((previous (stream-set-input-focus gadget))) (when (and previous (typep previous 'gadget)) (disarmed-callback previous (gadget-client previous) (gadget-id previous))) (armed-callback gadget (gadget-client gadget) (gadget-id gadget)))) (defmethod armed-callback :after ((gadget goatee-editor-substrate) client id) (declare (ignore client id)) (handle-repaint gadget +everywhere+) ;FIXME: trigger initialization (let ((cursor (cursor (area gadget)))) (letf (((cursor-state cursor) nil)) (setf (cursor-appearance cursor) :solid)))) (defmethod disarmed-callback :after ((gadget goatee-editor-substrate) client id) (declare (ignore client id)) (handle-repaint gadget +everywhere+) ;FIXME: trigger initialization (let ((cursor (cursor (area gadget)))) (letf (((cursor-state cursor) nil)) (setf (cursor-appearance cursor) :hollow)))) (defmethod handle-event ((gadget goatee-editor-substrate) (event key-press-event)) (let ((gesture (convert-to-gesture event)) (*activation-gestures* (activation-gestures gadget))) (when (activation-gesture-p gesture) (activate-callback gadget (gadget-client gadget) (gadget-id gadget)) (return-from handle-event t)) (goatee:execute-gesture-command gesture (area gadget) goatee::*simple-area-gesture-table*) (let ((new-value (goatee::buffer-string (goatee::buffer (area gadget))))) (unless (string= (gadget-value gadget) new-value) (setf (slot-value gadget 'value) new-value) (value-changed-callback gadget (gadget-client gadget) (gadget-id gadget) new-value))))) (defmethod (setf gadget-value) :after (new-value (gadget goatee-editor-substrate) &key invoke-callback) (declare (ignore invoke-callback)) (let* ((area (area gadget)) (buffer (goatee::buffer area)) (start (goatee::buffer-start buffer)) (end (goatee::buffer-end buffer))) (goatee::delete-region buffer start end) (goatee::insert buffer new-value :position start) (goatee::redisplay-area area))) #+nil (defmethod handle-repaint ((pane goatee-editor-substrate) region) (declare (ignore region)) (with-special-choices (pane) (with-sheet-medium (medium pane) (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* (sheet-region pane)) (display-gadget-background pane (gadget-current-color pane) 0 0 (- x2 x1) (- y2 y1)) (draw-text* pane (gadget-value pane) x1 (+ y1 (text-style-ascent (medium-text-style medium) medium)) :align-x :left :align-y :baseline))))) (defclass goatee-text-field-substrate (text-field-substrate-mixin goatee-editor-substrate) () (:documentation "The class for Goatee-based text field substrates.")) (defmethod compose-space ((pane goatee-text-field-substrate) &key width height) (declare (ignore width height)) (with-sheet-medium (medium pane) (let ((as (text-style-ascent (medium-text-style medium) medium)) (ds (text-style-descent (medium-text-style medium) medium)) (w (text-size medium (gadget-value pane)))) (let ((width w) (height (+ as ds))) (make-space-requirement :width width :height height :max-width width :max-height height :min-width width :min-height height))))) (defclass goatee-text-editor-substrate (text-editor-substrate-mixin goatee-editor-substrate) () (:documentation "The class for Goatee-based text field substrates.")) (defmethod compose-space ((pane goatee-text-editor-substrate) &key width height) (with-sheet-medium (medium pane) (let* ((text-style (medium-text-style medium)) (line-height (+ (text-style-height text-style medium) (stream-vertical-spacing pane))) (column-width (text-style-width text-style medium))) (with-accessors ((ncolumns text-editor-ncolumns) (nlines text-editor-nlines)) pane (apply #'space-requirement-combine* #'(lambda (req1 req2) (or req2 req1)) (call-next-method) (let ((width (if ncolumns (+ (* ncolumns column-width)) width)) (height (if nlines (+ (* nlines line-height)) height))) (list :width width :max-width width :min-width width :height height :max-height height :min-height height))))))) (defmethod allocate-space ((pane goatee-text-editor-substrate) w h) (resize-sheet pane w h)) (defun make-text-field-substrate (user &rest args) "Create an appropriate text field gadget editing substrate object." (let* ((substrate (apply #'make-pane (if *use-goatee* 'goatee-text-field-substrate 'drei-text-field-substrate) :user-gadget user args)) (sheet substrate)) (values substrate sheet))) (defun make-text-editor-substrate (user &rest args &key scroll-bars value &allow-other-keys) "Create an appropriate text editor gadget editing substrate object. Returns two values, the first is the substrate object, the second is the sheet that should be adopted by the user gadget." (let* ((minibuffer (when (and (not *use-goatee*) scroll-bars) (make-pane 'drei::drei-minibuffer-pane))) (substrate (apply #'make-pane (if *use-goatee* 'goatee-text-editor-substrate 'drei-text-editor-substrate) :user-gadget user :minibuffer minibuffer args)) (sheet (if scroll-bars (scrolling (:scroll-bars scroll-bars) substrate) substrate))) (if *use-goatee* (setf (slot-value substrate 'value) value) (setf (gadget-value substrate) value)) (values substrate (if minibuffer (vertically () sheet minibuffer) sheet)))) ;;; The class for using these substrates in the gadgets. (defclass editor-substrate-user-mixin (value-gadget) ((substrate :accessor substrate :documentation "The editing substrate used for this text field.")) (:documentation "A mixin class for creating gadgets using editor substrates.")) (defmethod gadget-value ((gadget editor-substrate-user-mixin)) (gadget-value (substrate gadget))) (defmethod (setf gadget-value) (value (gadget editor-substrate-user-mixin) &key invoke-callback) (declare (ignore invoke-callback)) (setf (gadget-value (substrate gadget)) value)) ;;; ------------------------------------------------------------------------------------------ ;;; 30.4.8 The concrete text-field Gadget (defclass text-field-pane (text-field vrack-pane editor-substrate-user-mixin) ((activation-gestures :accessor activation-gestures :initarg :activation-gestures :documentation "A list of gestures that cause the activate callback to be called.")) (:default-initargs :activation-gestures *standard-activation-gestures*)) (defmethod initialize-instance :after ((object text-field-pane) &key id client armed-callback disarmed-callback activation-gestures activate-callback value value-changed-callback) ;; Make an editor substrate object for the gadget. (let ((substrate (make-text-field-substrate object :id id :client client :armed-callback armed-callback :disarmed-callback disarmed-callback :activation-gestures activation-gestures :activate-callback activate-callback :value value :value-changed-callback value-changed-callback))) (setf (substrate object) substrate) (sheet-adopt-child object substrate))) ;;; ------------------------------------------------------------------------------------------ ;;; 30.4.9 The concrete text-editor Gadget (defclass text-editor-pane (text-editor vrack-pane editor-substrate-user-mixin) () (:default-initargs :activation-gestures '())) (defmethod initialize-instance :after ((object text-editor-pane) &key id client armed-callback disarmed-callback activation-gestures scroll-bars ncolumns nlines value) ;; Make an editor substrate object for the gadget. (multiple-value-bind (substrate sheet) (make-text-editor-substrate object :id id :client client :armed-callback armed-callback :disarmed-callback disarmed-callback :activation-gestures activation-gestures :scroll-bars scroll-bars :ncolumns ncolumns :nlines nlines :value value) (setf (substrate object) substrate) (sheet-adopt-child object sheet))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/patch.lisp0000600000175000017500000000050510423413276016761 0ustar pdmpdm(in-package :cl-user) (eval-when (:compile-toplevel :load-toplevel :execute) (unless (find-package :clim-lisp-patch) (make-package :clim-lisp-patch :use nil))) (export '(clim-lisp-patch::describe clim-lisp-patch::describe-object clim-lisp-patch::interactive-stream-p) :clim-lisp-patch) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/encapsulate.lisp0000640000175000017500000005406710561555365020217 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2001 by Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) (defvar *original-stream* nil) (defclass standard-encapsulating-stream (encapsulating-stream fundamental-character-input-stream fundamental-character-output-stream) ((stream :reader encapsulating-stream-stream :initarg :stream))) ;;; Macro used by methods for other stream classes that need to respect the ;;; possibility of an encapsulating stream when calling other methods on their ;;; stream argument. (defmacro with-encapsulating-stream ((maybe-encapsulating-stream stream) &body body) "Within BODY binds MAYBE-ENCAPSULATING-STREAM to an encapsulating stream, if there is one, or STREAM" `(let ((,maybe-encapsulating-stream (or *original-stream* ,stream))) ,@body)) ;;; Macro for defining methods that delegate to the encapsulated ;;; stream. Call the delegated method directly if possible, otherwise ;;; collect up optional and rest args and apply. (eval-when (:compile-toplevel :load-toplevel :execute) (defun parse-gf-lambda-list (ll) "Returns the required args, optional args, and presence of rest or key args" (let ((state 'required) (required-args nil) (optional-args nil) (rest-or-key nil)) (loop for arg in ll do (cond ((member arg lambda-list-keywords) (when (or (eq arg '&rest) (eq arg '&key) (eq arg '&allow-other-keys)) (setq rest-or-key t) (loop-finish)) (setq state arg)) ((eq state 'required) (push arg required-args)) ((eq state '&optional) (push arg optional-args)) (t (error "How did I get in this lambda list state?~% state ~S lambda list ~S" state ll)))) (values (nreverse required-args) (nreverse optional-args) rest-or-key))) ) (defmacro def-stream-method (name lambda-list) "stream is a required argument" (multiple-value-bind (required optional rest) (parse-gf-lambda-list lambda-list) (let* ((rest-arg (gensym "REST-ARG")) (supplied-vars (mapcar #'(lambda (var) (gensym (format nil "~A-SUPPLIED-P" (symbol-name var)))) optional)) (ll `(,@required ,@(and optional `(&optional ,@(mapcar #'(lambda (var supplied) `(,var nil ,supplied)) optional supplied-vars))) ,@(and rest `(&rest ,rest-arg)))) (required-params (mapcar #'(lambda (var) (if (consp var) (car var) var)) required)) (apply-list (gensym "APPLY-LIST")) (body (if (and (not optional) (not rest)) (if (symbolp name) `(,name ,@required-params) `(funcall #',name ,@required-params)) `(let ((,apply-list ,(and rest rest-arg))) ,@(mapcar #'(lambda (var supplied) `(when ,supplied (push ,var ,apply-list))) (reverse optional) (reverse supplied-vars)) (apply #',name ,@required-params ,apply-list))))) `(defmethod ,name ,ll (let ((*original-stream* stream) (stream (slot-value stream 'stream))) ,body))))) ;;; The basic input and output stream protocols, as specified by the Gray ;;; stream proposal in Chapter Common Lisp Streams . ;;; Not yet, apparently #+nil (def-stream-method streamp ((stream standard-encapsulating-stream))) (def-stream-method input-stream-p ((stream standard-encapsulating-stream))) (def-stream-method output-stream-p ((stream standard-encapsulating-stream))) (def-stream-method stream-element-type ((stream standard-encapsulating-stream))) (def-stream-method open-stream-p ((stream standard-encapsulating-stream))) (def-stream-method close ((stream standard-encapsulating-stream) &key abort)) (def-stream-method stream-pathname ((stream standard-encapsulating-stream))) (def-stream-method stream-truename ((stream standard-encapsulating-stream))) (def-stream-method stream-read-char ((stream standard-encapsulating-stream))) (def-stream-method stream-unread-char ((stream standard-encapsulating-stream) character)) (def-stream-method stream-read-char-no-hang ((stream standard-encapsulating-stream))) (def-stream-method stream-peek-char ((stream standard-encapsulating-stream))) (def-stream-method stream-listen ((stream standard-encapsulating-stream))) (def-stream-method stream-read-line ((stream standard-encapsulating-stream))) (def-stream-method stream-clear-input ((stream standard-encapsulating-stream))) (def-stream-method stream-write-char ((stream standard-encapsulating-stream) character)) (def-stream-method stream-line-column ((stream standard-encapsulating-stream))) (def-stream-method stream-start-line-p ((stream standard-encapsulating-stream))) (def-stream-method stream-write-string ((stream standard-encapsulating-stream) string &optional start end)) (def-stream-method stream-terpri ((stream standard-encapsulating-stream))) (def-stream-method stream-fresh-line ((stream standard-encapsulating-stream))) (def-stream-method stream-finish-output ((stream standard-encapsulating-stream))) (def-stream-method stream-force-output ((stream standard-encapsulating-stream))) (def-stream-method stream-clear-output ((stream standard-encapsulating-stream))) (def-stream-method stream-advance-to-column ((stream standard-encapsulating-stream) column)) (def-stream-method stream-read-byte ((stream standard-encapsulating-stream))) (def-stream-method stream-write-byte ((stream standard-encapsulating-stream) integer)) ;; stream-line-length is a CMUCL extension to Gray Streams which the pretty ;; printer seems to use. There's a default method which works for most CLIM ;; streams. For several dumb reasons it doesn't work on encapsulating streams. #+CMU (defmethod ext:stream-line-length ((stream standard-encapsulating-stream)) nil) #+SBCL (defmethod sb-gray:stream-line-length ((stream standard-encapsulating-stream)) nil) ;;;The sheet protocols, as specified in Chapters Properties of Sheets and Sheet ;;;Protocols . (def-stream-method sheetp ((stream standard-encapsulating-stream))) (def-stream-method sheet-parent ((stream standard-encapsulating-stream))) (def-stream-method sheet-children ((stream standard-encapsulating-stream))) (def-stream-method sheet-adopt-child ((stream standard-encapsulating-stream) child)) (def-stream-method sheet-disown-child ((stream standard-encapsulating-stream) child &key errorp)) (def-stream-method sheet-siblings ((stream standard-encapsulating-stream))) (def-stream-method sheet-enabled-children ((stream standard-encapsulating-stream))) (def-stream-method sheet-ancestor-p ((stream standard-encapsulating-stream) putative-ancestor)) (def-stream-method raise-sheet ((stream standard-encapsulating-stream))) (def-stream-method bury-sheet ((stream standard-encapsulating-stream))) (def-stream-method reorder-sheets ((stream standard-encapsulating-stream) new-ordering)) (def-stream-method sheet-enabled-p ((stream standard-encapsulating-stream))) (def-stream-method (setf sheet-enabled-p) (enabled-p (stream standard-encapsulating-stream))) (def-stream-method sheet-viewable-p ((stream standard-encapsulating-stream))) (def-stream-method sheet-occluding-sheets ((stream standard-encapsulating-stream) child)) (def-stream-method map-over-sheets (function (stream standard-encapsulating-stream))) (def-stream-method sheet-transformation ((stream standard-encapsulating-stream))) (def-stream-method (setf sheet-transformation) (transformation (stream standard-encapsulating-stream))) (def-stream-method sheet-region ((stream standard-encapsulating-stream))) (def-stream-method (setf sheet-region) (region (stream standard-encapsulating-stream))) (def-stream-method move-sheet ((stream standard-encapsulating-stream) x y)) (def-stream-method resize-sheet ((stream standard-encapsulating-stream) width height)) (def-stream-method move-and-resize-sheet ((stream standard-encapsulating-stream) x y width height)) (def-stream-method map-sheet-position-to-parent ((stream standard-encapsulating-stream) x y)) (def-stream-method map-sheet-position-to-child ((stream standard-encapsulating-stream) x y)) (def-stream-method map-sheet-rectangle*-to-parent ((stream standard-encapsulating-stream) x1 y1 x2 y2)) (def-stream-method map-sheet-rectangle*-to-child ((stream standard-encapsulating-stream) x1 y1 x2 y2)) (def-stream-method map-over-sheets-containing-position (function (stream standard-encapsulating-stream) x y)) (def-stream-method map-over-sheets-overlapping-region (function (stream standard-encapsulating-stream) region)) (def-stream-method child-containing-position ((stream standard-encapsulating-stream) x y)) (def-stream-method children-overlapping-region ((stream standard-encapsulating-stream) region)) (def-stream-method children-overlapping-rectangle* ((stream standard-encapsulating-stream) x1 y1 x2 y2)) (def-stream-method sheet-delta-transformation ((stream standard-encapsulating-stream) ancestor)) (def-stream-method sheet-allocated-region ((stream standard-encapsulating-stream) child)) (def-stream-method sheet-event-queue ((stream standard-encapsulating-stream))) (def-stream-method dispatch-event ((stream standard-encapsulating-stream) event)) (def-stream-method queue-event ((stream standard-encapsulating-stream) event)) (def-stream-method schedule-event ((stream standard-encapsulating-stream) event delay)) (def-stream-method handle-event ((stream standard-encapsulating-stream) event)) (def-stream-method event-read ((stream standard-encapsulating-stream))) (def-stream-method event-read-no-hang ((stream standard-encapsulating-stream))) (def-stream-method event-peek ((stream standard-encapsulating-stream) &optional event-type)) (def-stream-method event-unread ((stream standard-encapsulating-stream) event)) (def-stream-method event-listen ((stream standard-encapsulating-stream))) ;;; trampoline methods (def-stream-method medium-foreground ((stream standard-encapsulating-stream))) (def-stream-method (setf medium-foreground) (design (stream standard-encapsulating-stream))) (def-stream-method medium-background ((stream standard-encapsulating-stream))) (def-stream-method (setf medium-background) (design (stream standard-encapsulating-stream))) (def-stream-method medium-ink ((stream standard-encapsulating-stream))) (def-stream-method (setf medium-ink) (design (stream standard-encapsulating-stream))) (def-stream-method medium-transformation ((stream standard-encapsulating-stream))) (def-stream-method (setf medium-transformation) (transformation (stream standard-encapsulating-stream))) (def-stream-method medium-clipping-region ((stream standard-encapsulating-stream))) (def-stream-method (setf medium-clipping-region) (region (stream standard-encapsulating-stream))) (def-stream-method medium-line-style ((stream standard-encapsulating-stream))) (def-stream-method (setf medium-line-style) (line-style (stream standard-encapsulating-stream))) (def-stream-method medium-text-style ((stream standard-encapsulating-stream))) (def-stream-method (setf medium-text-style) (text-style (stream standard-encapsulating-stream))) (def-stream-method medium-default-text-style ((stream standard-encapsulating-stream))) (def-stream-method (setf medium-default-text-style) (text-style (stream standard-encapsulating-stream))) (def-stream-method text-size ((stream standard-encapsulating-stream) string &key text-style start end)) (def-stream-method text-style-ascent (text-style (stream standard-encapsulating-stream))) (def-stream-method text-style-descent (text-style (stream standard-encapsulating-stream))) (def-stream-method text-style-height (text-style (stream standard-encapsulating-stream))) (def-stream-method text-style-width (text-style (stream standard-encapsulating-stream))) (def-stream-method text-style-fixed-width-p (text-style (stream standard-encapsulating-stream))) (def-stream-method sheet-medium ((stream standard-encapsulating-stream))) (def-stream-method queue-repaint ((stream standard-encapsulating-stream) repaint-event)) (def-stream-method handle-repaint ((stream standard-encapsulating-stream) region)) (def-stream-method repaint-sheet ((stream standard-encapsulating-stream) region)) (def-stream-method note-sheet-grafted ((stream standard-encapsulating-stream))) (def-stream-method note-sheet-degrafted ((stream standard-encapsulating-stream))) (def-stream-method note-sheet-adopted ((stream standard-encapsulating-stream))) (def-stream-method note-sheet-disowned ((stream standard-encapsulating-stream))) (def-stream-method note-sheet-enabled ((stream standard-encapsulating-stream))) (def-stream-method note-sheet-disabled ((stream standard-encapsulating-stream))) ;;; Text Style binding forms #+nil (def-stream-method invoke-with-text-style ((stream standard-encapsulating-stream) continuation text-style)) (defmethod invoke-with-text-style ((stream standard-encapsulating-stream) continuation text-style) (invoke-with-text-style (slot-value stream 'stream) #'(lambda (medium) (declare (ignore medium)) (funcall continuation stream)) text-style)) ;;; Drawing functions (def-stream-method medium-draw-point* ((stream standard-encapsulating-stream) x y)) (def-stream-method medium-draw-points* ((stream standard-encapsulating-stream) coord-seq)) (def-stream-method medium-draw-line* ((stream standard-encapsulating-stream) x1 y1 x2 y2)) (def-stream-method medium-draw-lines* ((stream standard-encapsulating-stream) position-seq)) (def-stream-method medium-draw-polygon* ((stream standard-encapsulating-stream) coord-seq closed filled)) (def-stream-method medium-draw-rectangle* ((stream standard-encapsulating-stream) x1 y1 x2 y2 filled)) (def-stream-method medium-draw-rectangles* ((stream standard-encapsulating-stream) coord-seq filled)) (def-stream-method medium-draw-ellipse* ((stream standard-encapsulating-stream) center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy start-angle end-angle filled)) (def-stream-method medium-draw-circle* ((stream standard-encapsulating-stream) center-x center-y radius start-angle end-angle filled)) (def-stream-method medium-draw-text* ((stream standard-encapsulating-stream) string x y start end align-x align-y toward-x toward-y transform-glyphs)) (def-stream-method medium-finish-output ((stream standard-encapsulating-stream))) (def-stream-method medium-force-output ((stream standard-encapsulating-stream))) (def-stream-method medium-clear-area ((stream standard-encapsulating-stream) left top right bottom)) (def-stream-method medium-beep ((stream standard-encapsulating-stream))) ;;; Extended Output Streams (def-stream-method stream-text-cursor ((stream standard-encapsulating-stream))) (def-stream-method (setf stream-text-cursor) (cursor (stream standard-encapsulating-stream))) (def-stream-method stream-cursor-position ((stream standard-encapsulating-stream))) ;;; A setf* method, but this should still work... ;; (It didn't. --Hefner) ;(def-stream-method (setf stream-cursor-position) ; (x y (stream standard-encapsulating-stream))) (defmethod* (setf stream-cursor-position) (x y (stream standard-encapsulating-stream)) (let ((*original-stream* stream) (stream (slot-value stream 'stream))) (setf (stream-cursor-position stream) (values x y)))) (def-stream-method stream-increment-cursor-position ((stream standard-encapsulating-stream) dx dy)) (def-stream-method stream-character-width ((stream standard-encapsulating-stream) character &key text-style)) (def-stream-method stream-string-width ((stream standard-encapsulating-stream) string &key start end text-style)) (def-stream-method stream-text-margin ((stream standard-encapsulating-stream))) (def-stream-method (setf stream-text-margin) (margin (stream standard-encapsulating-stream))) (def-stream-method stream-line-height ((stream standard-encapsulating-stream) &key text-style)) (def-stream-method stream-vertical-spacing ((stream standard-encapsulating-stream))) (def-stream-method stream-baseline ((stream standard-encapsulating-stream))) (def-stream-method stream-end-of-line-action ((stream standard-encapsulating-stream))) (def-stream-method (setf stream-end-of-line-action) (action (stream standard-encapsulating-stream))) (def-stream-method stream-end-of-page-action ((stream standard-encapsulating-stream))) (def-stream-method (setf stream-end-of-page-action) (action (stream standard-encapsulating-stream))) (def-stream-method medium-buffering-output-p ((stream standard-encapsulating-stream))) (def-stream-method (setf medium-buffering-output-p) (buffered-p (stream standard-encapsulating-stream))) (defmethod invoke-with-drawing-options ((medium standard-encapsulating-stream) continuation &rest drawing-options) (apply #'invoke-with-drawing-options (slot-value medium 'stream) #'(lambda (old-medium) (declare (ignore old-medium)) (funcall continuation medium)) drawing-options)) ;;; Extended Input Streams (def-stream-method extended-input-stream-p ((stream standard-encapsulating-stream))) (def-stream-method stream-input-buffer ((stream standard-encapsulating-stream))) (def-stream-method (setf stream-input-buffer) (buffer (stream standard-encapsulating-stream))) (def-stream-method stream-pointer-position ((stream standard-encapsulating-stream) &key pointer)) (def-stream-method (setf stream-pointer-position) (x y (stream standard-encapsulating-stream) &key pointer)) (def-stream-method stream-set-input-focus ((stream standard-encapsulating-stream))) (def-stream-method stream-read-gesture ((stream standard-encapsulating-stream) &key timeout peek-p input-wait-test input-wait-handler pointer-button-press-handler)) (def-stream-method stream-input-wait ((stream standard-encapsulating-stream) &key timeout input-wait-test)) (def-stream-method stream-unread-gesture ((stream standard-encapsulating-stream) gesture)) (def-stream-method stream-accept ((stream standard-encapsulating-stream) type &key view default default-type provide-default insert-default replace-input history active-p prompt prompt-mode display-default query-identifier activation-gestures additional-activation-gestures delimiter-gestures additional-delimiter-gestures)) ;;; Output recording (def-stream-method stream-recording-p ((stream standard-encapsulating-stream))) (def-stream-method (setf stream-recording-p) (recording-p (stream standard-encapsulating-stream))) (def-stream-method stream-drawing-p ((stream standard-encapsulating-stream))) (def-stream-method (setf stream-drawing-p) (drawing-p (stream standard-encapsulating-stream))) (def-stream-method stream-output-history ((stream standard-encapsulating-stream))) (def-stream-method stream-current-output-record ((stream standard-encapsulating-stream))) (def-stream-method (setf stream-current-output-record) (record (stream standard-encapsulating-stream))) (def-stream-method stream-add-output-record ((stream standard-encapsulating-stream) record)) (def-stream-method stream-replay ((stream standard-encapsulating-stream) &optional region)) (def-stream-method erase-output-record (record (stream standard-encapsulating-stream) &optional errorp)) (def-stream-method stream-text-output-record ((stream standard-encapsulating-stream) text-style)) (def-stream-method stream-close-text-output-record ((stream standard-encapsulating-stream))) (def-stream-method stream-add-character-output ((stream standard-encapsulating-stream) character text-style width height baseline)) (def-stream-method stream-add-string-output ((stream standard-encapsulating-stream) string start end text-style width height baseline)) (defmethod invoke-with-output-recording-options ((stream standard-encapsulating-stream) continuation record draw) (invoke-with-output-recording-options (slot-value stream 'stream) #'(lambda (old-stream) (declare (ignore old-stream)) (funcall continuation stream)) record draw)) (defmethod invoke-with-new-output-record ((stream standard-encapsulating-stream) continuation record-type constructor &rest initargs) (apply #'invoke-with-new-output-record (slot-value stream 'stream) #'(lambda (inner-stream output-record) (declare (ignore inner-stream)) (funcall continuation stream output-record)) record-type constructor initargs)) (defmethod invoke-with-output-to-output-record ((stream standard-encapsulating-stream) continuation record-type constructor &rest initargs &key &allow-other-keys) (apply #'invoke-with-output-to-output-record (slot-value stream 'stream) #'(lambda (inner-stream record) (declare (ignore inner-stream)) (funcall continuation stream record)) record-type constructor initargs)) ;;; Presentation type generics (def-stream-method stream-default-view ((stream standard-encapsulating-stream))) (def-stream-method (setf stream-default-view) (view (stream standard-encapsulating-stream))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/ReleaseNotes/0000755000175000017500000000000011347763412017400 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/ReleaseNotes/0-9-1-mothering-sunday0000644000175000017500000002163610212676744023272 0ustar pdmpdmRELEASE NOTES FOR McCLIM 0.9.1, "Mothering Sunday": Changes to the McCLIM Installation Process ========================================== McCLIM now comes with a native ASDF system definition in mcclim.asd, along with the traditional (still ASDF-compatible) system.lisp. See INSTALL.ASDF for details. Changes to Backends =================== Support for Copy&Paste of selections (both into and out from McCLIM applications) in the X11 backend was added. Copying text from McCLIM into some applications (and vice versa) like KDE's Konsole is broken, unfortunately. In other cases, Shift + left-mouse-drag and Shift + mouse-middle-down now activate a selection and paste, respectively. There is now rudimentary support for printing non-Latin1 characters to X11 ports on SBCL. Beagle, A new experimental backend using Mac OS X's Cocoa bindings was added. Note that this backend is still incomplete and breaks in some places. It is not loaded automatically. To try it out, consult Backends/beagle/README. Changes to the Manual ===================== A chapter on presentation types was added. The chapter on command tables was improved. Changes to Contributed Applications and Examples ================================================ Clouseau, a graphical Inspector application was added. The CLIM Listener saw many improvements, among these: package graphing, better directory stack handling and a new Edit Definition command. A Method Browser was added to the examples. Status of the CLIM 2 Spec Implementation ======================================== Here is a list of what we think works, organized by chapters and sections of the CLIM 2 specification. Chapter 3 Regions Mostly finished. There are some troublesome parts of the specification that may not be implemented for all possible regions, for instance region-contains-region-p. There may not be an efficient way of implementing this function for all kinds of regions. Chapter 4, Bounding rectangles Finished Chapter 5, Affine transformations Finished Chapter 6, Overview of window facilities Finished Chapter 7, Properties of sheets Finished, though the correct behavior of sheet transformations may not have been tested. Chapter 8, Sheet protocols Finished Chapter 9, Ports, Grafts, and Mirrored sheets Finished Chapter 10, Sheet and medium output facilities Finished Chapter 11, Text styles Finished Chapter 12, Graphics Finished Chapter 13, Drawing in Color I am note sure about the state of this. I thought we were doing only full opacity and full transparency, but I see traces of more general designs. Chapter 14, General Designs The composition of designs is not supported. We do support regions as designs. Chapter 15, Extended Stream Output Extended output streams are fully supported. Chapter 16, Output Recording Output recording is mostly implemented. We do not have a true standard-tree-output-record type or the R-tree type of real CLIM, so some operations may be slow with lots of output records. make-design-from-output-record is not implemented. *Note*: the coordinates in output records are relative to the stream. This is in conformance with the Spec, but not necessarily compatible with other CLIM implementations. There is now a protocol in place for Drag-and-Drop of output records. Output recording inside formatting-tables now works. Chapter 17, Table Formatting Table formatting is completely implemented. Chapter 18, Graph Formatting Graph formatting is fully implemented. The :hash-table argument to format-graph-from-roots is ignored. Chapter 19, Bordered Output Bordered output is fully supported. The :move-cursor argument to surrounding-output-with-border is now working. Chapter 20, Text Formatting With the exception of the :after-line-break-initially argument to filling-output, this chapter is fully implemented. Chapter 21 Incremental Redisplay The updating-output interface to incremental redisplay is implemented. McCLIM makes no effort to move i.e., bitblit, output records; they are always erased and redrawn if their position changes. This is much more compatible with support for partial transparency. The :x, :y, :parent-x and :parent-y arguments to redisplay-output-record are ignored. McCLIM follows the spirit of 21.3 "Incremental Redisplay Protocol", but we have not tried very hard to implement the vague description in the Spec. augment-draw-set, note-output-record-child-changed and propagate-output-record-changes-p are not implemented. Incremental redisplay in McCLIM can suffer from performance problems because there are no spatially-organized compound output record types. The generic function incremental-redisplay is now implemented. Chapter 22, Extended Stream Input The implementation of extended input streams is quite complete. (setf* pointer-position) is not implemented. There is no stream numeric argument, so that slot of the accelerator-gesture condition is always 1. drag-output-record and dragging-output are now implemented. Chapter 23 Presentation Types Most of the literal specification of this chapter is implemented. Specific accept and present presentation methods for some types are not implemented, so the default method may be surprising. The output record bounding rectangle is always used or highlighting and pointer testing. presentation-default-processor is not implemented. The presentation method mechanism supports all method combinations. The body of a presentation method is surrounded with a block of the same name as the presentation method, not just the magic internal name. The method by which presentation type parameters and options are decoded for the method bodies is a bit different from real CLIM. In particular, you cannot refer to the type parameters and options in the lambda list of the method. The NIL value of presentation-single-box is now supported. Presentation type histories are now partially implemented. The gesture C-M-y should recall the last entered presentation. define-drag-and-drop-translator is now implemented. Chapter 24 Input Editing and Completion Facilities with-input-editor-typeout is not implemented. The noise strings produced by input-editor-format and the strings produced by presentation-replace-input are not read-only. This could lead to interesting "issues" if the user edits them. Only a few of the suggested editing commands are implemented. An additional command that is implemented is control-meta-B, which drops into the debugger. add-input-editor-command is not implemented. with-accept-help is not implemented. Chapter 25 Menu Facilities The protocol is implemented, but McCLIM doesn't use it to draw command table menus. Chapter 26 Dialog Facilities McCLIM contains a basic, somewhat buggy implementation of accepting-values. There is little user feedback as to what has been accepted in a dialog. The user has to press the "Exit" button to exit the dialog; there are no short cuts. There are no special accept-present-default methods for member or subset presentation types. Command-buttons are not implemented. There is no gadget-based implementation of accepting-values. own-window is not supported. The internal structure of accepting-values should be "culturally compatible" with real CLIM; if you have some spiffy hack, check the source. Chapter 27 Command Processing command-line-complete-input is not implemented (the functionality does exist in the accept method for command-name). display-command-table-menu and menu-choose-command-from-table are not implemented. Menu-command-parser is not implemented, though the functionality obviously is. Nothing is done about partial menu commands. There is no support for numeric arguments. The command-or-form presentation type is not implemented. Chapter 28 Application Frames raise-frame, bury-frame and notify-user are not implemented. :accept-values panes are not implemented. frame-maintain-presentation-histories, frame-drag-and-drop-feedback and frame-drag-and-drop-highlighting are not implemented. execute-frame-command ignores the possibility that frame and the current frame might be different. display-command-menu isn't implemented. command-enabled is now implemented. Chapter 29 Panes Due to the way the space-allocation protocol is implemented, it is not easy to create application-specific layout-panes. Client code needs to know about :AROUND methods to compose-space, but they are not mentioned in the spec. restraining-pane is partially implemented. Chapter 30 Gadgets This chapter is implemented. cl-mcclim-0.9.6.dfsg.cvs20100315.orig/ReleaseNotes/0-9-armistice0000644000175000017500000001566407754272213021623 0ustar pdmpdmThe OpenGL backend hasn't been tested recently. Here is a list of what we think works, organized by chapters and sections of the CLIM 2 specification. Chapter 3 Regions Mostly finished. There are some troublesome parts of the specification that may not be implemented for all possible regions, for instance region-contains-region-p. There may not be an efficient way of implementing this function for all kinds of regions. Chapter 4, Bounding rectangles Finished Chapter 5, Affine transformations Finished Chapter 6, Overview of window facilities Finished Chapter 7, Properties of sheets Finished, though the correct behavior of sheet transformations may not have been tested. Chapter 8, Sheet protocols Finished Chapter 9, Ports, Grafts, and Mirrored sheets Finished Chapter 10, Sheet and medium output facilities Finished Chapter 11, Text styles Finished Chapter 12, Graphics Finished Chapter 13, Drawing in Color I am note sure about the state of this. I thought we were doing only full opacity and full transparency, but I see traces of more general designs. Chapter 14, General Designs The composition of designs is not supported. We do support regions as designs. Chapter 15, Extended Stream Output Extended output streams are fully supported. Chapter 16, Output Recording Output recording is mostly implemented. We do not have a true standard-tree-output-record type or the R-tree type of real CLIM, so some operations may be slow with lots of output records. make-design-from-output-record is not implemented. *Note*: the coordinates in output records are relative to the stream. This is in conformance with the Spec, but not necessarily compatible with other CLIM implementations. Chapter 17, Table Formatting Table formatting is completely implemented. Chapter 18, Graph Formatting Graph formatting is fully implemented. The :hash-table argument to format-graph-from-roots is ignored. Chapter 19, Bordered Output Bordered output is fully supported with the exception of the :move-cursor argument to surrounding-output-with-border. Chapter 20, Text Formatting With the exception of the :after-line-break-initially argument to filling-output, this chapter is fully implemented. Chapter 21 Incremental Redisplay The updating-output interface to incremental redisplay is implemented. McCLIM makes no effort to move i.e., bitblit, output records; they are always erased and redrawn if their position changes. This is much more compatible with support for partial transparency. The :x, :y, :parent-x and :parent-y arguments to redisplay-output-record are ignored. McCLIM follows the spirit of 21.3 "Incremental Redisplay Protocol", but we haven't tried very hard to implement the vague description in the Spec. augment-draw-set, note-output-record-child-changed and propagate-output-record-changes-p are not implemented. The function incremental-redisplay is not implemented. Incremental redisplay in McCLIM can suffer from performance problems because there isn't any spatially-organized compound output record type. Chapter 22, Extended Stream Input The implementation of extended input streams is quite complete. (setf* pointer-position) is not implemented. There is no stream numeric argument, so that slot of the accelerator-gesture condition is always 1. drag-output-record and dragging-output are not implemented. Chapter 23 Presentation Types Most of the literal specification of this chapter is implemented. Specific accept and present presentation methods for some types are not implemented, so the default method may be surprising. The NIL value of presentation-single-box is not supported. The output record bounding rectangle is always used or highlighting and pointer testing. Presentation type histories are not implemented. The presentation method mechanism supports all method combinations. The body of a presentation method is surrounded with a block of the same name as the presentation method, not just the magic internal name. The method by which presentation type parameters and options are decoded for the method bodies is a bit different from real CLIM. In particular, you can't refer to the type parameters and options in the lambda list of the method. presentation-default-processor are define-drag-and-drop-translator not implemented. Chapter 24 Input Editing and Completion Facilities with-input-editor-typeout is not implemented. The noise strings produced by input-editor-format and the strings produced by presentation-replace-input are not read-only. This could lead to interesting "issues" if the user edits them. Only a few of the suggested editing commands are implemented. An additional command that is implemented is control-meta-B, which drops into the debugger. add-input-editor-command is not implemented. with-accept-help is not implemented. Chapter 25 Menu Facilities The protocol is implemented, but McCLIM doesn't use it to draw command table menus. Chapter 26 Dialog Facilities McCLIM contains a basic, somewhat buggy implementation of accepting-values. Thes is little user feedback as to what has been accepted in a dialog. The user has to press the "Exit" button to exit the dialog; there are no short cuts. There are no special accept-present-default methods for member or subset presentation types. Command-buttons are not implemented. There is not gadget-based implementation of accepting-values. own-window is not supported. The internal structure of accepting-values should be "culturally compatible" with real CLIM; if you have some spiffy hack, check the source. Chapter 27 Command Processing command-line-complete-input is not implemented (the functionality does exist in the accept method for command-name). display-command-table-menu and menu-choose-command-from-table are not implemented. Menu-command-parser is not implemented, though the functionality obviously is. Nothing is done about partial menu commands. There is no support for numeric arguments. The command-or-form presentation type is not implemented. Chapter 28 Application Frames raise-frame, bury-frame and notify-user are not implemented. :accept-values panes are not implemented. frame-maintain-presentation-histories, frame-drag-and-drop-feedback and frame-drag-and-drop-highlighting are not implemented. execute-frame-command ignores the possibility that frame and the current frame might be different. command-enable and display-command-menu aren't implemented. Chapter 29 Panes restraining-pane isn't implemented. Chapter 30 Gadgets This chapter is implemented. cl-mcclim-0.9.6.dfsg.cvs20100315.orig/ReleaseNotes/0-9-5-eastern-orthodox-liturgical-new-year0000640000175000017500000000661610666602767027174 0ustar pdmpdmRELEASE NOTES FOR McCLIM 0.9.5, "Eastern Orthodox Liturgical New Year": Compatibility ============= This release was tested and found to work on the following implementations: * SBCL * OpenMCL * CLISP (requires "Telent" CLX) * Allegro Common Lisp 8.0 in ANSI Mode In our tests, this release of McCLIM did not work on the following implementations: * CMUCL (at the time of this release, the released CMUCL has a bug that prevents successful loading of McCLIM; CMUCL 19d + patch 1 and the 2006-12 snapshot or later contain a fix for this problem) Also, McCLIM currently does not support lisps with case-sensitive readers (Allegro CL "modern mode" and lower-case Scieneer CL). Changes in mcclim-0.9.5 "Eastern Orthodox Liturgical New Year" relative to 0.9.4: ============================================================== From the NEWS file: * Changes in mcclim-0.9.5 relative to 0.9.4: ** Installation: the systems clim-listener, clim-examples, and clouseau can now be loaded without loading the system mcclim first. Users with existing McCLIM installations should use the provided script: ./symlink-asd-files.sh /path/to/asdf-central-registry/ ** New extension: tab-layout. This extension allows keeping a stack of panes whose foreground pane is controlled by a tab bar. This layout can be customized in backends and frame managers. For examples, see the gtkairo backend and the pixie frame manager. ** New extension function: SHEET-RGB-IMAGE: makes a screenshot of a sheet in the CLX backend. (Supported on truecolor visuals only for now.) ** New experimental extension: tree-with-cross-edges are an extension to the graph formatter. ** New experimental backend: clim-graphic-forms: native widgets on Windows. This backend is still very experimental (it doesn't run demos yet). ** New inspector feature: The inspector now displays more useful information about hash tables and generic functions. ** Specification compliance: Various layout panes no longer quite as aggressive at eating the space requirements of their children. ** Specification compliance: There is now a rudimentary implementation of NOTIFY-USER ** Usability: Text editors and text input panes now use click-to-focus. ** Improvement: the ACCEPTING-VALUES command table was renamed to ACCEPT-VALUES (as this is the name that the other clim-2 implementation uses) ** Improvement: the CLX backend should no longer cause focus stealing when an application has text-editor panes. This change comes with a rudimentary click-to-focus-keyboard widget policy. ** Improvement: define-application-frame now allows a :default-initargs option. (This is not exactly a "specification compliance" fix, as d-a-frame is not defined to accept this option.). ** Improvement: menu-choose menus now look a little prettier. ** Improvement: added more styles for bordered-output: :rounded, :ellipse ** Improvement: Toggle button values now default to NIL. ** Improvement: Frame layouts are now inherited from the frame's superclass. ** Improvement: The Lisp Syntax is much improved: now recognizes delimiter characters, and more types of Lambda lists. ** Bug fix: Bezier designs should now draw in the right place in all backends. ** Bug fix: Text in Drei no longer "walks" to the left. ** Bug fix: Drei now has better support for delimiter gestures. ** Bug fix: Partial commands now work better when invoked from the menu.cl-mcclim-0.9.6.dfsg.cvs20100315.orig/ReleaseNotes/0-9-4-orthodox-new-year0000640000175000017500000000576110552526772023372 0ustar pdmpdmRELEASE NOTES FOR McCLIM 0.9.4, "Orthodox New Year": Compatibility ============= This release was tested and found to work on the following implementations: * SBCL * OpenMCL * CLISP * Allegro Common Lisp 8.0 in ANSI Mode In our tests, this release of McCLIM did not work on the following implementations: * CMUCL (at the time of this release, the released CMUCL has a bug that prevents successful loading of McCLIM; CMUCL 19d + patch 1 and the 2006-12 snapshot or later contain a fix for this problem) Also, McCLIM currently does not support lisps with case-sensitive readers (ACL "modern mode" and lower-case SCL). Known Bugs ========== Due to the radical changes introduced by the new editor substrate, some bugs may surface in day-to-day use. We would very much like to hear about them on mcclim-devel@common-lisp.net. As a work-around, you can enable the old input substrate by using (setf climi::*use-goatee* t) on the REPL when clim is loaded. The following bugs are known to exist: * McCLIM freetype can interact poorly with Drei under some circumstances * Drei does not handle most reader macros well * Sometimes, the ENTER key is not very responsive when editing forms with Drei * Calling stream-input-buffer is still buggy. Changes in mcclim-0.9.4 "Orthodox New Year" relative to 0.9.3: =========================================================== From the NEWS file: * cleanup: removed the obsolete system.lisp file. * backend improvements: Gtkairo ** Double buffering is now supported (fixes disappearing widgets on Windows). ** X errors no longer terminate the lisp process. ** Some bugfixes, including CMUCL support and better key event handling. ** Native implementation of context menus, list panes, label panes, and option panes. ** Draw text using Pango. (Bug fix: Fixed-width font supported on Windows now. Multiple lines of output in TEXT-SIZE supported now. TEXT-STYLE-FIXED-WIDTH-P works correctly now.) * Improvement: Added new editor substrate ("Drei"). * Improvement: Improved the pathname presentation methods considerably. * specification compliance: DELETE-GESTURE-NAME function now implemented. * specification compliance: PRESENTATION-TYPE-SPECIFIER-P presentaion function now implemented. * specification compliance: DISPLAY-COMMAND-TABLE-MENU function now implemented. * specification compliance: DISPLAY-COMMAND-MENU function now implemented. * specification compliance: POINTER-PLACE-RUBBER-BAND-LINE* function now implemented. * specification compliance: POINTER-INPUT-RECTANGLE* function now implemented. * specification compliance: POINTER-INPUT-RECTANGLE function now implemented. * Improvement: Added font listing support, see section "Fonts and Extended Text Styles" in the manual. * Improvement: Added support for bezier splines (Robert Strandh). To be documented. * better PRESENTATION-SUBTYPEP (more likely to give the right answer on some-of and all-of presentation types) * Improvement: M-n/M-p gestures for navigating presentation histories. cl-mcclim-0.9.6.dfsg.cvs20100315.orig/ReleaseNotes/0-9-3-all-souls'-day0000640000175000017500000000631110522435532022511 0ustar pdmpdmRELEASE NOTES FOR McCLIM 0.9.3, "All Souls' Day": Compatibility ============= This release was tested and found to work on the following implementations: * SBCL * OpenMCL * Allegro Common Lisp 8.0 in ANSI Mode * The Scieneer Common Lisp in ANSI Mode In our tests, this release of McCLIM did not work on the following implementations: * CLISP (there are some problems with CLISP at the moment, but it is possible to run McCLIM there; a HOWTO will be posted to http://planet.lisp.org). * CMUCL (at the time of this release, the released CMUCL has a bug that prevents successful loading of McCLIM; CMUCL 19d + patch 1 and the 2006-12 snapshot or later contain a fix for this problem) * LispWorks (no known workaround) Also, McCLIM currently does not support lisps with case-sensitive readers (ACL "modern mode" and lower-case SCL). Changes in mcclim-0.9.3 "All Souls' Day" relative to 0.9.2: =========================================================== From the NEWS file: * backend improvement: The Null backend now registers itself in the server search path * improvement: with-output-as-gadget now sets the correct cursor position when incremental redisplay is active. * specification compliance: INVOKE-WITH-NEW-OUTPUT-RECORD's argument list now is the same as the one in the Franz CLIM user guide. * improvement: The text field cursor is now a solid block again. * backend improvement: the PostScript backend now outputs correct EPS * improvement: Graph nodes can now be dragged * improvement: Possibilities when reading from COMPLETE-FROM-GENERATOR are now sorted alphabetically. * new experimental backend: gtkairo (loads on SBCL, CMUCL and SCL): Uses GTK+ for gadgets and cairo for rendering graphics. * Bug fix: incremental-redisplay does no longer leak memory * improvement: incremental-redisplay is now a little faster * Bug fix: Invisible text cursors no longer leave a dangling space behind the text output record * improvement: commands whose names are shadowed in child command tables are now suggested in preference to their parents. * Bug fix: (setf stream-cursor-position) and output record replay on encapsulating streams work now. * Bug fix: Invoking command menu items in frames with no interactor works now. * Bug fix: DESTROY-PORT removes the port even if an error occurs while closing the port * Bug fix: make-process now sets the process name on SBCL * specification compliance: MENU-CHOOSE now supports almost all features demanded in the CLIM 2.0 specification. * improvement: new and improved ACCEPT presentation method for expressions on interactive streams. * specification compliance: LOOKUP-KEYSTROKE-ITEM no longer accepts the :errorp argument. * Bug fix: incremental redisplay no longer breaks on output records that had no children. * Bug fix: arrow head sizes are now transformed along with the line thickness. * improvement: resizing a viewport's child will now move the viewport's focus. * improvement: loading mcclim.asd no longer shows a code deletion note on SBCL. * new demo: logic-cube * compatibility: Add support for post-1.0 openmcl, and for Allegro Common Lisp 8.0 (ansi mode). * new example application showing use of CLIM views. cl-mcclim-0.9.6.dfsg.cvs20100315.orig/ReleaseNotes/0-9-2-laetare-sunday0000600000175000017500000002466510411572051022674 0ustar pdmpdmRELEASE NOTES FOR McCLIM 0.9.2, "Laetare Sunday": Compatibility ============= This release works on CMUCL, SBCL, CLISP, OpenMCL, Allegro CL, LispWorks, and the Scieneer CL, using the CLX X Window bindings. Changes to the Install Process ============================== Implementation-specific INSTALL.* files were removed. Generic and implementation-specific Installation instructions were improved and merged into the file INSTALL. This release requires the "spatial-trees" library by Christophe Rhodes. Get it via asdf-install or at http://cliki.net/spatial-trees. Changes to Backends =================== Copy & Paste code in the CLX backend was improved and should now adhere more strictly to ICCCM. Support for connecting to a ssh-forwarded display was restored. Several unused parts (marked with #+unicode) of the CLX backend were removed, thus restoring buildability on installations of clisp that have the unicode feature turned on. Double buffering for panes was implemented. To use it, create panes with the :double-buffering t initarg. There is now rudimentary support for entering non-Ascii characters from X11 ports using SBCL CLX (a.k.a. telent CLX). McCLIM ships experimental support for TrueType font rendering using the FreeType libraries and the free Bitstream Vera fonts. To use it, link Experimental/freetype/mcclim-freetype.asd to one of your asdf:*central-registry* directories and load the "MCCLIM-FREETYPE" system. An experimental "Null" backend was added that should allow testing of CLIM functionality without requiring a GUI environment to run. Changes to the Documentation ============================ A new chapter on contributed applications was added. Several new figures and examples were added to the manual Clemens Fruhwirth added a CLIM tutorial paper called "A Guided Tour to CLIM". It is available in Doc/Guided-Tour/. Changes to Contributed Applications and Examples ================================================ New application: A CLIM Debugger (by Peter Mechlenborg). It resides in Apps/Debugger/. New application: Functional-Geometry by Frank Buss and Rainer Joswig. It resides in Apps/Functional-Geometry/. The Inspector now is now able to disassemble functions and inspect pathnames. The Listener can now produce vertically-aligned graphs. The Scigraph application now builds on SBCL again. A demo for drag-and-drop-translators was added. Further additions to McCLIM =========================== There is now a test suite, located in Tests/. It contains tests for regions, bounding rectangles, transformations, commands, and the PostScript backend. With the addition of the Null backend, we hope to add several more tests for more chapters of the CLIM spec. New Extension "conditional-commands": allows activation/deactivation of commands when other commands are invoked. It resides in Extensions/conditional-commands/. Status of the CLIM 2 Spec Implementation ======================================== Here is a list of what we think works, organized by chapters and sections of the CLIM 2 specification. Chapter 3 Regions Mostly finished. There are some troublesome parts of the specification that may not be implemented for all possible regions, for instance region-contains-region-p. There may not be an efficient way of implementing this function for all kinds of regions. Chapter 4, Bounding rectangles Finished Chapter 5, Affine transformations Finished Chapter 6, Overview of window facilities Finished Chapter 7, Properties of sheets Finished, though the correct behavior of sheet transformations may not have been tested. Chapter 8, Sheet protocols Finished Chapter 9, Ports, Grafts, and Mirrored sheets Finished Chapter 10, Sheet and medium output facilities Finished Chapter 11, Text styles Mostly complete. There is now experimental support for device font text styles (via make-device-font-text-style) for the CLX, PostScript, and CLX+FreeType backends. Chapter 12, Graphics Finished Chapter 13, Drawing in Color I am note sure about the state of this. I thought we were doing only full opacity and full transparency, but I see traces of more general designs. Chapter 14, General Designs The composition of designs is not supported. We do support regions as designs. Chapter 15, Extended Stream Output Extended output streams are fully supported. Chapter 16, Output Recording Output recording is mostly implemented. This release ships with a standard-tree-output-record type for the first time. The tree output record type speeds up point- and region-based queries, but slows down insertion of output records by a bit. make-design-from-output-record is not implemented. *Note*: the coordinates in output records are relative to the stream. This is in conformance with the Spec, but not necessarily compatible with other CLIM implementations. Chapter 17, Table Formatting Table formatting is completely implemented. Chapter 18, Graph Formatting Graph formatting is fully implemented. The :hash-table argument to format-graph-from-roots is ignored. Support for a :dag graph type was added, as was support for vertically oriented graphs and support for the :arc-drawer argument to format-graph-from-roots. Chapter 19, Bordered Output Bordered output is fully supported. Chapter 20, Text Formatting With the exception of the :after-line-break-initially argument to filling-output, this chapter is fully implemented. Chapter 21 Incremental Redisplay The updating-output interface to incremental redisplay is implemented. McCLIM makes no effort to move i.e., bitblit, output records; they are always erased and redrawn if their position changes. This is much more compatible with support for partial transparency. The :x, :y, :parent-x and :parent-y arguments to redisplay-output-record are ignored. McCLIM follows the spirit of 21.3 "Incremental Redisplay Protocol", but we have not tried very hard to implement the vague description in the Spec. augment-draw-set, note-output-record-child-changed and propagate-output-record-changes-p are not implemented. Incremental redisplay in McCLIM may still suffer from performance problems, despite the presence of spatially-organized compound output record types. Chapter 22, Extended Stream Input The implementation of extended input streams is quite complete. (setf* pointer-position) is not implemented. There is no stream numeric argument, so that slot of the accelerator-gesture condition is always 1. Chapter 23 Presentation Types Most of the literal specification of this chapter is implemented. Specific accept and present presentation methods for some types are not implemented, so the default method may be surprising. The output record bounding rectangle is always used or highlighting and pointer testing. presentation-default-processor is not implemented. The presentation method mechanism supports all method combinations. The body of a presentation method is surrounded with a block of the same name as the presentation method, not just the magic internal name. The method by which presentation type parameters and options are decoded for the method bodies is a bit different from real CLIM. In particular, you cannot refer to the type parameters and options in the lambda list of the method. The NIL value of presentation-single-box is now supported. Presentation type histories are now partially implemented. The gesture C-M-y should recall the last entered presentation. define-drag-and-drop-translator is now implemented. Chapter 24 Input Editing and Completion Facilities with-input-editor-typeout is not implemented. The noise strings produced by input-editor-format and the strings produced by presentation-replace-input are not read-only. This could lead to interesting "issues" if the user edits them. Only a few of the suggested editing commands are implemented. An additional command that is implemented is control-meta-B, which drops into the debugger. add-input-editor-command is not implemented. with-accept-help is not implemented. Chapter 25 Menu Facilities The protocol is implemented, but McCLIM doesn't use it to draw command table menus. Chapter 26 Dialog Facilities McCLIM contains a basic, somewhat buggy implementation of accepting-values. There is little user feedback as to what has been accepted in a dialog. The user has to press the "OK" button to exit the dialog; there are no short cuts. There are no special accept-present-default methods for member or subset presentation types. Command-buttons are not implemented. There is no gadget-based implementation of accepting-values. The internal structure of accepting-values should be "culturally compatible" with real CLIM; if you have some spiffy hack, check the source. :own-window is now supported in accepting-values. Chapter 27 Command Processing command-line-complete-input is not implemented (the functionality does exist in the accept method for command-name). display-command-table-menu and menu-choose-command-from-table are not implemented. Menu-command-parser is not implemented, though the functionality obviously is. Nothing is done about partial menu commands. There is no support for numeric arguments. The command-or-form presentation type is not implemented. Chapter 28 Application Frames raise-frame, bury-frame and notify-user are not implemented. :accept-values panes are not implemented. frame-maintain-presentation-histories is not implemented. frame-drag-and-drop-feedback and frame-drag-and-drop-highlighting are now implemented. execute-frame-command ignores the possibility that frame and the current frame might be different. display-command-menu isn't implemented. Chapter 29 Panes Due to the way the space-allocation protocol is implemented, it is not easy to create application-specific layout-panes. Client code needs to know about :AROUND methods to compose-space, but they are not mentioned in the spec. restraining-pane is partially implemented. Chapter 30 Gadgets This chapter is implemented. with-output-as-gadget is not quite working yet, but it was improved since the last release.cl-mcclim-0.9.6.dfsg.cvs20100315.orig/ReleaseNotes/0-9-6-st-george's-day0000644000175000017500000000500411003617446022663 0ustar pdmpdmRELEASE NOTES FOR McCLIM 0.9.6, "St. George's Day": Compatibility ============= This release was tested and found to work on the following implementations: * SBCL * CMUCL 19d * Clozure CL 1.2 (RC 1) * CLISP 2.41 (requires "Telent" CLX) * Allegro Common Lisp 8.1 in ANSI Mode McCLIM currently does not support lisps with case-sensitive readers (Allegro CL "modern mode" and lower-case Scieneer CL). To run McCLIM on Mac OS X 10.5, it is currently necessary to pass an explicit DISPLAY argument to work around incompatibility between Leopard's X11 auto-start facility and CLX. Changes in mcclim-0.9.6 "St. George's Day" relative to 0.9.5: ============================================================== From the NEWS file: * New extension: mcclim-truetype: provides a 100% lisp path for AA fonts with CLX using cl-vectors and zpb-ttf, as an alternative to mcclim-freetype. * Improvement: Faster drawing and AA text rendering. AA text requires a fix to the Xrender support of CLX, available in Christophe Rhodes's current CLX distribution from darcs. * Improvement: Look up arbitrary truetype fonts by name via fontconfig. * Drei improvements ** New redisplay engine that is faster and has more features. ** Support for "views" concept. ** Support for modes a la Emacs "mini-modes". ** Improvement: Goal-columns for line movement. ** Improvement: More Emacs-like expression movement for Lisp syntax. ** Bug fix: Input prompting now works for directly recursive calls to ACCEPT. * Specification compliance: READ-BITMAP-FILE and MAKE-PATTERN-FROM-BITMAP-FILE from CLIM 2.2. Includes new example program, IMAGE-VIEWER. * Specification compliance: The :inherit-menu keyword argument to DEFINE-COMMAND-TABLE and MAKE-COMMAND-TABLE is now implemented with CLIM 2.2 semantics. The :keystrokes value is not handled yet. * Specification compliance: :PRINTER functions for MENU-CHOOSE are now called with the menu item, not the display object. * Bug fix: ESA's help commands are better at finding bindings and describing them * Bug fix: Some missing methods and functions have been implemented for the Null backend, allowing headless operation for many applications. * Bug fix: correct computation of bounding rectangle after clear-output-record and recompute-extent-for-new-child. * Bug fix: label panes no longer have a restrictive maximum width. * Bug fix: ellipses with a zero radius no longer cause errors. * Bug fix: bezier drawing in CLIM-FIG less likely to cause errors. * Bug fix: restored somewhat working undo in CLIM-FIG. cl-mcclim-0.9.6.dfsg.cvs20100315.orig/text-formatting.lisp0000644000175000017500000001526411345155772021046 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2002 by Alexey Dejneka (adejneka@comail.ru) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) (defun format-textual-list (sequence printer &key stream separator conjunction suppress-separator-before-conjunction suppress-space-after-conjunction) "Outputs the SEQUENCE of items as a \"textual list\" into STREAM. PRINTER is a function of an item and a stream. Between each two items the string SEPARATOR is placed. If the string CONJUCTION is supplied, it is placed before the last item. SUPPRESS-SEPARATOR-BEFORE-CONJUNCTION and SUPPRESS-SPACE-AFTER-CONJUNCTION are non-standard." (orf stream *standard-output*) (orf separator ", ") (let* ((length (length sequence)) (n-rest length)) (map-repeated-sequence nil 1 (lambda (item) (funcall printer item stream) (decf n-rest) (cond ((> n-rest 1) (princ separator stream)) ((= n-rest 1) (if conjunction (progn (unless suppress-separator-before-conjunction (princ separator stream)) (princ conjunction stream) (unless suppress-space-after-conjunction (princ #\space stream))) (princ separator stream))))) sequence))) ;;; filling-output support (defclass filling-stream (standard-encapsulating-stream extended-output-stream output-recording-stream) ((fill-width :accessor fill-width :initarg :fill-width) (break-characters :accessor break-characters :initarg :break-characters :initform '(#\Space)) (after-line-break :accessor after-line-break :initarg :after-line-break))) ;;; parse-space is from table-formatting.lisp (defmethod initialize-instance :after ((obj filling-stream) &key (fill-width '(80 :character))) (setf (fill-width obj) (parse-space (encapsulating-stream-stream obj) fill-width :horizontal))) (defmethod stream-write-char :around ((stream filling-stream) char) (let ((under-stream (encapsulating-stream-stream stream))) (if (and (member char (break-characters stream) :test #'char=) (> (stream-cursor-position under-stream) (fill-width stream))) (progn (stream-write-char under-stream #\newline) (when (slot-boundp stream 'after-line-break) (write-string (after-line-break stream) (encapsulating-stream-stream stream)))) (call-next-method)))) (defmethod stream-write-string :around ((stream filling-stream) string &optional (start 0) end) (dotimes (i (- (or end (length string)) start)) (stream-write-char stream (aref string (+ i start))))) ;;; All the monkey business with the lambda form has to do with capturing the ;;; keyword arguments of the macro while preserving the user's evaluation order. (defmacro filling-output ((stream &rest args &key fill-width break-characters after-line-break after-line-break-initially) &body body) (when (eq stream t) (setq stream '*standard-output*)) (with-gensyms (fill-var break-var after-var initially-var) `((lambda (&key ((:fill-width ,fill-var)) ((:break-characters ,break-var)) ((:after-line-break ,after-var)) ((:after-line-break-initially ,initially-var))) (declare (ignorable ,fill-var ,break-var ,after-var ,initially-var)) (let ((,stream (make-instance 'filling-stream :stream ,stream ,@(and fill-width `(:fill-width ,fill-var)) ,@(and break-characters `(:break-characters ,break-var)) ,@(and after-line-break `(:after-line-break ,after-var))))) ,(unless (null after-line-break-initially) `(when ,initially-var (write-string ,after-var ,stream))) ,@body)) ,@args))) ;;; indenting-output (defclass indenting-output-stream (standard-encapsulating-stream extended-output-stream output-recording-stream) ((indentation :accessor indentation))) (defmethod initialize-instance :after ((obj indenting-output-stream) &key (indent-spec 0) &allow-other-keys) (setf (indentation obj) (parse-space (encapsulating-stream-stream obj) indent-spec :horizontal))) (defmethod stream-write-char :around ((stream indenting-output-stream) char) (let ((under-stream (encapsulating-stream-stream stream))) (when (stream-start-line-p under-stream) (stream-increment-cursor-position under-stream (indentation stream) nil)) (call-next-method))) (defmethod stream-write-string :around ((stream indenting-output-stream) string &optional (start 0) end) (let ((under-stream (encapsulating-stream-stream stream)) (end (or end (length string)))) (flet ((foo (start end) (when (stream-start-line-p under-stream) (stream-increment-cursor-position under-stream (indentation stream) nil)) (stream-write-string under-stream string start end))) (let ((seg-start start)) (loop for i from start below end do (when (char= #\Newline (char string i)) (foo seg-start (1+ i)) (setq seg-start (1+ i)))) (foo seg-start end))))) (defmacro indenting-output ((stream indent &key (move-cursor t)) &body body) (when (eq stream t) (setq stream '*standard-output*)) (with-gensyms (old-x old-y) `(multiple-value-bind (,old-x ,old-y) (stream-cursor-position ,stream) (let ((,stream (make-instance 'indenting-output-stream :stream ,stream :indent-spec ,indent))) ,@body) (unless ,move-cursor (setf (stream-cursor-position ,stream) (values ,old-x ,old-y)))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Lisp-Dep/0000755000175000017500000000000011347763424016427 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Lisp-Dep/fix-clisp.lisp0000640000175000017500000000201510561555374021210 0ustar pdmpdm(defpackage #:clim-mop (:use #:clos)) (eval-when (:compile-toplevel :load-toplevel :execute) (loop for sym being the symbols of :clim-mop do (export sym :clim-mop))) ;; CLIM expects INPUT-STREAM-P to be a generic function. (ext:without-package-lock ("GRAY" "COMMON-LISP") (unless (typep #'input-stream-p 'generic-function) (setf (fdefinition (intern "ORIGINAL-INPUT-STREAM-P" (find-package :gray))) #'input-stream-p) (fmakunbound 'input-stream-p) (defgeneric input-stream-p (stream) (:method ((stream stream)) (funcall (fdefinition (intern "ORIGINAL-OUTPUT-STREAM-P" (find-package :gray))) stream)))) ;; CLIM expects OUTPUT-STREAM-P to be a generic function. (unless (typep #'output-stream-p 'generic-function) (setf (fdefinition (intern "ORIGINAL-OUTPUT-STREAM-P" (find-package :gray))) #'output-stream-p) (fmakunbound 'output-stream-p) (defgeneric output-stream-p (stream) (:method ((stream stream)) (funcall (fdefinition (intern "ORIGINAL-OUTPUT-STREAM-P" (find-package :gray))) stream))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Lisp-Dep/mp-sbcl.lisp0000644000175000017500000001730511345155773020663 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-INTERNALS; -*- ;;; --------------------------------------------------------------------------- ;;; Title: CLIM-2, Chapter 32.2 Multi-processing ;;; for SBCL ;;; Created: 2003-02-22 ;;; Author: Daniel Barlow ;;; Based on mp-acl, created 2001-05-22 by Gilbert Baumann ;;; License: LGPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2001 by Gilbert Baumann ;;; (c) copyright 2002 by John Wiseman (jjwiseman@yahoo.com) ;;; (c) copyright 2003 by Daniel Barlow ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :CLIM-INTERNALS) (defconstant *multiprocessing-p* t) (eval-when (:load-toplevel :compile-toplevel :execute) (pushnew :clim-mp *features*)) (defstruct (process (:constructor %make-process) (:predicate processp)) name state whostate function thread) (defun make-current-process () (%make-process :name (sb-thread:thread-name sb-thread:*current-thread*) :function nil :thread sb-thread:*current-thread*)) (defvar *current-process* (make-current-process)) (defvar *all-processes* (list *current-process*) "A list of processes created by McCLIM, plus the one that was running when this file was loaded.") (defun reinit-processes () (setf *current-process* (make-current-process)) (setf *all-processes* (list *current-process*))) (push 'reinit-processes sb-ext:*init-hooks*) (defvar *all-processes-lock* (sb-thread:make-mutex :name "Lock around *ALL-PROCESSES*")) ;; we implement disable-process by making the disablee attempt to lock ;; *permanent-queue*, which is already locked because we locked it ;; here. enable-process just interrupts the lock attempt. (defvar *permanent-queue* (sb-thread:make-mutex :name "Lock for disabled threads")) (unless (sb-thread:mutex-value *permanent-queue*) (sb-thread:get-mutex *permanent-queue* nil)) (defun make-process (function &key name) (let ((p (%make-process :name name :function function))) (restart-process p))) (defun restart-process (p) (labels ((boing () (let ((*current-process* p)) (sb-thread:with-mutex (*all-processes-lock*) (pushnew p *all-processes*)) (unwind-protect (funcall (process-function p)) (sb-thread:with-mutex (*all-processes-lock*) (setf *all-processes* (delete p *all-processes*))))))) (when (process-thread p) (sb-thread:terminate-thread p)) (when (setf (process-thread p) (sb-thread:make-thread #'boing :name (process-name p))) p))) (defun destroy-process (process) (sb-thread:terminate-thread (process-thread process))) (defun current-process () (if (eq (process-thread *current-process*) sb-thread:*current-thread*) *current-process* (setf *current-process* (or (find sb-thread:*current-thread* *all-processes* :key #'process-thread) ;; Don't add this to *all-processes*, because we don't ;; control it. (%make-process :name (sb-thread:thread-name sb-thread:*current-thread*) :function nil :thread sb-thread:*current-thread*))))) (defun all-processes () ;; we're calling DELETE on *ALL-PROCESSES*. If we look up the value ;; while that delete is executing, we could end up with nonsense. ;; Better use a lock (or call REMOVE instead in DESTROY-PROCESS). (sb-thread:with-mutex (*all-processes-lock*) *all-processes*)) ;;; people should be shot for using these, honestly. Use a queue! (declaim (inline yield)) (defun yield () (declare (optimize speed (safety 0))) (sb-alien:alien-funcall (sb-alien:extern-alien "sched_yield" (function sb-alien:int))) (values)) (defun process-wait (reason predicate) (let ((old-state (process-whostate *current-process*))) (unwind-protect (progn (setf old-state (process-whostate *current-process*) (process-whostate *current-process*) reason) (loop (let ((it (funcall predicate))) (when it (return it))) ;(sleep .01) (yield))) (setf (process-whostate *current-process*) old-state)))) (defun process-wait-with-timeout (reason timeout predicate) (let ((old-state (process-whostate *current-process*)) (end-time (+ (get-universal-time) timeout))) (unwind-protect (progn (setf old-state (process-whostate *current-process*) (process-whostate *current-process*) reason) (loop (let ((it (funcall predicate))) (when (or (> (get-universal-time) end-time) it) (return it))) ;(sleep .01))) (yield))) (setf (process-whostate *current-process*) old-state)))) (defun process-interrupt (process function) (sb-thread:interrupt-thread (process-thread process) function)) (defun disable-process (process) (sb-thread:interrupt-thread (process-thread process) (lambda () (catch 'interrupted-wait (sb-thread:get-mutex *permanent-queue*))))) (defun enable-process (process) (sb-thread:interrupt-thread (process-thread process) (lambda () (throw 'interrupted-wait nil)))) (defun process-yield () (sleep .1)) ;;; FIXME but, of course, we can't. Fix whoever wants to use it, ;;; instead (defmacro without-scheduling (&body body) `(progn ,@body)) (defparameter *atomic-lock* (sb-thread:make-mutex :name "atomic incf/decf")) (defmacro atomic-incf (place) `(sb-thread:with-mutex (*atomic-lock*) (incf ,place))) (defmacro atomic-decf (place) `(sb-thread:with-mutex (*atomic-lock*) (decf ,place))) ;;; 32.3 Locks (defun make-lock (&optional name) (sb-thread:make-mutex :name name)) (defmacro with-lock-held ((place &optional state) &body body) (let ((old-state (gensym "OLD-STATE"))) `(let (,old-state) (unwind-protect (progn (sb-thread:get-mutex ,place) (when ,state (setf ,old-state (process-state *current-process*)) (setf (process-state *current-process*) ,state)) ,@body) (setf (process-state *current-process*) ,old-state) (sb-thread::release-mutex ,place))))) (defun make-recursive-lock (&optional name) (sb-thread:make-mutex :name name)) (defmacro with-recursive-lock-held ((place &optional state) &body body) (let ((old-state (gensym "OLD-STATE"))) `(sb-thread:with-recursive-lock (,place) (let (,old-state) (unwind-protect (progn (when ,state (setf ,old-state (process-state *current-process*)) (setf (process-state *current-process*) ,state)) ,@body) (setf (process-state *current-process*) ,old-state)))))) (defun make-condition-variable () (sb-thread:make-waitqueue)) (defun condition-wait (cv lock &optional timeout) (if timeout (handler-case (sb-ext:with-timeout timeout (sb-thread:condition-wait cv lock) t) (sb-ext:timeout (c) (declare (ignore c)) nil)) (progn (sb-thread:condition-wait cv lock) t))) (defun condition-notify (cv) (sb-thread:condition-notify cv)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Lisp-Dep/mp-nil.lisp0000640000175000017500000001014410561555374020510 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-INTERNALS; -*- ;;; --------------------------------------------------------------------------- ;;; Title: CLIM-2, Chapter 32.2 Multi-processing ;;; for single processing Lisps ;;; Created: 2001-05-22 ;;; Author: Gilbert Baumann ;;; License: LGPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2001 by Gilbert Baumann ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) ;;; No multi-processing here (defconstant *multiprocessing-p* nil) (defun make-process (function &key name) (declare (ignore function name)) (error "No ~S here." 'make-process)) (defun destroy-process (process) (declare (ignore process)) (error "Huh?")) (defun current-process () nil) (defun all-processes () nil) (defun processp (object) (declare (ignore object)) nil) (defun process-name (process) (declare (ignore process)) nil) (defun process-state (process) (declare (ignore process)) nil) (defun process-whostate (process) (declare (ignore process))) (defun process-wait (reason predicate) (declare (ignore reason)) (loop until (funcall predicate))) (defun process-wait-with-timeout (reason timeout predicate) (declare (ignore reason)) (let ((end-time (+ (get-internal-real-time) (round (* timeout internal-time-units-per-second))))) (loop until (or (funcall predicate) (> (get-internal-real-time) end-time))))) (defun process-yield () nil) (defun process-interrupt (process function) (declare (ignore process)) (funcall function)) (defun disable-process (process) (declare (ignore process)) (error "Huh?!")) (defun enable-process (process) (declare (ignore process)) (error "Huh?!")) (defun restart-process (process) (declare (ignore process)) (error "Huh?!")) (defmacro without-scheduling (&body body) `(progn ,@body)) (defmacro atomic-incf (place) `(incf (the fixnum ,place))) (defmacro atomic-decf (place) `(decf (the fixnum ,place))) ;;; 32.3 Locks (defun make-lock (&optional name) (declare (ignore name)) (list nil)) (defmacro with-lock-held ((place &optional state) &body body) (declare (ignore place state)) `(progn ,@body)) (defun make-recursive-lock (&optional name) (declare (ignore name)) (list nil)) (defmacro with-recursive-lock-held ((place &optional state) &body body) (declare (ignore place state)) `(progn ,@body)) ;;; This is a bit dodgy; it depends on the condition notifier to be ;;; called from process-next-event. However, I don't feel obligated ;;; to put too much work into CLIM-SYS on non-multiprocessing platforms. (defun make-condition-variable () (list nil)) (defun condition-wait (cv lock &optional timeout) (declare (ignore lock)) (flet ((wait-func () (loop for port in climi::*all-ports* ;; this is dubious do (loop as this-event = (process-next-event port :timeout 0) for got-events = this-event then (or got-events this-event) while this-event finally (unless got-events (process-next-event port)))) (car cv))) (setf (car cv) nil) (if timeout (process-wait-with-timeout "Waiting for event" timeout #'wait-func) (process-wait "Waiting for event" #'wait-func)))) (defun condition-notify (cv) (setf (car cv) t)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Lisp-Dep/mp-acl.lisp0000600000175000017500000000772110423413315020451 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-INTERNALS; -*- ;;; --------------------------------------------------------------------------- ;;; Title: CLIM-2, Chapter 32.2 Multi-processing ;;; for ACL ;;; Created: 2001-05-22 ;;; Author: Gilbert Baumann ;;; License: LGPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2001 by Gilbert Baumann ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) (defconstant *multiprocessing-p* t) (eval-when (:load-toplevel :compile-toplevel :execute) (pushnew :clim-mp *features*)) (defun make-process (function &key name) (mp:process-run-function name function)) (defun destroy-process (process) (mp:process-kill process)) (defun current-process () sys:*current-process*) (defun all-processes () sys:*all-processes*) (defun processp (object) (typep object 'mp:process)) (defun process-name (process) (mp:process-name process)) (defun process-state (process) (declare (ignore process)) ;; Hmm can we somehow gain useful information here? nil) (defun process-whostate (process) (mp:process-whostate process)) (defun process-wait (reason predicate) (mp:process-wait reason predicate)) (defun process-wait-with-timeout (reason timeout predicate) (mp:process-wait-with-timeout reason timeout predicate)) (defun process-yield () (mp:process-allow-schedule)) (defun process-interrupt (process function) (mp:process-interrupt process function)) (defun disable-process (process) (mp:process-add-arrest-reason process 'suspend)) (defun enable-process (process) (mp:process-revoke-arrest-reason process 'suspend)) (defun restart-process (process) (mp:process-reset process) ) (defmacro without-scheduling (&body body) `(mp:without-scheduling .,body)) ;; We perhaps could make use of EXCL::ATOMICALLY, which is ;; undocumented, but seems to do what we want. (defmacro atomic-incf (place) `(locally (declare (optimize (safety 1) (speed 3))) (excl::atomically (incf (the fixnum ,place))))) (defmacro atomic-decf (place) `(locally (declare (optimize (safety 1) (speed 3))) (excl::atomically (decf (the fixnum ,place))))) ;;; 32.3 Locks (defun make-lock (&optional name) (mp:make-process-lock :name name)) (defmacro with-lock-held ((place &optional state) &body body) `(mp:with-process-lock (,place :norecursive t ,@(if state (list :whostate state) nil)) .,body)) (defun make-recursive-lock (&optional name) (mp:make-process-lock :name name)) (defmacro with-recursive-lock-held ((place &optional state) &body body) `(mp:with-process-lock (,place ,@(if state (list :whostate state) nil)) .,body)) (defun make-condition-variable () (mp:make-gate nil)) ;;; Lock is held on entry (defun condition-wait (cv lock &optional timeout) (mp:close-gate cv) (mp:process-unlock lock) (unwind-protect (if timeout (mp:process-wait-with-timeout "Waiting on condition variable" timeout #'mp:gate-open-p cv) (progn (mp:process-wait "Waiting on condition variable" #'mp:gate-open-p cv) t)) (mp:process-lock lock))) (defun condition-notify (cv) (mp:open-gate cv)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Lisp-Dep/foreign-openmcl.lisp0000644000175000017500000000500410016355174022372 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-FFI -*- ;;; (c) copyright 2003 by Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Macros used to stack allocate memory, etc. when communicating ;;; with foreign code i.e., OpenGL. (in-package :clim-ffi) (eval-when (:compile-toplevel :load-toplevel :execute) (defun map-tree (func tree) (let ((car-result (if (atom (car tree)) (funcall func (car tree)) (map-tree func (car tree)))) (tail-result (if (null (cdr tree)) nil (map-tree func (cdr tree))))) (cons car-result tail-result))) (defun translate-typespec (typespec) (flet ((make-keyword (s) (if (and s (symbolp s)) (intern (symbol-name s) :keyword) s))) (if (atom typespec) (make-keyword typespec) (map-tree #'make-keyword typespec)))) ) (defmacro with-c-data ((bindings) &body body) (let ((rlet-bindings nil)) (loop for (var typespec . initforms) in bindings for mcl-typespec = (translate-typespec typespec) collect `(var mcl-typespec ,@initforms) into new-bindings finally (setq rlet-bindings new-bindings)) `(ccl:rlet ,rlet-bindings ,@body))) (defmacro with-c-strings ((bindings) &body body) `(ccl:with-cstrs ,bindings ,@body)) (defmacro null-pointer () `(ccl:%null-ptr)) (defmacro cref (pointer type &optional index) "Dereference the foreign POINTER of TYPE. Arrays can be accessed via INDEX." (let ((typespec (translate-typespec type))) (if (null index) `(ccl:pref ,pointer ,typespec) (let ((offset `(* ,index ,(ccl::%foreign-type-or-record-size typespec :bits)))) (destructuring-bind (type-name &rest accessors) (ccl::decompose-record-accessor typespec) (ccl::%foreign-access-form pointer (ccl::%foreign-type-or-record type-name) offset accessors)))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Lisp-Dep/fix-cmu.lisp0000644000175000017500000000300707522712077020666 0ustar pdmpdm(defpackage #:clim-mop (:use #:mop) (:shadowing-import-from #:pcl #:eql-specializer-object)) (eval-when (:compile-toplevel :load-toplevel :execute) (loop for sym being the symbols of :clim-mop do (export sym :clim-mop)) (loop for other-symbol in '("EQL-SPECIALIZER" "FUNCALLABLE-STANDARD-CLASS") unless (find-symbol other-symbol :clim-mop) do (let ((sym (intern other-symbol :pcl))) (import sym :clim-mop) (export sym :clim-mop)))) ;;; In CMUCL the Common Lisp versions of class-of and find-class ;;; return wrappers which the MOP can't grok, so use the PCL versions ;;; instead. (eval-when (:compile-toplevel :load-toplevel :execute) (flet ((reexport (symbols) (import symbols :clim-lisp-patch) (export symbols :clim-lisp-patch))) (reexport '(pcl:class-name pcl:class-of pcl:find-class pcl::standard-class))) (export '(clim-lisp-patch::defclass) :clim-lisp-patch)) (defvar clim-lisp-patch::*compile-time-clos-names* (make-hash-table)) (defun clim-lisp-patch::compile-time-clos-class-p (name) (gethash name clim-lisp-patch::*compile-time-clos-names* nil)) (defmacro clim-lisp-patch:defclass (name &rest args) `(progn (eval-when (:compile-toplevel) (setf (gethash ',name clim-lisp-patch::*compile-time-clos-names*) t)) ;; CMU's compiler barks much less this way (so the original ;; comment says; we should try turning this off in 18d. (eval-when (:compile-toplevel :load-toplevel :execute) (cl:defclass ,name ,@args)))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Lisp-Dep/fix-scl.lisp0000640000175000017500000001175310561555374020670 0ustar pdmpdm;;;; Support for the Scieneer Common Lisp. ;;;; Gray streams can be defined as subclass of the native stream classes. (in-package :ext) (export '(fundamental-stream fundamental-input-stream fundamental-output-stream fundamental-character-stream fundamental-binary-stream fundamental-character-input-stream fundamental-character-output-stream fundamental-binary-input-stream fundamental-binary-output-stream stream-read-line stream-start-line-p stream-write-string stream-terpri stream-fresh-line stream-advance-to-column ) :ext) (defclass fundamental-stream (stream) () (:documentation "Base class for all CLOS streams")) ;;; Define the stream classes. (defclass fundamental-input-stream (fundamental-stream ext:input-stream) ()) (defclass fundamental-output-stream (fundamental-stream ext:output-stream) ()) (defclass fundamental-character-stream (fundamental-stream ext:character-stream) ()) (defclass fundamental-binary-stream (fundamental-stream ext:binary-stream) ()) (defclass fundamental-character-input-stream (fundamental-input-stream fundamental-character-stream ext:character-input-stream) ()) (defclass fundamental-character-output-stream (fundamental-output-stream fundamental-character-stream ext:character-output-stream) ()) (defclass fundamental-binary-input-stream (fundamental-input-stream fundamental-binary-stream ext:binary-input-stream) ()) (defclass fundamental-binary-output-stream (fundamental-output-stream fundamental-binary-stream ext:binary-output-stream) ()) (defgeneric stream-read-line (stream) (:documentation "Used by 'read-line. A string is returned as the first value. The second value is true if the string was terminated by end-of-file instead of the end of a line. The default method uses repeated calls to 'stream-read-char.")) (defmethod stream-read-line ((stream fundamental-character-input-stream)) (let ((res (make-string 80)) (len 80) (index 0)) (loop (let ((ch (stream-read-char stream))) (cond ((eq ch :eof) (return (values (cl::shrink-vector res index) t))) (t (when (char= ch #\newline) (return (values (cl::shrink-vector res index) nil))) (when (= index len) (setq len (* len 2)) (let ((new (make-string len))) (replace new res) (setq res new))) (setf (schar res index) ch) (incf index))))))) (defgeneric stream-start-line-p (stream)) (defmethod stream-start-line-p ((stream fundamental-character-output-stream)) (eql (stream-line-column stream) 0)) (defgeneric stream-terpri (stream) (:documentation "Writes an end of line, as for TERPRI. Returns NIL. The default method does (STREAM-WRITE-CHAR stream #\NEWLINE).")) (defmethod stream-terpri ((stream fundamental-character-output-stream)) (stream-write-char stream #\Newline)) (defgeneric stream-fresh-line (stream) (:documentation "Outputs a new line to the Stream if it is not positioned at the begining of a line. Returns 't if it output a new line, nil otherwise. Used by 'fresh-line. The default method uses 'stream-start-line-p and 'stream-terpri.")) (defmethod stream-fresh-line ((stream fundamental-character-output-stream)) (unless (stream-start-line-p stream) (stream-terpri stream) t)) (defgeneric stream-advance-to-column (stream column) (:documentation "Writes enough blank space so that the next character will be written at the specified column. Returns true if the operation is successful, or NIL if it is not supported for this stream. This is intended for use by by PPRINT and FORMAT ~T. The default method uses STREAM-LINE-COLUMN and repeated calls to STREAM-WRITE-CHAR with a #\SPACE character; it returns NIL if STREAM-LINE-COLUMN returns NIL.")) (defmethod stream-advance-to-column ((stream fundamental-character-output-stream) column) (let ((current-column (stream-line-column stream))) (when current-column (let ((fill (- column current-column))) (dotimes (i fill) (stream-write-char stream #\Space))) t))) (defpackage :clim-mop (:use :clos)) (eval-when (:compile-toplevel :load-toplevel :execute) (loop for sym being the symbols of :clim-mop do (export sym :clim-mop))) (eval-when (:compile-toplevel :load-toplevel :execute) (export '(clim-lisp-patch::defconstant clim-lisp-patch::defclass) :clim-lisp-patch)) (defmacro clim-lisp-patch:defconstant (symbol value &optional docu) `(defvar ,symbol ,value ,@(and docu (list docu)))) (defvar clim-lisp-patch::*compile-time-clos-names* (make-hash-table)) (defun clim-lisp-patch::compile-time-clos-class-p (name) (gethash name clim-lisp-patch::*compile-time-clos-names* nil)) (defmacro clim-lisp-patch:defclass (name &rest args) `(progn (eval-when (:compile-toplevel) (setf (gethash ',name clim-lisp-patch::*compile-time-clos-names*) t)) (eval-when (:compile-toplevel :load-toplevel :execute) (cl:defclass ,name ,@args)))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Lisp-Dep/mp-lw.lisp0000644000175000017500000000664307712157177020370 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-INTERNALS; -*- ;;; --------------------------------------------------------------------------- ;;; Title: CLIM-2, Chapter 32.2 Multi-processing ;;; for ACL ;;; Created: 2001-05-22 ;;; Author: Gilbert Baumann ;;; License: LGPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2001 by Gilbert Baumann ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :CLIM-INTERNALS) (defconstant *multiprocessing-p* t) (eval-when (:load-toplevel :compile-toplevel :execute) (pushnew :clim-mp *features*)) (defun make-process (function &key name) (mp:process-run-function name () function)) (defun destroy-process (process) (mp:process-kill process)) (defun current-process () mp:*current-process*) (defun all-processes () (mp:list-all-processes)) (defun processp (object) (mp:process-p object)) (defun process-name (process) (mp:process-name process)) (defun process-state (process) (declare (ignore process)) ;; Hmm can we somehow gain useful information here? nil) (defun process-whostate (process) (mp:process-whostate process)) (defun process-wait (reason predicate) (mp:process-wait reason predicate)) (defun process-wait-with-timeout (reason timeout predicate) (mp:process-wait-with-timeout reason timeout predicate)) (defun process-yield () (mp:process-allow-scheduling)) (defun process-interrupt (process function) (mp:process-interrupt process function)) (defun disable-process (process) (mp:without-interrupts (setf (mp:process-arrest-reasons process) (pushnew 'suspend (mp:process-arrest-reasons process))))) (defun enable-process (process) (mp:without-interrupts (setf (mp:process-arrest-reasons process) (remove 'suspend (mp:process-arrest-reasons process))))) (defun restart-process (process) (mp:process-reset process)) (defmacro without-scheduling (&body body) `(mp:without-preemption .,body)) (defmacro atomic-incf (place) (declare (optimize (speed 3) (safety 1))) `(mp:without-interrupts (incf (the fixnum ,place)))) (defmacro atomic-decf (place) (declare (optimize (speed 3) (safety 1))) `(mp:without-interrupts(decf (the fixnum ,place)))) ;;; 32.3 Locks (defun make-lock (&optional name) (mp:make-lock :name name)) (defmacro with-lock-held ((place &optional state) &body body) `(mp:with-lock (,place ,@(if state (list :whostate state) nil)) .,body)) (defun make-recursive-lock (&optional name) (mp:make-lock :name name)) (defmacro with-recursive-lock-held ((place &optional state) &body body) `(mp:with-lock (,place ,@(if state (list :whostate state) nil)) .,body)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Lisp-Dep/fix-sbcl.lisp0000640000175000017500000000366210741375214021023 0ustar pdmpdm(in-package :cl-user) (eval-when (:compile-toplevel :execute) (when (find-package "SB-MOP") (pushnew :sb-mop *features*))) (eval-when (:compile-toplevel :load-toplevel :execute) (unless (find-package '#:clim-mop) (make-package '#:clim-mop :use '(#+sb-mop #:sb-mop #-sb-mop #:sb-pcl)) (shadowing-import 'sb-pcl::eql-specializer-object '#:clim-mop))) (eval-when (:compile-toplevel :load-toplevel :execute) (loop for sym being the symbols of :clim-mop do (export sym :clim-mop)) #-sb-mop (loop for other-symbol in '("EQL-SPECIALIZER" "FUNCALLABLE-STANDARD-CLASS") unless (find-symbol other-symbol :clim-mop) do (let ((sym (intern other-symbol :sb-pcl))) (import sym :clim-mop) (export sym :clim-mop)))) ;;; In SBCL the Common Lisp versions of CLASS-OF and FIND-CLASS used ;;; to return wrappers which the MOP couldn't grok. This has been fixed ;;; for some time, certainly in sbcl 0.9.4. #+nil (eval-when (:compile-toplevel :load-toplevel :execute) (flet ((reexport (symbols) (import symbols :clim-lisp-patch) (export symbols :clim-lisp-patch))) (reexport '(sb-pcl:class-name sb-pcl:class-of sb-pcl:find-class sb-pcl::standard-class)))) (eval-when (:compile-toplevel :load-toplevel :execute) (export '(clim-lisp-patch::defconstant clim-lisp-patch::defclass) :clim-lisp-patch)) (defmacro clim-lisp-patch:defconstant (symbol value &optional docu) `(defvar ,symbol ,value ,@(and docu (list docu)))) (defvar clim-lisp-patch::*compile-time-clos-names* (make-hash-table)) (defun clim-lisp-patch::compile-time-clos-class-p (name) (gethash name clim-lisp-patch::*compile-time-clos-names* nil)) (defmacro clim-lisp-patch:defclass (name &rest args) `(progn (eval-when (:compile-toplevel) (setf (gethash ',name clim-lisp-patch::*compile-time-clos-names*) t)) (cl:defclass ,name ,@args))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Lisp-Dep/fix-lispworks.lisp0000644000175000017500000000504407712157177022147 0ustar pdmpdm;;; -*- Mode: Lisp; Package: User -*- (in-package :common-lisp-user) (eval-when (:compile-toplevel :load-toplevel :execute) (setf *packages-for-warn-on-redefinition* (remove-if (lambda (p) (member p '("COMMON-LISP" "CLIM" "CLIM-INTERNALS" "CLIM-SYS" "CLIM-UTILS" "CLIM-LISP" "POSTSCRIPT-CLIM") :test #'equal)) *packages-for-warn-on-redefinition*))) (defpackage :clim-mop (:use :clos :common-lisp) (:export #:validate-superclass #:class-finalized-p #:finalize-inheritance #:class-prototype #:class-precedence-list #:class-direct-superclasses #:ensure-class #:funcallable-standard-class #:method-specializers #:generic-function-methods #:eql-specializer #:eql-specializer-object #:intern-eql-specializer #:compute-applicable-methods-using-classes)) (in-package :clim-mop) (defmethod compute-applicable-methods-using-classes (gf classes) (values nil nil)) (ignore-errors (defmethod validate-superclass (a b) T)) (ignore-errors (defmethod class-finalized-p (c) T)) (ignore-errors (defmethod finalize-inheritance (c) (values))) (deftype eql-specializer () '(satisfies eql-specializer-p)) (defun eql-specializer-object (spec) (cadr spec)) ;;; Pretty bogus, but should suit our purposes, whatever they are. (defparameter *eql-specializer-hash* (make-hash-table)) (defun intern-eql-specializer (object) (let ((eql-object (gethash object *eql-specializer-hash* nil))) (unless eql-object (setq eql-object (cons 'eql object)) (setf (gethash object *eql-specializer-hash*) eql-object)) eql-object)) (eval-when (:compile-toplevel :load-toplevel :execute) (do-external-symbols (sym :clos) (export sym :clim-mop))) (eval-when (:compile-toplevel :load-toplevel :execute) (export '(clim-lisp-patch::defclass) :clim-lisp-patch)) (defvar clim-lisp-patch::*compile-time-clos-names* (make-hash-table)) (defun clim-lisp-patch::compile-time-clos-class-p (name) (gethash name clim-lisp-patch::*compile-time-clos-names* nil)) (defmacro clim-lisp-patch:defclass (name &rest args) `(progn (eval-when (:compile-toplevel) (setf (gethash ',name clim-lisp-patch::*compile-time-clos-names*) t)) (cl:defclass ,name ,@args))) (defmethod clim-mop:class-direct-superclasses ((instance (eql *ptype-t-class*))) (list (find-class 'standard-object))) ;; scary.. cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Lisp-Dep/mp-cmu.lisp0000644000175000017500000000676610016474751020527 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-INTERNALS; -*- ;;; --------------------------------------------------------------------------- ;;; Title: CLIM-2, Chapter 32.2 Multi-processing ;;; for CMU ;;; Created: 2001-05-22 ;;; Author: Gilbert Baumann ;;; License: LGPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2001 by Gilbert Baumann ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :CLIM-INTERNALS) (defconstant *multiprocessing-p* t) (eval-when (:load-toplevel :compile-toplevel :execute) (pushnew :clim-mp *features*)) (defun make-lock (&optional name) (mp:make-lock name)) (defun make-recursive-lock (&optional name) (mp:make-lock name :kind :recursive)) (defmacro with-lock-held ((place &optional state) &body body) `(mp:with-lock-held (,place ,state) ,@body)) (defmacro with-recursive-lock-held ((place &optional state) &body body) `(mp:with-lock-held (,place ,state) ,@body)) ;;; condition variables, not actually part of CLIM-SYS but useful anyway (defstruct condition-variable (lock (make-lock "condition variable")) (value nil) (process-queue nil)) (defun %release-lock (lock) ; copied from with-lock-held in multiproc.lisp #+i486 (kernel:%instance-set-conditional lock 2 mp:*current-process* nil) #-i486 (when (eq (lock-process lock) mp:*current-process*) (setf (lock-process lock) nil))) (defun condition-wait (cv lock &optional timeout) (declare (ignore timeout)) ;For now (loop (let ((cv-lock (condition-variable-lock cv))) (with-lock-held (cv-lock) (when (condition-variable-value cv) (setf (condition-variable-value cv) nil) (return-from condition-wait t)) (setf (condition-variable-process-queue cv) (nconc (condition-variable-process-queue cv) (list mp:*current-process*))) (%release-lock lock)) (mp:process-add-arrest-reason mp:*current-process* cv) (let ((cv-val nil)) (with-lock-held (cv-lock) (setq cv-val (condition-variable-value cv)) (when cv-val (setf (condition-variable-value cv) nil))) (when cv-val (mp::lock-wait lock "waiting for condition variable lock") (return-from condition-wait t)))))) (defun condition-notify (cv) (with-lock-held ((condition-variable-lock cv)) (let ((proc (pop (condition-variable-process-queue cv)))) ;; The waiting process may have released the CV lock but not ;; suspended itself yet (when proc (loop for activep = (mp:process-active-p proc) while activep do (mp:process-yield)) (setf (condition-variable-value cv) t) (mp:process-revoke-arrest-reason proc cv)))) ;; Give the other process a chance (mp:process-yield)) ;; all other are handled by import in defpack.lisp cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Lisp-Dep/mp-openmcl.lisp0000644000175000017500000001116110261251036021350 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-INTERNALS; -*- ;;; --------------------------------------------------------------------------- ;;; Title: CLIM-2, Chapter 32.2 Multi-processing ;;; for ACL ;;; Created: 2001-05-22 ;;; Author: Gilbert Baumann ;;; License: LGPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2001 by Gilbert Baumann ;;; (c) copyright 2002 by John Wiseman (jjwiseman@yahoo.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :CLIM-INTERNALS) (defconstant *multiprocessing-p* t) (eval-when (:load-toplevel :compile-toplevel :execute) (pushnew :clim-mp *features*)) (defun make-process (function &key name) (ccl:process-run-function name function)) (defun destroy-process (process) (ccl:process-kill process)) (defun current-process () ccl:*current-process*) (defun all-processes () #-openmcl-native-threads ccl:*all-processes* #+openmcl-native-threads (ccl:all-processes)) (defun processp (object) (typep object 'ccl::process)) (defun process-name (process) (ccl:process-name process)) (defun process-state (process) (declare (ignore process)) ;; Hmm can we somehow gain useful information here? nil) (defun process-whostate (process) (ccl:process-whostate process)) (defun process-wait (reason predicate) (ccl:process-wait reason predicate)) (defun process-wait-with-timeout (reason timeout predicate) (ccl:process-wait-with-timeout reason timeout predicate)) (defun process-yield () (ccl:process-allow-schedule)) (defun process-interrupt (process function) (ccl:process-interrupt process function)) (defun disable-process (process) #-openmcl-native-threads (ccl:process-enable-arrest-reason process 'suspend) #+openmcl-native-threads (ccl:process-suspend process)) (defun enable-process (process) #-openmcl-native-threads (ccl:process-disable-arrest-reason process 'suspend) #+openmcl-native-threads (ccl:process-enable process)) (defun restart-process (process) (ccl:process-reset process) ) (defmacro without-scheduling (&body body) `(ccl:without-interrupts ,@body)) ;; We perhaps could make use of EXCL::ATOMICALLY, which is ;; undocumented, but seems to do what we want. ;; Use EXCL::ATOMICALLY in OpenMCL?? - mikemac #-openmcl-native-threads (defmacro atomic-incf (place) `(ccl:without-interrupts (incf (the fixnum ,place)))) #-openmcl-native-threads (defmacro atomic-decf (place) `(ccl:without-interrupts (decf (the fixnum ,place)))) #+openmcl-native-threads (defmacro atomic-incf (place) `(ccl::atomic-incf ,place)) #+openmcl-native-threads (defmacro atomic-decf (place) `(ccl::atomic-decf ,place)) ;;; 32.3 Locks (defun make-lock (&optional name) (ccl:make-lock name)) (defmacro with-lock-held ((place &optional state) &body body) #-openmcl-native-threads `(ccl:with-lock-grabbed (,place 'ccl:*current-process* ,@(if state (list state) nil)) ,@body) #+openmcl-native-threads `(ccl:with-lock-grabbed (,place ,@(if state (list state) nil)) ,@body)) (defun make-recursive-lock (&optional name) (ccl:make-lock name)) (defmacro with-recursive-lock-held ((place &optional state) &body body) `(with-lock-held (,place ,@(if state (list state) nil)) ,@body)) ;;; Condition variable simulation (defun make-condition-variable () (ccl:make-semaphore)) (defun condition-wait (cv lock &optional timeout) (let ((lock-error nil)) (unwind-protect (progn (handler-bind ((ccl::lock-not-owner #'(lambda (c) (declare (ignore c)) (setq lock-error t)))) (ccl:release-lock lock)) (if timeout (ccl:timed-wait-on-semaphore cv timeout) (ccl:wait-on-semaphore cv))) ;XXX nil here is some kind of error (unless lock-error ; We didn't have the lock. (ccl:grab-lock lock))))) (defun condition-notify (cv) (ccl:signal-semaphore cv)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Lisp-Dep/fix-openmcl.lisp0000640000175000017500000002024410561555374021537 0ustar pdmpdm;;; -*- Mode: Lisp; Package: User -*- ;;; (c) copyright 2002 by John Wiseman (jjwiseman@yahoo.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :cl-user) (export 'ccl::stream-finish-output :ccl) (defpackage :clim-mop #-openmcl-partial-mop (:use :common-lisp) #+openmcl-partial-mop (:use :openmcl-mop) #+openmcl-partial-mop (:import-from :ccl #:class-name #:eql-specializer) #-openmcl-partial-mop (:import-from :ccl #:class-prototype #:class-precedence-list #:class-direct-superclasses #:generic-function-methods #:method-specializers #:compute-applicable-methods #:funcallable-standard-class #:slot-definition-name) #-openmcl-partial-mop (:export #:validate-superclass #:class-finalized-p #:finalize-inheritance ccl::class-prototype ccl::class-precedence-list ccl::class-direct-superclasses ccl::generic-function-methods ccl::method-specializers ccl::compute-applicable-methods ccl::funcallable-standard-class #:slot-definition-name #:eql-specializer #:eql-specializer-object #:intern-eql-specializer ccl::ensure-class #:compute-applicable-methods-using-classes #:extract-specializer-names #:extract-lambda-list #:class-slots)) #+openmcl-partial-mop (eval-when (:compile-toplevel :load-toplevel :execute) (loop for sym being the symbols of :clim-mop do (export sym :clim-mop))) #-openmcl-partial-mop (in-package :clim-mop) #-openmcl-partial-mop (progn (defmethod validate-superclass (a b) T) (defmethod class-finalized-p (c) T) (defmethod finalize-inheritance (c) (values)) ;; MCL's eql-specializer-objects are just lists whose car is eql. (defun eql-specializer-p (spec) (and (consp spec) (eq (car spec) 'eql))) (deftype eql-specializer () '(satisfies eql-specializer-p)) (defun eql-specializer-object (spec) (cadr spec)) ;;; Pretty bogus, but should suit our purposes, whatever they are. (defparameter *eql-specializer-hash* (make-hash-table)) (defun intern-eql-specializer (object) (let ((eql-object (gethash object *eql-specializer-hash* nil))) (unless eql-object (setq eql-object (cons 'eql object)) (setf (gethash object *eql-specializer-hash*) eql-object)) eql-object)) (defun ensure-class (name &rest all-keys &key name metaclass direct-superclasses &allow-other-keys) (let ((metaclass-options (copy-list all-keys))) (remf metaclass-options :name) (remf metaclass-options :metaclass) (remf metaclass-options :direct-superclasses) (ccl::%defclass name direct-superclasses '() '() nil '() metaclass :metaclass-opts metaclass-options))) (defun extract-specializer-names (lambda-list) (loop for var in lambda-list until (member var lambda-list-keywords :test #'eq) collect (if (consp var) (cadr var) t))) (defun extract-lambda-list (lambda-list) (loop for tail on lambda-list for (var) = tail until (member var lambda-list-keywords :test #'eq) collect (if (consp var) (car var) var) into required finally (return (nconc required tail)))) (defmethod class-slots ((class standard-class)) (append (ccl::class-instance-slots class) (ccl::class-class-slots class))) ) ; #-openmcl-partial-mop (defpackage :clim-lisp-patch (:use) (:export #:defclass)) (defvar clim-lisp-patch::*compile-time-clos-names* (make-hash-table)) (defun clim-lisp-patch::compile-time-clos-class-p (name) (gethash name clim-lisp-patch::*compile-time-clos-names* nil)) (defmacro clim-lisp-patch:defclass (name &rest args) `(progn (eval-when (:compile-toplevel) (setf (gethash ',name clim-lisp-patch::*compile-time-clos-names*) t)) (eval-when (:compile-toplevel :load-toplevel :execute) (cl:defclass ,name ,@args)))) #-openmcl-partial-mop (in-package :ccl) #-openmcl-partial-mop (let ((*warn-if-redefine-kernel* NIL)) (defun %defclass (class-name superclasses instance-slotds class-slotds doc default-initargs metaclass &key primary-p metaclass-opts) (if (null superclasses) (setq superclasses (list 'standard-object)) (setq superclasses (copy-list superclasses))) (if (null metaclass) (setq metaclass *standard-class-class*)) (if (symbolp metaclass) (setq metaclass (find-class metaclass))) (unless (subclassp metaclass *std-class-class*) (error "~s is not a subclass of ~s" metaclass *std-class-class*)) (let* ((old-class (find-class class-name nil)) (class (or old-class (let* ((c (if (or (eq metaclass *standard-class-class*) (eq metaclass *funcallable-standard-class-class*)) (%cons-standard-class class-name (%class-own-wrapper metaclass)) (apply #'make-instance metaclass :name class-name metaclass-opts)))) (setf (%class-ctype c) (make-class-ctype c)) c)))) (when (eq class *standard-object-class*) (error "Cannot redefine ~S" class)) (unless (eq (class-of class) metaclass) (cerror (format nil "(~s '~s '~s)" 'change-class class metaclass) "~s is not an instance of ~s" class metaclass) (change-class class metaclass)) ; (s)he asked for it. (setf (find-class class-name) class) (labels ((obsolete (class) (dolist (sub (%class-subclasses class)) (obsolete sub)) ;Need to save old class info in wrapper for obsolete instance access... (setf (%class-cpl class) nil) (make-instances-obsolete class))) (without-interrupts (obsolete class) (dolist (sup (%class-local-supers class)) (if (typep sup 'class) ; might be a symbol from earlier forward ref (setf (%class-subclasses sup) (nremove class (%class-subclasses sup))))) (setf (%class-local-supers class) superclasses) (setf (%class-local-instance-slotds class) instance-slotds) (setf (%old-class-local-shared-slotds class) (%class-local-shared-slotds class)) (setf (%class-local-shared-slotds class) class-slotds) (setf (%class-local-default-initargs class) default-initargs))) (setf (%class-primary-p class) primary-p) (when doc (setf (documentation class 'type) doc)) (record-source-file class-name 'class) (initialize-class class t) class))) ;;; Fake compute-applicable-methods-using-classes, for the Show ;;; Applicable Methods command in the listener. #+openmcl-partial-mop (in-package :ccl) #+openmcl-partial-mop (progn (defgeneric compute-applicable-methods-using-classes (gf args)) (defmethod compute-applicable-methods-using-classes ((gf standard-generic-function) args) (let* ((methods (%gf-methods gf)) (args-length (length args)) (bits (inner-lfun-bits gf)) arg-count res) (when methods (setq arg-count (length (%method-specializers (car methods)))) (unless (<= arg-count args-length) (error "Too few args to ~s" gf)) (unless (or (logbitp $lfbits-rest-bit bits) (logbitp $lfbits-restv-bit bits) (logbitp $lfbits-keys-bit bits) (<= args-length (+ (ldb $lfbits-numreq bits) (ldb $lfbits-numopt bits)))) (error "Too many args to ~s" gf)) (let ((cpls (make-list arg-count))) (declare (dynamic-extent cpls)) (do* ((args-tail args (cdr args-tail)) (cpls-tail cpls (cdr cpls-tail))) ((null cpls-tail)) (setf (car cpls-tail) (%class-precedence-list (car args-tail)))) (dolist (m methods) (when (find-if #'(lambda (spec) (typep spec 'eql-specializer)) (%method-specializers m)) (return-from compute-applicable-methods-using-classes (values nil nil))) (if (%method-applicable-p m args cpls) (push m res))) (values (sort-methods res cpls (%gf-precedence-list gf)) t)))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Lisp-Dep/fix-acl.lisp0000600000175000017500000001267010423413315020622 0ustar pdmpdm;;; -*- Mode: Lisp; Package: User -*- (in-package :common-lisp-user) ;;; Needed to keep ACL from issuing warnings about toplevel (shadow ...) forms (setq comp:*cltl1-compile-file-toplevel-compatibility-p* nil) (eval-when (:compile-toplevel :load-toplevel :execute) (require :loop) (require :mop)) (defpackage :clim-mop (:use :clos :common-lisp) (:export #:accessor-method-slot-definition #:add-dependent #:add-direct-method #:add-direct-subclass #:add-method #:allocate-instance #:built-in-class #:class #:class-default-initargs #:class-direct-default-initargs #:class-direct-slots #:class-direct-subclasses #:class-direct-superclasses #:class-finalized-p #:class-name #:class-precedence-list #:class-prototype #:class-slots #:compute-applicable-methods #:compute-applicable-methods-using-classes #:compute-class-precedence-list #:compute-default-initargs #:compute-discriminating-function #:compute-effective-method #:compute-effective-slot-definition #:compute-slots #:direct-slot-definition #:direct-slot-definition-class #:effective-slot-definition #:effective-slot-definition-class #:ensure-class #:ensure-class-using-class #:ensure-generic-function #:ensure-generic-function-using-class #:eql-specializer #:eql-specializer-object #:extract-lambda-list #:extract-specializer-names #:finalize-inheritance #:find-method-combination #:forward-referenced-class #:funcallable-standard-class #:funcallable-standard-instance-access #:funcallable-standard-object #:function #:generic-function #:generic-function-argument-precedence-order #:generic-function-declarations #:generic-function-lambda-list #:generic-function-method-class #:generic-function-method-combination #:generic-function-methods #:generic-function-name #:intern-eql-specializer #:make-instance #:make-method-lambda #:map-dependents #:metaobject #:method #:method-combination #:method-function #:method-generic-function #:method-lambda-list #:method-qualifiers #:method-specializers #:reader-method-class #:remove-dependent #:remove-direct-method #:remove-direct-subclass #:remove-method #:set-funcallable-instance-function #:slot-boundp-using-class #:slot-definition #:slot-definition-allocation #:slot-definition-initargs #:slot-definition-initform #:slot-definition-initfunction #:slot-definition-location #:slot-definition-name #:slot-definition-readers #:slot-definition-type #:slot-definition-writers #:slot-makunbound-using-class #:slot-value-using-class #:specializer #:specializer-direct-generic-functions #:specializer-direct-methods #:standard-accessor-method #:standard-class #:standard-direct-slot-definition #:standard-effective-slot-definition #:standard-generic-function #:standard-instance-access #:standard-method #:standard-object #:standard-reader-method #:standard-slot-definition #:standard-writer-method #:update-dependent #:validate-superclass #:writer-method-class)) ;;;(eval-when (:compile-toplevel :load-toplevel :execute) ;;; (do-external-symbols (sym :clos) ;;; (export sym :clim-mop))) (eval-when (:compile-toplevel :load-toplevel :execute) (export '(clim-lisp-patch::defclass) :clim-lisp-patch)) (defvar clim-lisp-patch::*compile-time-clos-names* (make-hash-table)) (defun clim-lisp-patch::compile-time-clos-class-p (name) (gethash name clim-lisp-patch::*compile-time-clos-names* nil)) (defmacro clim-lisp-patch:defclass (name &rest args) `(progn (eval-when (:compile-toplevel) (setf (gethash ',name clim-lisp-patch::*compile-time-clos-names*) t)) (cl:defclass ,name ,@args))) #+nil (progn (eval-when (:compile-toplevel :load-toplevel :execute) (defvar clim-lisp-patch::*inline-functions* nil)) (defmacro clim-lisp-patch:declaim (&rest args) (dolist (arg args) (cond ((and (consp arg) (eq (car arg) 'inline)) (dolist (k (cdr arg)) (pushnew k clim-lisp-patch::*inline-functions*))))) `(declaim ,@args) ) (defmacro clim-lisp-patch:defun (fun args &body body) (cond ((member fun clim-lisp-patch::*inline-functions*) (cond ((and (consp fun) (eq (car fun) 'setf)) (let ((fnam (intern (concatenate 'string "(SETF " (symbol-name (cadr fun)) ")") (symbol-package (cadr fun))))) `(progn (defsetf ,(cadr fun) (&rest ap) (new-value) (list* ',fnam new-value ap)) (defun ,fnam ,args .,body) (define-compiler-macro ,fnam (&rest .args.) (cons '(lambda ,args .,body) .args.))))) (t `(progn (defun ,fun ,args .,body) (define-compiler-macro ,fun (&rest .args.) (cons '(lambda ,args .,body) .args.)))))) (t `(defun ,fun ,args ,@body)))) ) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Lisp-Dep/mp-scl.lisp0000600000175000017500000000663710406115667020512 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: clim-internals; -*- ;;; --------------------------------------------------------------------------- ;;; Title: CLIM-2, Chapter 32.2 Multi-processing ;;; for the Scieneer Common Lisp ;;; Created: 2006-03-12 ;;; Author: Scieneer Pty Ltd ;;; Based on mp-acl, created 2001-05-22 by Gilbert Baumann ;;; License: LGPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2006 by Scieneer Pty Ltd ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) (defconstant *multiprocessing-p* t) (eval-when (:load-toplevel :compile-toplevel :execute) (pushnew :clim-mp *features*)) (defun make-process (function &key name) (mp:make-process function :name name)) (defun restart-process (process) (mp:restart-process process)) (defun destroy-process (process) (mp:destroy-process process)) (defun current-process () (mp:current-process)) (defun all-processes () (mp:all-processes)) (defun processp (object) (mp:processp object)) (defun process-name (process) (mp:process-name process)) (defun process-state (process) (mp:process-state process)) (defun process-whostate (process) (mp:process-whostate process)) (defun process-wait (reason predicate) (mp:process-wait reason predicate)) (defun process-wait-with-timeout (reason timeout predicate) (mp:process-wait-with-timeout reason timeout predicate)) (defun process-yield () (mp:process-yield)) (defun process-interrupt (process function) (mp:process-interrupt process function)) (defun disable-process (process) (mp:disable-process process)) (defun enable-process (process) (mp:enable-process process)) (defmacro without-scheduling (&body body) `(mp:without-scheduling ,@body)) (defmacro atomic-incf (place) `(mp:atomic-incf ,place)) (defmacro atomic-decf (place) `(mp:atomic-decf ,place)) ;;; 32.3 Locks (defun make-lock (&optional name) (mp:make-lock name :type :error-check)) (defmacro with-lock-held ((place &optional state) &body body) `(mp:with-lock-held (,place (or ,state "Lock Wait")) ,@body)) (defun make-recursive-lock (&optional name) (mp:make-lock name :type :recursive)) (defmacro with-recursive-lock-held ((place &optional state) &body body) `(mp:with-lock-held (,place (or ,state "Lock Wait")) ,@body)) (defun make-condition-variable () (thread:make-cond-var)) (defun condition-wait (condition-variable lock &optional timeout) (cond (timeout (thread:cond-var-timedwait condition-variable lock timeout)) (t (thread:cond-var-wait condition-variable lock) t))) (defun condition-notify (condition-variable) (thread:cond-var-broadcast condition-variable)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Images/0000755000175000017500000000000011347763412016214 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Images/green-apple.ppm0000644000175000017500000001547207460531553021142 0ustar pdmpdmP6 # CREATOR: The GIMP's PNM Filter Version 1.0 48 48 255 þþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþÞÞÞúúúþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþÎÒËŠ‡r~nkvf“›öööþþþþþþþþþþþþþþþþþþþþþ®ª¢b\LMMMöööþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþ¶¾¶er`r‚fŠ–z’ler`er`¶º²þþþþþþþþþþþþþþþþþþ~zQ**)RRRîîîþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþòòòcn^kvf†–rŠ–z€Žpžt‚–ner`¶¾¶þþþþþþþþþþþþââàb\L¾¾¾þþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþjt\jzb’lx†jr‚fp~bnybp~bp~gcn^¶º²þþþþþþþþþ¢ž’???þþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþ‚Ž~er`‹–fr‚fv‚jzŠj–¦zžt–¦z–¦z’lcn^Ž—„þþþþþþ~vj¾¾¾þþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþÞÞÖer`’lr‚fzŠj’¢zr‚fzŠjp~b`lZ`lZcn^`lZ`lZ‚Š~þþþhfb**)þþþþþþþþþÒÒо¾š¾¾¾¾¾¾Ëʾþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþy…rr‚fv‚j‚–njzb’¢zkvfer`kvf‚Š~ÉÊÈêêéÞÞÞŠ‡`lZ‚Š~jfZvvvþþþÎξ–’bŽ…[Œ~X†~V~zQxvLrrJ‚‚fšš†ââàþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþËÎËkvfv‚jzŠj†–rr~nŠ‡Š‡¶¶¶öööþþþþþþþþþþþþþþþ¶º²rznvvvŠ‡¶¬Š–ŽjšŽa–’b–Žj”Ž`“†[Œ~X‚}SxvLzrNhjDz~bËʾþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþnybx†jžty…rnybv‚j’¢zêêéþþþÙÚѪ¥Š‰‚V“†[“†[‰‚V¦žlª¥Šž–v–Žj¡–gžžm¥šk¦žl¥šk¡–gž’ešŠ`“†[‰‚V~~VrrJffAZ^;…rââàþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþ¶¾®x†j€Žpkvfpzj“›ææåþþþææ妛{“†[šŽa¦–h¥šk¥šk¥šk¥škªžpªžp¬¢r®¦t¬¢rµª{¬¢r¦žl¥šk¡–gž’ešŽaŠŠ\‰‚V‚}SrrJffAZ^;bf@ËÎËþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþŠ–zv‚jpzj¶º²òòòþþþþþþææå–ŽjšŠ`¦–h¦›{ªžpº®‚¼²„²¦x²¦xµª{µª{µª{º®‚²®|¶®~¶®~¬¢rªžp¥šk¦–hž’ešŠ`Ž…[‚}SrrJhjDbb>NR2WZ8¶º²þþþþþþþþþþþþþþþþþþþþþþþþþþþÎÒËv‚jÆÆÅþþþþþþþþþþþþþþþšŠ`ž’eªžpº®‚ÌŦßÚÅÙÒºÙҺº¼²„¼²„¼²„¼²„º¶‡¼²„¶²‚µª{ªªt¬¢rªžp¦–h¦–hšŽa“Š]‰‚VxvLhjDbb>RV6IR1NR2ææåþþþþþþþþþþþþþþþþþþþþþþþþÎÒËËÎËþþþþþþþþþþþþþþþ¶²šž’eªžpÊÂßÚÅêêéâÞËÙÒºÓϯ¶‹Â¶‹Â¶‹¾¶‰Â¶‹¾¶‰º¶‡¶²‚¶®~®ªv¬¢r¦žl¥šk¡–g¡–g“Š]‰‚V‚}SrrJffAWZ8NR2NR2rzZþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþÚÚÚš’d¦›{¶‹ÜÖÀæâÒæâÒÜÖÀÑʫƾ˜ÂºÆ¾˜ÂºÂ¶‹¾¶‰¾¶‰º¶‡¼²„²®|ªªtª¦s£¢m¦žl¥škž’ešŽa“Š]Œ~XxvLhjDZ^;NR2NR2WZ8¶º²þþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþ¦›{¡–g¬¢rÑÊ«ßÚÅæâÒÜÖÀâÞËƾ˜Æ¾˜ÑÊ«Æœ¾‘ºººº¶‡¶²‚²®|ªªtª¦s£¢m¦žlššgž’e”Ž`Ž…[Œ~XxzOrrJ^f?RV6NR2NV6nrJþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþÚÖÒ–Žjªžpº®‚ÜÖÀßÚÅÜÖÀßÚÅÎÆ¢ÊÂÎÆ¢ÎƢººº¾ºŠº¶‡º¶‡¶²‚®®xªªt£¢m¦žlžšiš–eš’d”Ž`Ž…[†~V~zQrrJbb>RV6IR1NR2JR7þþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþª¥ŠšŽaªžpÊÂßÚÅßÚÅÜÖÀÑÊ«ÓϯÊÂÆœƜ¾‘ºº¾ºŠº¶‡¶²‚¶®~®ªvª¦s¦¦pž¢jžšiš–ešŽa”Ž`‡†ZŒ~XxvLnvIbf@RV6IR1IR1IR1þþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþŠŠ\žšiª¦sÊÆ¢ÙÒºÙÒºÑÊ«ÓϯÆœƾ˜Æœ¾‘¾‘¾ºŠ¾ºŠ¾¶‰º¶‡¶²‚®®x®ªv¦ªs¦¦p£¢mžši–’b–’bŠŠ\‰‚V~zQxzOonGbf@RV6IR1BJ-EN/þþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþææå“Š]žšiª¦sËʾÓϯÎÆ¢ÎÆ¢ÊƢǖƾ˜Ç–¾ºÂº¾ºŠ¾ºŠº¶‡¶²‚®®x®ªvª¦s¦¦p£¢m™žhššg’–b”Ž`Ž…[‰‚V‚}SxvLnrJbf@RV6JN2FJ.EN/þþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþËʾ‹Ž^ž–v¬¢rÎÆ¢ÎƢƜƜ¾–¾ºÂ¾–º¾ºŠ¾ºŠº¶‡º¶‡¶²‚¶®~®®xªªt¦¦p¦¦pž¢jžši’–b–’b“Š]‡†Z‰‚V~zQrvLhnEYbF*>F*Âļþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþ‡†Z”Ž`žžm¤¦†®®º¶Ž²²€¬ª~®®®®²®|®®x®ªv®®x®®x®®xªªt¦ªs¢¦ož¢jššg’’aŽ’`†ŽZ‡†Z~†U~‚UxzOjrF^b=RZ9NV6FJ.BF,NV6þþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþ¤¦†ŠŠ\––fžžmª¥Š¬ª~®®ªªtªªtªªt®ªv®®x®®x®®xªªt¦ªsž¢j¢¦o™žh–še’–bŽ’`†ŽZ†ŠZ~†U~‚Uz~RjrFhnE^b=RV6BJ->J,>F*Ž—„þþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþÖÖÕ‚‚W’’a–šež¢j£¢s£¢s£¢s¦¦pªªt¦ªs¦¦p¦¦p¦ªs¦ªs¢¦o¦¦p™žh™žh–še’–bŽ’`ŠŠ\~†U‚‚Wz~RrzMhjDbb>NV6IR1BJ->J,>F*ÞÞÖþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþŠŠ\†ŠZ‹Ž^–šeššgž¢jžžmž¢jž¢j¢¦o¢¦o¦¦p¢¦o£¢mž¢j™žh™žh–še’–bŠ’_†ŽZ†ŽZ~‚UxzOnvIonGbf@YbB*>F*‚‚fþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþÚÚÚ‡†ZŠŠ\‹Ž^’–b––fššgžžmžžm™žhž¢jž¢jž¢jž¢j™žh™žh’’a’–b†ŽZ‚ŠY~†Uz‚Sv~QnvIhnEbjCYbB*>B*ÞÞÖþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþ¤¦†~‚U‡†Z†ŠZŠ’_‹–f’–b–šeššg–še–še™žh–še’–b‹–f†ŽZ†ŽZ‚ŠYz‚Sz~RrvLjrFhnE^f?bf@YbF*>F*kvfÞÞÖææåöööþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþêê釆Z~‚U~‚U‡†ZŠŠ\‹Ž^Š’_Š’_Š’_Š’_Š’_Š’_†ŽZ†ŽZ‚ŠY~‚Uz‚Sv~QrzMnvIjrFhnEbf@YbF*EN/††„šššªªª¾¾¾ÖÖÕîîîúúúþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþêê邆Yv~Q~‚U~‚U‚‚W‚†Y†ŠZ~†U~†Uz‚S~†Uz‚S~‚Uz‚SrzMnvIjrFnvIbjChjDbjCZf@YbF*>F*&*FFFrrr–––²²²ÖÖÕîîîúúúþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþÖÖÕ‚†YrvLxzOv~QxzOxzOz~Rz~Rv~QxzOnvInvIhnEjrFhjDhjDbjC^f?Zf@^f?ZbBV^>NV6EN/BJ-17"**)jjj¦¦¦ÆÆÅææåþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþææåxzOjrFjrFjrFjrFjrFjrFhnEhnEbjCbjC^f?^f?Zf@Zf@^f?YbNV6IR1BJ-8@(  ZZZ¦¦¦ÒÒÐþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþöööÎÒËnvIhnEhnEbjChjDbf@bjC^b=Z^;V^9V^9V^9YbV^>NV6IR1IR1>B* ???–––ÉÊÈþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþîîîÒÒÐvvv17"^b=YbNV6EN/...???rrr¢¢¢ÖÖÕþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþîîîÉÊÈžžž&* 8@(V^9V^9RZ9>F*  17"BJ-IR1RZ9RZ9IR117"  RRRvvvšššÆÆÅêêéþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþöööÚÚÚ²²²{~z888  FFFnnn††„¦¦¦ÆÆÅêêéúúúþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþîîîÚÖÒ²²²–––zzzFFF  **)RRRrrrŠŠŠ¢¢¢ÂÂÂÚÚÚîîîúúúþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþöööææåÖÖÕ¾¾¾¦¦¦ŠŠŠrrrZZZ888......**)**)  888RRRjjjzzz{~z–––®®®ÆÆÅÞÞÞîîîúúúþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþúúúòòòââàÖÖÕÉÊȲ²²¢¢¢ššš–––žžž¢¢¢¢¢¢žžžžžž¦¦¦¦¦¦²²²®®®®®®ººº¶¶¶¾¾¾ÂÂÂÒÒÐââàòòòúúúþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþúúúòòòòòòææåÞÞÞÚÚÚââàÞÞÞÞÞÞÞÞÞÚÚÚââàââàêêéêêéêêéîîîîîîîîîöööúúúþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþúúúúúúöööúúúúúúþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþþcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Images/green-apple-mask.ppm0000644000175000017500000001547207460531553022073 0ustar pdmpdmP6 # CREATOR: The GIMP's PNM Filter Version 1.0 48 48 255 üýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýüýýcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Looks/0000755000175000017500000000000011347763424016101 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Looks/pixie.lisp0000644000175000017500000015354511345155773020125 0ustar pdmpdm(in-package :clim-internals) ;;; ; ; This file is in transition, please don't fix it :] ; ; Much is left purposefully un-refactored until enough is reworked that it can be ; refactored into sensible subcomponents, without becoming a hodge-podge of random ; mixins (as opposed to a hodge-podge of sensible mixins :]) - BTS ; ; This especially applies to colour and event management :\ ; ; TODO: move the hardcoded color-settings into proper defaults ; ;;; ;;; TODO: Add units label to slider pane ;;; TODO: Matching repaint method for the list pane ;;; TODO: Is there a locking bug, and does it somehow involve pixie? ;;; (Or is my computer still haunted?) ;;; TODO: Colors of buttons in clim-fig are wrong (export '(pixie-look #+clx pixie/clx-look)) (defclass pixie-look (frame-manager) ()) #+clx (defclass pixie/clx-look (pixie-look clim-clx::clx-frame-manager) ()) (defun use-pixie () (setf *default-frame-manager* (make-instance 'pixie/clx-look :port (find-port)))) (defmacro define-pixie-gadget (abstract-type pixie-type &key (enabled t)) `(defmethod make-pane-1 ((fm pixie-look) (frame application-frame) (type (eql ',abstract-type)) &rest args) (declare (ignorable fm frame type args)) ,(if enabled `(apply #'make-instance ',pixie-type :frame frame :manager fm :port (port frame) args) `(call-next-method)))) ;; Let us please stop playing these stupid symbol games. #+NIL (defmethod make-pane-1 ((fm pixie-look) (frame application-frame) type &rest args) (apply #'make-instance (or (find-symbol (concatenate 'string "PIXIE-" (symbol-name type)) :climi) (find-symbol (concatenate 'string "PIXIE-" (symbol-name type) "-PANE") :climi) ; drop back to the built ins... (find-symbol (concatenate 'string (symbol-name type) "-PANE") :climi) type) :frame frame :manager fm :port (port frame) args)) ;;; Scroll button patterns (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter +pixie-arrow-pattern+ #2a((0 0 0 1 0 0 0) (0 0 1 1 1 0 0) (0 1 1 1 1 1 0) (1 1 1 1 1 1 1))) (flet ((rotate (array) (let ((new-array (make-array (reverse (array-dimensions array))))) (dotimes (i (array-dimension array 0)) (dotimes (j (array-dimension array 1)) (setf (aref new-array j (- (array-dimension array 0) i 1)) (aref array i j)))) new-array))) (let* ((up +pixie-arrow-pattern+) (right (rotate up)) (down (rotate right)) (left (rotate down))) (macrolet ((def (var) `(defparameter ,(intern (format nil "~A~A~A" (symbol-name '#:+pixie-) (symbol-name var) (symbol-name '#:-arrow+)) (find-package :climi)) (make-pattern ,var (list +transparent-ink+ +black+))))) (def up) (def right) (def down) (def left))))) ; Standard ; TODO - clean up all of this colour nonsense ; which should involve some sensible ideas about tints vs' inks (defclass pixie-gadget () ((highlighted :initarg :highlight :initform +gray93+ :reader pane-highlight) (paper-color :initarg :paper-color :initform +white+ :reader pane-paper-color) (inking-color :initarg :inking-color :initform +black+ :reader pane-inking-color) (foreground :initarg :foreground :initform +gray83+ :reader pane-foreground) (background :initarg :background :initform +gray76+ :reader pane-background))) ; Convenience (defun draw-up-box (pane x1 y1 x2 y2 foreground) (let ((x2 (- x2 1))) (draw-rectangle* pane x1 y1 x2 y2 :ink foreground) ;; white outline (draw-line* pane x1 y2 x1 y1 :ink +white+) (draw-line* pane x2 y1 x1 y1 :ink +white+) ;; now for the gray inline (let ((x1 (+ x1 1)) ; I'd prefer this be zero, so that there isn't (y1 (+ y1 1)) ; the little sparkling white pixel in both corners (x2 (- x2 1)) ; (bothersome in the corner of a scroller-pane), (y2 (- y2 1))) ; but we may be transformed, so too much work. Bah. (draw-line* pane x1 y2 x2 y2 :ink +gray54+) (draw-line* pane x2 y1 x2 y2 :ink +gray54+)) ;; now for the black outline (draw-line* pane x1 y2 x2 y2 :ink +black+) (draw-line* pane x2 y1 x2 y2 :ink +black+) (draw-label* pane x1 y1 x2 y2 :ink (pane-inking-color pane)))) (defun draw-down-box (pane x1 y1 x2 y2 foreground) (draw-rectangle* pane x1 y1 x2 y2 :ink foreground) ;; white outline (draw-line* pane x1 y2 x1 y1 :ink +gray58+) (draw-line* pane x2 y1 x1 y1 :ink +gray58+) ;; now for the black inline (let ((x1 (+ x1 1)) (y1 (+ y1 1)) (x2 (- x2 2)) (y2 (- y2 2))) (draw-line* pane x1 y1 (+ x2 1) y1 :ink +black+) (draw-line* pane x1 y1 x1 (+ y2 1) :ink +black+)) ;; now for the white outline (draw-line* pane x1 y2 x2 y2 :ink +white+) (draw-line* pane x2 y1 x2 y2 :ink +white+) (draw-label* pane x1 y1 x2 y2 :ink (pane-inking-color pane))) ; Highlighting (defmethod gadget-highlight-background ((gadget pixie-gadget)) +gray93+) (defmethod effective-gadget-foreground ((gadget pixie-gadget)) (if (slot-value gadget 'armed) +gray93+ +gray83+)) (defmethod effective-gadget-background ((gadget pixie-gadget)) (if (slot-value gadget 'armed) (gadget-highlight-background gadget) (pane-background gadget))) (defmethod effective-gadget-input-area-color ((gadget pixie-gadget)) +white+) (defclass draggable-arming-mixin (arm/disarm-repaint-mixin) () (:documentation "Mixin class for gadgets, which will be armed, when the mouse enters and disarmed, when the mouse leaves, and manages dragging.")) (defmethod handle-event :before ((pane draggable-arming-mixin) (event pointer-enter-event)) (declare (ignorable event)) (with-slots (armed dragging) pane (if dragging (setf dragging :inside) (unless armed (arm-gadget pane))))) (defmethod handle-event :after ((pane draggable-arming-mixin) (event pointer-exit-event)) (declare (ignorable event)) (with-slots (armed dragging) pane (if dragging (setf dragging :outside) (when armed (disarm-gadget pane))))) ; Slider (refactor into 'thumbed' gadget?) (defconstant +pixie-slider-pane-thumb-size+ 5000.0) (defconstant +pixie-slider-thumb-half-height+ 17) (defconstant +pixie-slider-thumb-height+ 34) (defconstant +pixie-slider-thumb-half-width+ 8) (defclass pixie-slider-pane (pixie-gadget draggable-arming-mixin slider-pane) ((dragging :initform nil) (drag-delta :initform 0) (bounce-value :initform 0) (thumb-size :initarg :thumb-size :initform 1/4 :accessor gadget-thumb-size) (repeating :initform 0) (was-repeating :initform 0)) (:default-initargs :border-style :inset :border-width 1)) (define-pixie-gadget slider pixie-slider-pane) (defmethod compose-space ((pane pixie-slider-pane) &key width height) (declare (ignore width height)) (if (eq (gadget-orientation pane) :vertical) (make-space-requirement :min-width *scrollbar-thickness* :width *scrollbar-thickness* :max-width +fill+ :min-height (* 2 *scrollbar-thickness*) :height (* 4 *scrollbar-thickness*) :max-height +fill+) (make-space-requirement :min-height *scrollbar-thickness* :height *scrollbar-thickness* :max-height +fill+ :min-width (* 2 *scrollbar-thickness*) :width (* 4 *scrollbar-thickness*) :max-width +fill+))) (defmethod vertical-gadget-orientation-transformation ((pane gadget)) (ecase (gadget-orientation pane) (:vertical +identity-transformation+) (:horizontal (make-transformation 0 1 1 0 0 0)))) ;(defun translate-range-value (a mina maxa mino maxo) ; "When \arg{a} is some value in the range from \arg{mina} to \arg{maxa}, ; proportionally translate the value into the range \arg{mino} to \arg{maxo}." ; (+ mino (* (/ (- a mina) (- maxa mina)) (- maxo mino)))) (defmethod gadget-thumb-region ((pane pixie-slider-pane)) (with-bounding-rectangle* (x1 y1 x2 y2) (gadget-bed-region pane) (multiple-value-bind (x1 y1 x2 y2) (values (+ x1 1) (+ y1 1) (- x2 1) (- y2 1)) (multiple-value-bind (minv maxv) (gadget-range* pane) (multiple-value-bind (value) (gadget-value pane) (let ((half-thumb-size +pixie-slider-thumb-half-height+)) (let ((ym (translate-range-value value minv maxv (+ y1 half-thumb-size) (- y2 half-thumb-size)))) (make-rectangle* x1 (- ym half-thumb-size) x2 (+ ym half-thumb-size))))))))) (defmethod gadget-bed-region ((pane pixie-slider-pane)) (with-bounding-rectangle* (minx miny maxx maxy) (transform-region (vertical-gadget-orientation-transformation pane) (sheet-region pane)) (let* ((middle (/ (+ maxx minx) 2)) (minx (- middle +pixie-slider-thumb-half-width+)) (maxx (+ middle +pixie-slider-thumb-half-width+))) (make-rectangle* (+ minx 1) (+ miny 1) (- maxx 1) (- maxy 1))))) (defmethod handle-event ((pane pixie-slider-pane) (event pointer-button-release-event)) (with-slots (armed dragging value bounce-value repeating was-repeating) pane (setf was-repeating repeating) (when armed (setf armed t (gadget-value pane :invoke-callback t) (convert-position-to-value pane (if (eq (gadget-orientation pane) :vertical) (pointer-event-y event) (pointer-event-x event))))) (when dragging (unless (eq dragging :inside) (setf armed nil ; value bounce-value ; this bouncing is more annoying than anything for sliders ) (disarmed-callback pane (gadget-client pane) (gadget-id pane))) (setf dragging nil) (dispatch-repaint pane (sheet-region pane))))) (defmethod handle-event ((pane pixie-slider-pane) (event timer-event)) (let ((token (clim-internals::event-token event))) (with-slots (was-repeating repeating) pane (unless (eql was-repeating repeating) (case token ((up-notch) (when (< (gadget-value pane) (gadget-max-value pane)) #+NIL (clim-internals::schedule-timer-event pane token 0.1) (incf (gadget-value pane)) (dispatch-repaint pane (sheet-region pane)))) ((down-notch) (when (> (gadget-value pane) (gadget-min-value pane)) #+NIL (clim-internals::schedule-timer-event pane token 0.1) (decf (gadget-value pane)) (dispatch-repaint pane (sheet-region pane))))))))) (defmethod handle-event ((pane pixie-slider-pane) (event pointer-button-press-event)) (multiple-value-bind (x y) (transform-position (vertical-gadget-orientation-transformation pane) (pointer-event-x event) (pointer-event-y event)) (with-slots (armed dragging drag-delta value bounce-value repeating) pane (incf repeating) (let ((thumb (gadget-thumb-region pane))) (cond ((region-contains-position-p thumb x y) ; Thumb (setf dragging :inside armed t bounce-value value drag-delta (- y (bounding-rectangle-min-y thumb)))) ((region-contains-position-p (gadget-bed-region pane) x y) ; well, they clicked in the bed, but not on the thumb ; move up or down one notch (cond ((< y (bounding-rectangle-min-y thumb)) #+NIL (clim-internals::schedule-timer-event pane 'down-notch 0.1) ; move toward the min (when (> (gadget-value pane) (gadget-min-value pane)) (decf (gadget-value pane)) (dispatch-repaint pane (sheet-region pane)))) ((> y (bounding-rectangle-max-y thumb)) #+NIL (clim-internals::schedule-timer-event pane 'up-notch 0.1) ; move toward the max (when (< (gadget-value pane) (gadget-max-value pane)) (incf (gadget-value pane)) (dispatch-repaint pane (sheet-region pane))))))))))) (defmethod handle-event ((pane pixie-slider-pane) (event pointer-motion-event)) (with-slots (dragging drag-delta thumb-size) pane (multiple-value-bind (x y) (transform-position (vertical-gadget-orientation-transformation pane) (pointer-event-x event) (pointer-event-y event)) (declare (ignore x)) (when dragging (let* ((y-new-thumb-top (- y drag-delta)) (bed-region (gadget-bed-region pane)) (miny (bounding-rectangle-min-y bed-region)) (maxy (bounding-rectangle-max-y bed-region)) (minv (gadget-min-value pane)) (maxv (gadget-max-value pane)) (thumb-size (* thumb-size (- minv maxv))) (value (min maxv (max minv (translate-range-value (+ y-new-thumb-top +pixie-slider-thumb-half-height+) (+ miny +pixie-slider-thumb-half-height+) (- maxy +pixie-slider-thumb-half-height+) minv maxv))))) (setf (gadget-value pane :invoke-callback nil) value) (drag-callback pane (gadget-client pane) (gadget-id pane) value) (dispatch-repaint pane (sheet-region pane))))))) ;;; Repaint (defmethod handle-repaint ((pane pixie-slider-pane) region) (declare (ignore region)) (with-special-choices (pane) (let ((tr (vertical-gadget-orientation-transformation pane))) (let ((transformed-sheet (transform-region tr (sheet-region pane)))) (with-bounding-rectangle* (minx miny maxx maxy) transformed-sheet (with-drawing-options (pane :transformation tr) ; This region-difference is a bit weird ; the gadget-bed-region seems to be being transformed by the with-drawing-options ; but the sheet-region itself not, which I guess makes some kind of sense ; -- CHECKME (with-drawing-options (pane :clipping-region (region-difference transformed-sheet (gadget-bed-region pane))) (draw-rectangle* pane minx miny maxx maxy :filled t :ink *3d-normal-color*)) ;; draw bed (with-bounding-rectangle* (x1 y1 x2 y2) (gadget-bed-region pane) (with-drawing-options (pane :clipping-region (region-difference transformed-sheet (gadget-thumb-region pane))) (multiple-value-bind (x1 y1 x2 y2) (values (+ x1 1) (+ y1 1) (- x2 1) (- y2 1)) (draw-rectangle* pane x1 y1 x2 y2 :ink (pane-background pane))) (draw-bordered-polygon pane (polygon-points (make-rectangle* x1 y1 x2 y2)) :style :inset :border-width 1))) ;; draw thumb (with-bounding-rectangle* (x1 y1 x2 y2) (gadget-thumb-region pane) (draw-up-box pane x1 y1 x2 y2 (effective-gadget-foreground pane)) ;; draw decoration in the thumb (let* ((middle (/ (+ y1 y2) 2)) (y1 (- middle 1)) (y2 middle) (x1 (+ x1 2)) (x2 (- x2 3))) (draw-line* pane x1 y1 x2 y1 :ink +gray58+) (draw-line* pane x1 y2 x2 y2 :ink +white+) (draw-line* pane x2 y1 x2 y2 :ink +white+))))))))) ; Scrollbar ; We derive from the slider, since the slider is the same, only ; less so. ;;; XXX Probably should derive from scroll-bar too. (defconstant +pixie-scroll-bar-pane-thumb-size+ 5000.0) (defconstant +pixie-scroll-bar-thumb-half-height+ 17) (defconstant +pixie-scroll-bar-thumb-height+ 34) (defconstant +pixie-scroll-bar-thumb-half-width+ 8) (defclass pixie-scroll-bar-pane (pixie-slider-pane) ( (drag-callback :initarg :drag-callback :initform nil :reader scroll-bar-drag-callback) (scroll-to-bottom-callback :initarg :scroll-to-bottom-callback :initform nil :reader scroll-bar-scroll-to-bottom-callback) (scroll-to-top-callback :initarg :scroll-to-top-callback :initform nil :reader scroll-bar-scroll-to-top-callback) (scroll-down-line-callback :initarg :scroll-down-line-callback :initform nil :reader scroll-bar-scroll-down-line-callback) (scroll-up-line-callback :initarg :scroll-up-line-callback :initform nil :reader scroll-bar-scroll-up-line-callback) (scroll-down-page-callback :initarg :scroll-down-page-callback :initform nil :reader scroll-bar-scroll-down-page-callback) (scroll-up-page-callback :initarg :scroll-up-page-callback :initform nil :reader scroll-bar-scroll-up-page-callback) (thumb-size :initarg :thumb-size :initform 1/4 :accessor gadget-thumb-size)) (:default-initargs :value 0 :min-value 0 :max-value 1 :orientation :vertical)) (define-pixie-gadget scroll-bar pixie-scroll-bar-pane) (defmethod compose-space ((pane pixie-scroll-bar-pane) &key width height) (declare (ignore width height)) (if (eq (gadget-orientation pane) :vertical) (make-space-requirement :min-width 1 :width *scrollbar-thickness* :min-height (* 3 *scrollbar-thickness*) :height (* 4 *scrollbar-thickness*)) (make-space-requirement :min-height 1 :height *scrollbar-thickness* :min-width (* 3 *scrollbar-thickness*) :width (* 4 *scrollbar-thickness*)))) (defmethod drag-callback ((pane pixie-scroll-bar-pane) client gadget-id value) (declare (ignore client gadget-id)) (invoke-callback pane (scroll-bar-drag-callback pane) value)) (defmethod scroll-to-top-callback ((pane pixie-scroll-bar-pane) client gadget-id) (declare (ignore client gadget-id)) (invoke-callback pane (scroll-bar-scroll-to-top-callback pane))) (defmethod scroll-to-bottom-callback ((pane pixie-scroll-bar-pane) client gadget-id) (declare (ignore client gadget-id)) (invoke-callback pane (scroll-bar-scroll-to-bottom-callback pane))) (defmethod scroll-up-line-callback ((pane pixie-scroll-bar-pane) client gadget-id) (declare (ignore client gadget-id)) (invoke-callback pane (scroll-bar-scroll-up-line-callback pane))) (defmethod scroll-up-page-callback ((pane pixie-scroll-bar-pane) client gadget-id) (declare (ignore client gadget-id)) (invoke-callback pane (scroll-bar-scroll-up-page-callback pane))) (defmethod scroll-down-line-callback ((pane pixie-scroll-bar-pane) client gadget-id) (declare (ignore client gadget-id)) (invoke-callback pane (scroll-bar-scroll-down-line-callback pane))) (defmethod scroll-down-page-callback ((pane pixie-scroll-bar-pane) client gadget-id) (declare (ignore client gadget-id)) (invoke-callback pane (scroll-bar-scroll-down-page-callback pane))) (defmethod scroll-bar-thumb-size ((pane pixie-scroll-bar-pane)) (gadget-thumb-size pane)) (defmethod (setf scroll-bar-thumb-size) (value (pane pixie-scroll-bar-pane)) (setf (gadget-thumb-size pane) value)) (defmethod gadget-up-region ((pane pixie-scroll-bar-pane)) (with-bounding-rectangle* (x1 y1 x2 y2) (transform-region (vertical-gadget-orientation-transformation pane) (sheet-region pane)) (let ((y1 (+ y1 1)) (y2 (- y2 1)) (x1 (+ x1 1)) (x2 (- x2 1))) (declare (ignore y2)) (make-rectangle* x1 y1 x2 (+ y1 (- x2 x1)))))) (defmethod gadget-down-region ((pane pixie-scroll-bar-pane)) (with-bounding-rectangle* (x1 y1 x2 y2) (transform-region (vertical-gadget-orientation-transformation pane) (sheet-region pane)) (let ((y1 (+ y1 1)) (y2 (- y2 1)) (x1 (+ x1 1)) (x2 (- x2 1))) (declare (ignore y1)) (make-rectangle* x1 (- y2 (- x2 x1)) x2 y2)))) (defmethod gadget-bed-region ((pane pixie-scroll-bar-pane)) (with-bounding-rectangle* (minx miny maxx maxy) (transform-region (vertical-gadget-orientation-transformation pane) (sheet-region pane)) (make-rectangle* minx (+ miny (- maxx minx) 0) maxx (- maxy (- maxx minx) 0)))) (defmethod gadget-thumb-region ((pane pixie-scroll-bar-pane)) (with-bounding-rectangle* (x1 y1 x2 y2) (gadget-bed-region pane) (let ((y1 (+ y1 1)) (y2 (- y2 1)) (x1 (+ x1 1)) (x2 (- x2 1))) (multiple-value-bind (minv maxv) (gadget-range* pane) (multiple-value-bind (v) (gadget-value pane) (let ((ts (gadget-thumb-size pane))) (let ((ya (translate-range-value v minv (+ maxv ts) y1 y2)) (yb (translate-range-value (+ v ts) minv (+ maxv ts) y1 y2))) (make-rectangle* x1 (- ya 1) x2 (+ yb 1))))))))) (defmethod* (setf scroll-bar-values) (min-value max-value thumb-size value (scroll-bar pixie-scroll-bar-pane)) (setf (slot-value scroll-bar 'min-value) min-value (slot-value scroll-bar 'max-value) max-value (slot-value scroll-bar 'thumb-size) thumb-size (slot-value scroll-bar 'value) value) (dispatch-repaint scroll-bar (sheet-region scroll-bar))) (defmethod handle-event ((pane pixie-scroll-bar-pane) (event pointer-button-release-event)) (with-slots (armed dragging repeating was-repeating) pane (setf was-repeating repeating) (cond (dragging (unless (eq dragging :inside) (setf armed nil) (disarmed-callback pane (gadget-client pane) (gadget-id pane))) (setf dragging nil) (dispatch-repaint pane (sheet-region pane))) (t ; we were pressing on one of the arrows (when armed ; if we were armed, we're still armed, but not :up or :down (setf armed t) (dispatch-repaint pane (sheet-region pane))))))) (defmethod handle-event ((pane pixie-scroll-bar-pane) (event timer-event)) (let ((token (clim-internals::event-token event))) (with-slots (was-repeating repeating) pane (unless (eql was-repeating repeating) #+NIL (clim-internals::schedule-timer-event pane token 0.1) (case token ((up-line) (scroll-up-line-callback pane (gadget-client pane) (gadget-id pane))) ((down-line) (scroll-down-line-callback pane (gadget-client pane) (gadget-id pane))) ((up-page) (scroll-up-page-callback pane (gadget-client pane) (gadget-id pane))) ((down-page) (scroll-down-page-callback pane (gadget-client pane) (gadget-id pane)))))))) (defmethod handle-event ((pane pixie-scroll-bar-pane) (event pointer-button-press-event)) (multiple-value-bind (x y) (transform-position (vertical-gadget-orientation-transformation pane) (pointer-event-x event) (pointer-event-y event)) (with-slots (armed dragging drag-delta repeating) pane (incf repeating) (let ((thumb (gadget-thumb-region pane))) (cond ((region-contains-position-p thumb x y) ; Thumb (setf dragging :inside armed t drag-delta (- y (bounding-rectangle-min-y thumb)))) ((region-contains-position-p (gadget-up-region pane) x y) #+NIL (clim-internals::schedule-timer-event pane 'up-line 0.1) ; Up Arrow (scroll-up-line-callback pane (gadget-client pane) (gadget-id pane)) (setf (slot-value pane 'armed) :up) (dispatch-repaint pane +everywhere+)) ((region-contains-position-p (gadget-down-region pane) x y) #+NIL (clim-internals::schedule-timer-event pane 'down-line 0.1) ; Down Arrow (scroll-down-line-callback pane (gadget-client pane) (gadget-id pane)) (setf (slot-value pane 'armed) :down) (dispatch-repaint pane +everywhere+)) ((region-contains-position-p (gadget-bed-region pane) x y) ; Bed (cond ((< y (bounding-rectangle-min-y thumb)) #+NIL (clim-internals::schedule-timer-event pane 'up-page 0.1) (scroll-up-page-callback pane (gadget-client pane) (gadget-id pane))) (t #+NIL (clim-internals::schedule-timer-event pane 'down-page 0.1) (scroll-down-page-callback pane (gadget-client pane) (gadget-id pane))))) (t ; Nowhere (!) nil)))))) (defmethod handle-event ((pane pixie-scroll-bar-pane) (event pointer-motion-event)) (with-slots (dragging drag-delta) pane (multiple-value-bind (x y) (transform-position (vertical-gadget-orientation-transformation pane) (pointer-event-x event) (pointer-event-y event)) (declare (ignore x)) (when dragging (let* ((y-new-thumb-top (- y drag-delta)) (ts (gadget-thumb-size pane)) (value (min (gadget-max-value pane) (max (gadget-min-value pane) (translate-range-value y-new-thumb-top (bounding-rectangle-min-y (gadget-bed-region pane)) (bounding-rectangle-max-y (gadget-bed-region pane)) (gadget-min-value pane) (+ (gadget-max-value pane) ts)))))) (setf (gadget-value pane :invoke-callback nil) value) (drag-callback pane (gadget-client pane) (gadget-id pane) value) (dispatch-repaint pane (sheet-region pane))))))) ;;; Repaint (defmethod handle-repaint ((pane pixie-scroll-bar-pane) region) (declare (ignore region)) (with-special-choices (pane) (let* ((tr (vertical-gadget-orientation-transformation pane)) (transformed-sheet (transform-region tr (sheet-region pane)))) (with-bounding-rectangle* (minx miny maxx maxy) transformed-sheet ; draw the bed? (with-drawing-options (pane :transformation tr) (let ((gadget-thumb-region (gadget-thumb-region pane)) (gadget-down-region (gadget-down-region pane)) (gadget-up-region (gadget-up-region pane)) (gadget-bed-region (gadget-bed-region pane))) (with-drawing-options (pane :clipping-region (region-difference gadget-bed-region gadget-thumb-region)) (multiple-value-bind (x1 y1 x2 y2) (values (+ minx 1) (+ miny 1) (- maxx 1) (- maxy 1)) (draw-rectangle* pane x1 y1 x2 y2 :ink (pane-background pane)))) (draw-bordered-polygon pane (polygon-points (make-rectangle* minx miny maxx maxy)) :style :inset :border-width 1) ;; draw up arrow (with-bounding-rectangle* (x1 y1 x2 y2) gadget-up-region (if (eq (slot-value pane 'armed) :up) (draw-down-box pane x1 y1 x2 y2 +gray83+) (draw-up-box pane x1 y1 x2 y2 +gray83+)) ;; draw decoration in the region (multiple-value-bind (pattern fudge-x fudge-y) (if (eq (gadget-orientation pane) :vertical) (values +pixie-up-arrow+ -1 1) (values +pixie-left-arrow+ -1 1)) (draw-pattern* pane pattern (+ fudge-x (floor (- (+ x1 x2) (pattern-width pattern)) 2)) (+ fudge-y (floor (- (+ y1 y2) (pattern-height pattern)) 2))))) ;; draw down arrow (with-bounding-rectangle* (x1 y1 x2 y2) gadget-down-region (if (eq (slot-value pane 'armed) :down) (draw-down-box pane x1 y1 x2 y2 +gray83+) (draw-up-box pane x1 y1 x2 y2 +gray83+)) ;; draw decoration in the region (multiple-value-bind (pattern fudge-x fudge-y) (if (eq (gadget-orientation pane) :vertical) (values +pixie-down-arrow+ -1 1) (values +pixie-right-arrow+ -1 2)) (draw-pattern* pane pattern (+ fudge-x (floor (- (+ x1 x2) (pattern-width pattern)) 2)) (+ fudge-y (floor (- (+ y1 y2) (pattern-height pattern)) 2))))) ;; draw thumb (with-bounding-rectangle* (x1 y1 x2 y2) gadget-thumb-region (draw-up-box pane x1 y1 x2 y2 (effective-gadget-foreground pane)) ;; no thumb decoration ))))))) ; Menus (defclass pixie-menu-bar-pane (pixie-gadget menu-bar) ()) (define-pixie-gadget menu-bar pixie-menu-bar-pane :enabled t) (defmethod handle-repaint ((pane pixie-menu-bar-pane) region) (declare (ignore region)) (with-special-choices (pane) (let* ((region (sheet-region pane)) (frame (polygon-points (bounding-rectangle region)))) #+NIL (draw-polygon pane frame :ink +Blue+ :filled t) (draw-bordered-polygon pane frame :style :outset :border-width 1)))) (define-pixie-gadget menu-button pixie-menu-button-pane) (defclass pixie-menu-button-pane (pixie-gadget menu-button-pane) ((left-margin :reader left-margin) (right-margin :reader right-margin)) (:default-initargs :align-x :left :align-y :center)) (defparameter *pixie-menu-button-left-margin* 26) (defparameter *pixie-menu-button-right-margin* 26) (defparameter *pixie-menubar-item-left-margin* 8) (defparameter *pixie-menubar-item-right-margin* 8) (defparameter *pixie-menubar-item-spacing* 0) (defmethod initialize-instance :after ((pane pixie-menu-button-pane) &rest args &key vertical &allow-other-keys) (declare (ignore args)) (with-slots (left-margin right-margin) pane (setf (values left-margin right-margin) (if (or (typep (slot-value pane 'client) 'menu-bar) (not vertical)) (values *pixie-menubar-item-left-margin* *pixie-menubar-item-right-margin*) (values *pixie-menu-button-left-margin* *pixie-menu-button-right-margin*))))) ;; What even uses this? All the subclasses have their own handle-repaint methods! #+NIL (defmethod handle-repaint ((pane pixie-menu-button-pane) region) (declare (ignore region)) (with-special-choices (pane) (let* ((region (sheet-region pane)) (frame (polygon-points (bounding-rectangle region)))) (draw-polygon pane frame :filled t :ink (effective-gadget-foreground pane)) (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* region) (cond ((slot-value pane 'armed) (let ((inset-frame (polygon-points (make-rectangle* (+ x1 2) (+ y1 2) (- x2 2) (- y2 2))))) (draw-polygon pane inset-frame :filled t :ink (effective-gadget-foreground pane)) (draw-bordered-polygon pane inset-frame :style :outset :border-width 1))) (t (draw-polygon pane frame :filled t :ink (effective-gadget-foreground pane)))) (draw-label* pane (+ x1 (left-margin pane)) y1 (- x2 (right-margin pane)) y2 :ink +red+ #+NIL (pane-inking-color pane)))))) (defmethod compose-space ((gadget pixie-menu-button-pane) &key width height) (declare (ignore width height)) (space-requirement+* (compose-label-space gadget :wider (+ (left-margin gadget) (right-margin gadget)) :higher (+ 6 (* 2 *3d-border-thickness*))) :min-width 0 :width 0 :max-width +fill+ :min-height 0 :height 0 :max-height 0)) (defclass pixie-menu-button-leaf-pane (pixie-menu-button-pane menu-button-leaf-pane) ()) (define-pixie-gadget menu-button-leaf-pane pixie-menu-button-leaf-pane) (defmethod handle-repaint ((pane pixie-menu-button-leaf-pane) region) (declare (ignore region)) (with-slots (armed) pane ; XXX only do this when the gadget is realized. (when (sheet-mirror pane) (with-special-choices (pane) (with-slots (label) pane (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region pane) (let ((w (- x2 x1)) (h (- y2 y1))) (draw-rectangle* pane -1 -1 x2 y2 :ink (if armed +gray93+ +gray83+) :filled t) (when armed (draw-edges-lines* pane +white+ 0 0 +black+ (1- w) (1- h))) (let ((x1 (+ x1 (left-margin pane))) (x2 (- x2 (right-margin pane)))) (if (gadget-active-p pane) (draw-label* pane x1 y1 x2 y2 :ink +black+) (draw-engraved-label* pane x1 y1 x2 y2)))))))))) (defclass pixie-menu-button-submenu-pane (pixie-menu-button-pane menu-button-submenu-pane) ()) (define-pixie-gadget menu-button-submenu-pane pixie-menu-button-submenu-pane) (define-pixie-gadget menu-button-vertical-submenu-pane pixie-menu-button-submenu-pane) (defmethod compose-space ((gadget pixie-menu-button-submenu-pane) &key width height) (declare (ignore width height)) (if (typep (slot-value gadget 'client) 'menu-bar) ; XXX (compose-label-space gadget :wider (+ (left-margin gadget) (right-margin gadget)) :higher 10) (call-next-method))) (defmethod handle-repaint ((pane pixie-menu-button-submenu-pane) region) (declare (ignore region)) (with-slots (submenu-frame client) pane (when (sheet-mirror pane) ;XXX only do this when the gadget is realized. (with-special-choices (pane) (with-slots (label) pane (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region pane) (let ((w (- x2 x1)) (h (- y2 y1))) (draw-rectangle* pane -1 -1 x2 y2 :ink (if submenu-frame +gray93+ +gray83+) :filled t) (when submenu-frame (draw-edges-lines* pane +white+ 0 0 +black+ (1- w) (1- h))) (if (typep client 'menu-button) (let ((pattern +pixie-right-arrow+)) (draw-label* pane (+ x1 (left-margin pane)) y1 (- x2 (right-margin pane)) y2 :ink +black+) (draw-pattern* pane pattern (- x2 10) (+ y1 (floor (- h (pattern-height pattern)) 2)))) (draw-label* pane (+ x1 (left-margin pane)) y1 (- x2 (right-margin pane)) y2 :ink +black+))))))))) ; Image pane ; rebuild this with a pixmap repository for general re-use of pixmaps ; within a port/visual combination. ; This is just test/proof-of-concept code :] #+NIL (defclass pixie-image-pane (pixie-gadget basic-gadget) ( (image-pathname :initarg :pathname) (image-mask-pathname :initarg :mask-pathname :initform nil) (image-width :type integer :reader width :initform 0) (image-height :type integer :reader height :initform 0) (image-image :initform nil) (image-pixmap :initform nil) (image-stencil :initform nil))) ; TODO: allow pixmaps to be realized from unrealized media #+NIL (defmethod initialize-instance :after ((pane pixie-image-pane) &rest args) (declare (ignore args)) (with-slots (image-pathname image-image image-width image-height) pane (let* ((data (image:read-image-file image-pathname)) (image (image:make-truecolor-image data 255))) (destructuring-bind (width height) (array-dimensions data) (setf image-width width image-height height image-image image)))) (with-slots (image-mask-pathname image-stencil) pane (when image-mask-pathname (let* ((data (image:read-image-file image-mask-pathname))) (setf image-stencil (make-stencil data)))))) #+NIL (defmethod handle-repaint ((pane pixie-image-pane) region) (declare (ignore region)) (with-slots (image-pixmap image-width image-height) pane ; we defer the image loading until after realisation ; which will cause a delay in the initial exposure, ; CHECKME - should we be able to realize pixmaps derived ; from unrealized panes? ; Technically we could just do it from the port's root ; since we don't switch visuals within a port at this point. ; but that is not necessarily a good thing (unless image-pixmap (with-slots (image-image image-width image-height image-pixmap) pane (setf image-pixmap (with-output-to-pixmap (medium pane :width image-width :height image-height) (draw-image (medium-sheet medium) image-image :clipping-region (make-rectangle* 0 0 image-width image-height)))))) (copy-from-pixmap image-pixmap 0 0 image-width image-height pane 0 0))) #+NIL (defmethod compose-space ((pane pixie-image-pane) &key width height) (declare (ignore width height)) (with-slots (image-width image-height) pane (let ((w image-width) (h image-height)) (make-space-requirement :width w :height h :min-width w :min-height h :max-width w :max-height h)))) ; Toggle Button (for checkboxes and radio-buttons) (defclass pixie-toggle-button-pane (pixie-gadget toggle-button-pane) ()) (define-pixie-gadget toggle-button pixie-toggle-button-pane) (defmethod draw-toggle-button-indicator ((pane pixie-toggle-button-pane) (type (eql :one-of)) value x1 y1 x2 y2) (multiple-value-bind (cx cy) (values (/ (+ x1 x2) 2) (/ (+ y1 y2) 2)) (let ((radius (/ (- y2 y1) 2))) (draw-circle* pane cx cy radius :start-angle (* 1/4 pi) :end-angle (* 5/4 pi) :ink *3d-dark-color*) (draw-circle* pane cx cy (- radius 1) :start-angle (* 1/4 pi) :end-angle (* 5/4 pi) :ink (pane-inking-color pane)) (draw-circle* pane cx cy radius :start-angle (* 5/4 pi) :end-angle (* 1/4 pi) :ink *3d-light-color*) (draw-circle* pane cx cy (- radius 1) :start-angle (* 5/4 pi) :end-angle (* 1/4 pi) :ink (effective-gadget-foreground pane)) (draw-circle* pane cx cy (max 1 (- radius 2)) :ink (pane-paper-color pane)) (when value (draw-circle* pane cx cy (max 1 (- radius 4)) :ink (pane-inking-color pane)))))) (defmethod draw-toggle-button-indicator ((pane pixie-toggle-button-pane) (type (eql :some-of)) value x1 y1 x2 y2) (draw-rectangle* pane x1 y1 x2 y2 :ink (pane-paper-color pane)) (draw-bordered-rectangle* pane x1 y1 x2 y2 :style :inset) (multiple-value-bind (x1 y1 x2 y2) (values (+ x1 1) (+ y1 1) (- x2 2) (- y2 2)) (draw-line* pane x1 y2 x2 y2 :ink (effective-gadget-foreground pane)) (draw-line* pane x2 y1 x2 y2 :ink (effective-gadget-foreground pane)) (draw-line* pane x1 y1 x1 (+ y2 1) :ink (pane-inking-color pane)) (draw-line* pane x1 y1 (+ x2 1) y1 :ink (pane-inking-color pane))) (when value (multiple-value-bind (x1 y1 x2 y2) (values (+ x1 3) (+ y1 3) (- x2 3) (- y2 3)) (draw-line* pane x1 y1 x2 y2 :ink (pane-inking-color pane) :line-thickness 2) (draw-line* pane x2 y1 x1 y2 :ink (pane-inking-color pane) :line-thickness 2)))) (defmethod handle-repaint ((pane pixie-toggle-button-pane) region) (declare (ignore region)) (when (sheet-grafted-p pane) (with-special-choices (pane) (with-slots (armed) pane (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* (sheet-region pane)) (draw-rectangle* pane x1 y1 x2 y2 :ink (effective-gadget-background pane)) (let* ((as (text-style-ascent (pane-text-style pane) pane)) (ds (text-style-descent (pane-text-style pane) pane)) ) (multiple-value-bind (tx1 ty1 tx2 ty2) (values (+ x1 (pane-x-spacing pane)) (- (/ (+ y1 y2) 2) (/ (+ as ds) 2)) (+ x1 (pane-x-spacing pane) (+ as ds)) (+ (/ (+ y1 y2) 2) (/ (+ as ds) 2))) (draw-toggle-button-indicator pane (toggle-button-indicator-type pane) (gadget-value pane) tx1 ty1 tx2 ty2) (draw-label* pane (+ tx2 3 (pane-x-spacing pane)) y1 x2 y2 :ink (pane-inking-color pane))))))))) ; Push Button ; why does this inherit from slider-pane? (defclass pixie-push-button-pane (pixie-gadget push-button-pane slider-pane) ( (dragging :initform nil))) (define-pixie-gadget push-button pixie-push-button-pane) (defmethod compose-space ((gadget pixie-push-button-pane) &key width height) (declare (ignore width height)) ;; Why does a button have spacing options, anyway? (space-requirement+* (space-requirement+* (compose-label-space gadget) :min-width (* 2 (pane-x-spacing gadget)) :width (* 2 (pane-x-spacing gadget)) :max-width (* 2 (pane-x-spacing gadget)) :min-height (* 2 (pane-y-spacing gadget)) :height (* 2 (pane-y-spacing gadget)) :max-height (* 2 (pane-y-spacing gadget))) :min-width (* 8 *3d-border-thickness*) :width (* 8 *3d-border-thickness*) :max-width (* 8 *3d-border-thickness*) :min-height (* 4 *3d-border-thickness*) :height (* 4 *3d-border-thickness*) :max-height (* 4 *3d-border-thickness*))) ; factor out the dragging code into a mixin (defmethod handle-event ((pane pixie-push-button-pane) (event pointer-enter-event)) (with-slots (armed dragging) pane (cond ((not armed) (setf armed t) (armed-callback pane (gadget-client pane) (gadget-id pane))) (dragging (setf dragging :inside)))) (dispatch-repaint pane +everywhere+)) (defmethod handle-event ((pane pixie-push-button-pane) (event pointer-exit-event)) (with-slots (armed dragging) pane (cond (dragging (setf dragging :outside)) (armed (setf armed nil) (disarmed-callback pane (gadget-client pane) (gadget-id pane))))) (dispatch-repaint pane +everywhere+)) (defmethod handle-event ((pane pixie-push-button-pane) (event pointer-button-press-event)) (with-slots (pressedp dragging) pane (setf pressedp t dragging :inside) (dispatch-repaint pane +everywhere+))) (defmethod handle-event ((pane pixie-push-button-pane) (event pointer-button-release-event)) (with-slots (armed pressedp dragging) pane (setf pressedp nil) (when (and armed (eq dragging :inside)) (activate-callback pane (gadget-client pane) (gadget-id pane)) (setf pressedp nil) (dispatch-repaint pane +everywhere+)))) (defmethod handle-repaint ((pane pixie-push-button-pane) region) (declare (ignore region)) (with-slots (armed dragging pressedp) pane (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region pane) (let ((x1 (+ x1 1)) (y1 (+ y1 1)) (x2 (- x2 1)) (y2 (- y2 1))) (let ((x2 (- x2 1)) ; Removing this magic weirdness slightly uglifies the (y2 (- y2 1))) ; scroll bar. Not sure why, but FIXME. (cond ((or (not pressedp) (eq dragging :outside)) (draw-up-box pane x1 y1 x2 y2 (effective-gadget-foreground pane))) (pressedp (draw-down-box pane x1 y1 x2 y2 (effective-gadget-foreground pane))))))))) (defclass pixie-submenu-border-pane (submenu-border) () (:default-initargs :border-width 2)) (define-pixie-gadget submenu-border pixie-submenu-border-pane) (defmethod handle-repaint ((pane pixie-submenu-border-pane) region) (declare (ignore region)) (with-slots (border-width) pane (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region pane) (draw-rectangle* pane x1 y1 x2 y2 :filled nil :ink +black+) ;; Why, having incremented the coordinates, and despite setting ;; the border-width to 2, do I now get a single pixel border ? ;; It's fine, that's the result I want, but an explanation is in order. (draw-bordered-rectangle* pane (1+ x1) (1+ y1) (1- x2) (1- y2) :style :outset :border-width border-width)))) ; Text Area (defclass pixie-text-field-pane (text-field-pane) ()) ;; Why does pixie need its own text area subclass? Leave it disabled for now. (define-pixie-gadget text-field-pane pixie-text-field-pane :enabled nil) (defmethod initialize-instance :after ((pane pixie-text-field-pane) &rest rest) (unless (getf rest :normal) (setf (slot-value pane 'current-color) +white+ (slot-value pane 'normal) +white+))) (defmethod note-sheet-grafted :after ((pane pixie-text-field-pane)) (multiple-value-bind (cx cy) (stream-cursor-position pane) (setf (cursor-visibility (stream-text-cursor pane)) nil) (setf (area pane) (make-instance 'goatee:simple-screen-area :area-stream pane :x-position cx :y-position cy :initial-contents (slot-value pane 'value))) (stream-add-output-record pane (area pane)))) (defmethod handle-repaint ((pane pixie-text-field-pane) region) (declare (ignore region)) (with-special-choices (pane) (with-sheet-medium (medium pane) (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* (sheet-region pane)) (display-gadget-background pane (gadget-current-color pane) 0 0 (- x2 x1) (- y2 y1)) (goatee::redisplay-all (area pane)))))) (defmethod handle-event ((gadget pixie-text-field-pane) (event key-press-event)) (let ((gesture (convert-to-gesture event)) (*activation-gestures* *standard-activation-gestures*)) (when (activation-gesture-p gesture) (activate-callback gadget (gadget-client gadget) (gadget-id gadget)) (return-from handle-event t)) (goatee:execute-gesture-command gesture (area gadget) goatee::*simple-area-gesture-table*) (let ((new-value (goatee::buffer-string (goatee::buffer (area gadget))))) (unless (string= (gadget-value gadget) new-value) (setf (slot-value gadget 'value) new-value) (value-changed-callback gadget (gadget-client gadget) (gadget-id gadget) new-value))))) (defmethod (setf gadget-value) :after (new-value (gadget pixie-text-field-pane) &key invoke-callback) (declare (ignore invoke-callback)) (let* ((area (area gadget)) (buffer (goatee::buffer area)) (start (goatee::buffer-start buffer)) (end (goatee::buffer-end buffer))) (goatee::clear-buffer buffer) (goatee::insert buffer new-value :position start) (goatee::redisplay-area area))) (defmethod compose-space ((pane pixie-text-field-pane) &key width height) (declare (ignore width height)) (with-sheet-medium (medium pane) (let ((as (text-style-ascent (medium-text-style medium) medium)) (ds (text-style-descent (medium-text-style medium) medium)) (w (text-size medium (gadget-value pane)))) (let ((width w) (height (+ as ds))) (make-space-requirement :width width :height height :max-width width :max-height height :min-width width :min-height height))))) ;;;; Pixie tab-layout. Reuses implementation of the generic tab-layout-pane. (define-pixie-gadget clim-tab-layout:tab-layout pixie-tab-layout-pane) (define-pixie-gadget clim-tab-layout::tab-bar-pane pixie-tab-bar-pane) (defclass pixie-tab-bar-view (gadget-view) ((selected :initform nil :initarg :selected :reader pixie-tab-view-selected-p))) (defparameter +pixie-tab-bar-view+ (make-instance 'pixie-tab-bar-view :selected nil)) (defparameter +pixie-selected-tab-bar-view+ (make-instance 'pixie-tab-bar-view :selected t)) (defclass pixie-tab-layout-pane (clim-tab-layout:tab-layout-pane) () (:default-initargs :header-display-function 'pixie-display-tab-header)) (defclass pixie-tab-bar-pane (application-pane pixie-gadget) () (:default-initargs :default-view +pixie-tab-bar-view+ :background +gray83+ :text-style (make-text-style :sans-serif :roman (if (find-package :mcclim-truetype) :normal :small)))) (defmethod compose-space ((pane pixie-tab-bar-pane) &key width height) (declare (ignore width height)) (let ((h (+ 6 ; padding on the top 6 ; padding on the bottom (text-style-ascent (pane-text-style pane) pane) (text-style-descent (pane-text-style pane) pane)))) (make-space-requirement :min-height h :height h :max-height h))) (defun draw-pixie-tab-bar-bottom (pane) (let ((y0 (bounding-rectangle-min-y (sheet-region pane))) (y1 (bounding-rectangle-max-y (sheet-region pane)))) (draw-line* pane 0 (- y1 6) +fill+ (- y1 6) :ink *3d-light-color*) (draw-line* pane 0 (- y1 1) +fill+ (- y1 1) :ink *3d-dark-color*) #+NIL (draw-line* pane 0 (1- y1) x1 (1- y1) :ink +gray30+))) (defmethod draw-output-border-over ((shape (eql 'pixie-tab-bar-border)) stream record &key &allow-other-keys) (declare (ignore shape stream record))) (defmethod draw-output-border-under ((shape (eql 'pixie-tab-bar-border)) stream record &key background enabled &allow-other-keys) (with-border-edges (stream record) (declare (ignore bottom)) (with-bounding-rectangle* (x0 y0 x1 y1) (sheet-region stream) (declare (ignore x0 x1 y0)) (let ((bottom (- y1 7)) (left (- left 4 (if enabled 2 0))) (right (+ right 4 (if enabled 2 0))) (top (- top 2 #+NIL (if enabled 2 0)))) (draw-rectangle* stream left top right (+ bottom (if enabled 2 1)) :filled t :ink background) (draw-line* stream (1+ left) (1- top) (- right 1) (1- top) :ink +white+) (draw-point* stream left top :ink +white+) (draw-line* stream (1- left) bottom (1- left) (1+ top) :ink +white+) (draw-line* stream right bottom right top :ink +gray66+) (draw-point* stream right top :ink +gray40+) (draw-line* stream (1+ right) bottom (1+ right) (1+ top) :ink +gray40+))))) (define-default-highlighting-method 'pixie-tab-bar-border) (define-presentation-method present (tab-page (type clim-tab-layout:tab-page) stream (view pixie-tab-bar-view) &key) (stream-increment-cursor-position stream 5 0) (surrounding-output-with-border (stream :shape 'pixie-tab-bar-border :enabled (pixie-tab-view-selected-p view) :highlight-background +gray94+ :background +gray83+ :move-cursor nil) (apply #'invoke-with-drawing-options stream (lambda (rest) (declare (ignore rest)) (write-string (clim-tab-layout:tab-page-title tab-page) stream)) (clim-tab-layout:tab-page-drawing-options tab-page))) (stream-increment-cursor-position stream 6 0)) (defun pixie-display-tab-header (tab-layout pane) (draw-pixie-tab-bar-bottom pane) (setf (stream-cursor-position pane) (values 3 (- (bounding-rectangle-height (sheet-region pane)) 7 (text-style-descent (pane-text-style pane) pane) (text-style-ascent (pane-text-style pane) pane)))) (let ((enabled-page-drawers nil)) (mapc (lambda (page) ;; This gets a little silly, but the tabs are laid out simply by ;; letting the cursor move from left to right. In order to make ;; the selected tab overlap, we can't draw it until after the other ;; tabs. We then draw it slightly larger in each direcetion. But the ;; cursor has to have moved as though it were smaller (so that it ;; overlaps its neighbors), so draw it initially, note its position, ;; and redraw a larger version once everything is done. (let ((enabled (sheet-enabled-p (clim-tab-layout:tab-page-pane page)))) (when enabled (multiple-value-bind (x y) (stream-cursor-position pane) (push (lambda () (setf (stream-cursor-position pane) (values x (- y 2))) (with-output-as-presentation (pane (clim-tab-layout:tab-page-pane page) (clim-tab-layout:tab-page-presentation-type page)) (present page 'clim-tab-layout:tab-page :stream pane :view +pixie-selected-tab-bar-view+))) enabled-page-drawers))) (let ((record (with-output-as-presentation (pane (clim-tab-layout:tab-page-pane page) (clim-tab-layout:tab-page-presentation-type page)) (present page 'clim-tab-layout:tab-page :stream pane)))) ;; Because piling the presentations on top of each other confuses ;; CLIM as to which should be highlighted, erase the smaller one. ;; The cursor has already been moved, so we don't need it. (when enabled (delete-output-record record (output-record-parent record)))))) (clim-tab-layout:tab-layout-pages tab-layout)) (mapcar #'funcall enabled-page-drawers))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/design.lisp0000644000175000017500000007711511345155771017165 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com) ;;; (c) copyright 2000 by Robert Strandh (strandh@labri.u-bordeaux.fr) ;;; (c) copyright 1998,2002 by Gilbert Baumann ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;;; Some Notes ;; The design design has a pitfall: ;; ;; As drawing is specified, a design of class opacity carries no color ;; and thus borrows its color from +foreground-ink+. So that ;; ;; (make-opacity v) == (compose-in +foreground-ink+ (make-opacity v)) ;; ;; This implies, that an opacity is not neccessary uniform, it depends ;; on the selected foreground ink. ;; ;; They halfway fix this by specifing that the mask argument of ;; compose-in and compose-out is thought as to be drawn with ;; +foreground-ink+ = +background-ink+ = +black+. ;; ;; But Is (make-opacity 1) really the same as +foreground-ink+? ;; Or: Is ;; (compose-in D +foreground-ink+) different from ;; (compose-in D (make-opacity 1))? ;; ;; If the above equation is true, we get a funny algebra: ;; ;; (make-opacity 0) = +transparent-ink+ = +nowhere+ ;; (make-opacity 1) = +foreground-ink+ = +everywhere+ ;; ;; --GB ;; I agree with this interpretation. -Hefner ;; It might be handy to have the equivalent of parent-relative ;; backgrounds. We can specify new indirect inks: ;; ;; +parent-background+ ;; +parent-relative-background+ ;; +parent-foreground+ ;; +parent-relative-foreground+ ;; ;; The relative one would have the same "absolute" origin as the ;; relevant inks of the parent. ;; ;; When they are evaluated, they look at the parent's ;; foreground/background ink. Though the relative variants are ;; expensive, when you want to scroll them ... ;; ;; ;; Further we really should specify some form of indirekt ink ;; protocol. ;; ;; --GB ;;;; Design Protocol ;; ;; DRAW-DESIGN already is all you need for a design protocol. ;; ;; --GB (in-package :clim-internals) (eval-when (:compile-toplevel :load-toplevel :execute) (defgeneric color-rgb (color)) (defmethod print-object ((color color) stream) (print-unreadable-object (color stream :identity nil :type t) (multiple-value-call #'format stream "~,4F ~,4F ~,4F" (color-rgb color)))) ;;; standard-color (defclass standard-color (color) ((red :initarg :red :initform 0 :type (real 0 1)) (green :initarg :green :initform 0 :type (real 0 1)) (blue :initarg :blue :initform 0 :type (real 0 1)))) (defmethod color-rgb ((color standard-color)) (with-slots (red green blue) color (values red green blue))) (defclass named-color (standard-color) ((name :initarg :name :initform "Unnamed color") )) (defmethod print-object ((color named-color) stream) (with-slots (name) color (print-unreadable-object (color stream :type t :identity nil) (format stream "~S" name)))) (defmethod make-load-form ((color named-color) &optional env) (declare (ignore env)) (with-slots (name red green blue) color `(make-named-color ',name ,red ,green ,blue))) (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *color-hash-table* (make-hash-table :test #'eql))) (defun compute-color-key (red green blue) (+ (ash (round (* 255 red)) 16) (ash (round (* 255 green)) 8) (round (* 255 blue)))) (defun make-rgb-color (red green blue) (let ((key (compute-color-key red green blue))) (declare (type fixnum key)) (or (gethash key *color-hash-table*) (setf (gethash key *color-hash-table*) (make-instance 'named-color :red red :green green :blue blue))))) (defun make-gray-color (intensity) (make-rgb-color intensity intensity intensity)) (defun make-named-color (name red green blue) (let* ((key (compute-color-key red green blue)) (entry (gethash key *color-hash-table*))) (declare (type fixnum key)) (cond (entry (when (string-equal (slot-value entry 'name) "Unnamed color") (setf (slot-value entry 'name) name)) entry) (t (setf (gethash key *color-hash-table*) (make-instance 'named-color :name name :red red :green green :blue blue)))))) ) ; eval-when ;;; ;;; For ihs to rgb conversion, we use the formula ;;; ;;; i = (r+g+b)/3 ;;; ;;; s = 1-min(r,g,b)/i ;;; ;;; h = 60(g-b)/(max(r,g,b)-min(r,g,b)) if r >= g,b ;;; ;;; 120+60(b-r)/(max(r,g,b)-min(r,g,b)) if g >= r,b ;;; ;;; 240+60(r-g)/(max(r,g,b)-min(r,g,b)) if b >= r,g ;;; ;;; First, we introduce colors x, y, z such that x >= y >= z ;;; ;;; We compute x, y, and z and then determine the correspondance ;;; ;;; between x, y, and z on the one hand and r, g, and b on the other. ;;; (defun make-ihs-color (i h s) ;;; (assert (and (<= 0 i 1) ;;; (<= 0 s 1) ;;; (<= 0 h 360))) ;;; (let ((ah (/ (abs (cond ((<= h 60) h) ;;; ((<= h 180) (- h 120)) ;;; ((<= h 300) (- h 240)) ;;; (t (- h 360)))) ;;; 60))) ;;; (let* ((z (* i (- 1 s))) ;;; (y (/ (+ (* ah (- (* 3 i) (* 2 z))) z) (+ 1 ah))) ;;; (x (- (* 3 i) y z))) ;;; (assert (and (<= 0 x 1) ;;; (<= 0 y 1) ;;; (<= 0 z 1))) ;;; (cond ((<= h 60) (make-rgb-color x y z)) ;;; ((<= h 120) (make-rgb-color y x z)) ;;; ((<= h 180) (make-rgb-color z x y)) ;;; ((<= h 240) (make-rgb-color z y x)) ;;; ((<= h 300) (make-rgb-color y z x)) ;;; (t (make-rgb-color x z y)))))) ;;; ;;; (defmethod color-ihs ((color color)) ;;; (multiple-value-bind (r g b) (color-rgb color) ;;; (let ((max (max r g b)) ;;; (min (min r g b)) ;;; (intensity (/ (+ r g b) 3))) ;;; (if (= max min) ;;; (values intensity 0 0) ;;; (let* ((saturation (- 1 (/ min intensity))) ;;; (diff (- max min)) ;;; (hue (* 60 (cond ((= max r) (/ (- g b) diff)) ;;; ((= max g) (+ 2 (/ (- b r) diff))) ;;; (t (+ 4 (/ (- r g) diff))))))) ;;; (when (< hue 0) ;;; (incf hue 360)) ;;; (values intensity hue saturation)))))) ;;; ;;; Below is a literal translation from Dylan's DUIM source code, ;;; which was itself probably literal translation from some Lisp code. ;;; (defconstant +ihs-rgb-c1+ (sqrt (coerce 1/6 'double-float))) (defconstant +ihs-rgb-c2+ (sqrt (coerce 1/2 'double-float))) (defconstant +ihs-rgb-c3+ (sqrt (coerce 1/3 'double-float))) (defun ihs-to-rgb (intensity hue saturation) (let* ((hh (- (* (mod (- hue 1/2) 1) 2 pi) pi)) (c3 (cos saturation)) (s3 (sin saturation)) (cos-hh (cos hh)) (sin-hh (sin hh)) (x (* +ihs-rgb-c1+ s3 cos-hh intensity)) (y (* +ihs-rgb-c2+ s3 sin-hh intensity)) (z (* +ihs-rgb-c3+ c3 intensity))) (declare (type (real #.(- pi) #.pi) hh)) (values (max 0 (min 1 (+ x x z))) (max 0 (min 1 (+ y z (- x)))) (max 0 (min 1 (- z x y)))))) (defun rgb-to-ihs (red green blue) (let* ((x (* +ihs-rgb-c1+ (- (* 2 red) blue green))) (y (* +ihs-rgb-c2+ (- green blue))) (z (* +ihs-rgb-c3+ (+ red green blue))) (q (+ (* x x) (* y y))) (intensity (sqrt (+ q (* z z))))) ;sqrt(r^2 + g^2 + b^2) (if (zerop q) ;; A totally unsaturated color (values intensity 0 0) (let* ((hue (mod (/ (atan y x) (* 2 pi)) 1)) (f1 (/ z intensity)) (f2 (sqrt (- 1 (* f1 f1)))) (saturation (atan f2 f1))) (values intensity hue saturation))))) (defgeneric color-ihs (color)) (defmethod color-ihs ((color color)) (multiple-value-call #'rgb-to-ihs (color-rgb color))) (defun make-ihs-color (i h s) (multiple-value-call #'make-rgb-color (ihs-to-rgb i h s))) (defun make-contrasting-inks (n &optional k) ;; Look +contrasting-colors+ up at runtime, because it has not yet been ;; declared when this is compiled. (let ((contrasting-colors (symbol-value '+contrasting-colors+))) (if (> n (length contrasting-colors)) (error "The argument N is out of range [1-~D]" (length contrasting-colors))) (if (null k) (subseq contrasting-colors 0 n) (aref contrasting-colors k)))) #|| ;;; I used this function to generate the predefined colors and names - mikemac@mikemac.com (defun generate-named-colors () (with-open-file (out "X11-colors.lisp" :direction :output :if-exists :supersede) (with-open-file (in "/usr/X11/lib/X11/rgb.txt" :direction :input) (format out ";;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-~%~%") (format out "(in-package :clim-internals)~%~%") (loop with names = nil for line = (read-line in nil nil) until (null line) do (if (eql (aref line 0) #\!) (format out ";~A~%" (subseq line 1)) (multiple-value-bind (red index) (parse-integer line :start 0 :junk-allowed t) (multiple-value-bind (green index) (parse-integer line :start index :junk-allowed t) (multiple-value-bind (blue index) (parse-integer line :start index :junk-allowed t) (let ((name (substitute #\- #\Space (string-trim '(#\Space #\Tab #\Newline) (subseq line index))))) (format out "(defconstant +~A+ (make-named-color ~S ~,4F ~,4F ~,4F))~%" name name (/ red 255.0) (/ green 255.0) (/ blue 255.0)) (setq names (nconc names (list name)))))))) finally (format out "~%(defconstant +contrasting-colors+ (vector +black+ +red+ +green+ +blue+ +cyan+ +magenta+ +yellow+ +white+))~%~%") (format out "(eval-when (eval compile load)~% (export '(") (loop for name in names for count = 1 then (1+ count) do (format out "+~A+ " name) (when (= count 4) (format out "~% ") (setq count 0))) (format out "~% )))~%") )))) ||# ;;;; Design <-> Region Equivalences ;;; As Gilbert points in his notes, transparent ink is in every ;;; respect interchangable with the nowhere region, and likewise ;;; foreground ink is interchangable with the everywhere region. ;;; By defining the following mixins and adding them to the ;;; appropriate ink/region class pairs, we can reduce the number ;;; of methods necessary. (defclass everywhere-mixin () ()) (defclass nowhere-mixin () ()) ;;;; ;;;; 13.6 Indirect Inks ;;;; (defclass indirect-ink (design) ()) (defclass %foreground-ink (indirect-ink everywhere-mixin) ()) (defvar +foreground-ink+ (make-instance '%foreground-ink)) (defvar +background-ink+ (make-instance 'indirect-ink)) (defmethod print-object ((ink (eql +foreground-ink+)) stream) (format stream "#.~S" '+foreground-ink+)) (defmethod print-object ((ink (eql +background-ink+)) stream) (format stream "#.~S" '+background-ink+)) ;;;; ;;;; 13.4 Opacity ;;;; (defmethod print-object ((object opacity) stream) (print-unreadable-object (object stream :identity nil :type t) (format stream "~S" (opacity-value object)))) ;; Note: Though tempting, opacity is not a uniform-design! (defclass standard-opacity (opacity) ((value :initarg :value :type (real 0 1) :reader opacity-value))) (defclass %transparent-ink (standard-opacity nowhere-mixin) () (:default-initargs :value 0)) (defvar +transparent-ink+ (make-instance '%transparent-ink :value 0)) (defmethod opacity-value ((region everywhere-mixin)) (declare (ignore region)) 1.0) (defmethod opacity-value ((region nowhere-mixin)) (declare (ignore region)) 0.0) (defun make-opacity (value) (setf value (clamp value 0 1)) ;defensive programming (cond ((= value 0) +transparent-ink+) ((= value 1) +everywhere+) ; used to say +foreground-ink+ (t (make-instance 'standard-opacity :value value)))) ;;;; ;;;; 13.7 Flipping Ink ;;;; (defclass standard-flipping-ink (design) ((design1 :initarg :design1 :type design) (design2 :initarg :design2 :type design))) (defvar +flipping-ink+ (make-instance 'standard-flipping-ink :design1 +foreground-ink+ :design2 +background-ink+)) (defmethod print-object ((ink (eql +flipping-ink+)) stream) (format stream "#.~S" '+flipping-ink+)) (defmethod print-object ((flipper standard-flipping-ink) stream) (with-slots (design1 design2) flipper (print-unreadable-object (flipper stream :identity nil :type t) (format stream "~S ~S" design1 design2)))) (defgeneric make-flipping-ink (design1 design2)) (defmethod make-flipping-ink ((design1 design) (design2 design)) (make-instance 'standard-flipping-ink :design1 design1 :design2 design2)) (defmethod make-flipping-ink ((design1 (eql +foreground-ink+)) (design2 (eql +background-ink+))) +flipping-ink+) (defmethod make-flipping-ink ((design1 (eql +background-ink+)) (design2 (eql +foreground-ink+))) +flipping-ink+) ;;;; ;;;; 14 General Designs ;;;; (declaim (inline color-blend-function)) (defun color-blend-function (r1 g1 b1 o1 r2 g2 b2 o2) (let* ((o3 (+ o1 (* (- 1 o1) o2))) (r3 (/ (+ (* r1 o1) (* (- 1 o1) o2 r2)) o3)) (g3 (/ (+ (* g1 o1) (* (- 1 o1) o2 g2)) o3)) (b3 (/ (+ (* b1 o1) (* (- 1 o1) o2 b2)) o3))) (values r3 g3 b3 o3))) (defgeneric compose-over (design1 design2)) (defgeneric compose-in (ink mask)) (defgeneric compose-out (ink mask)) ;;; RGB image designs, efficient support for truecolor images. ARGB ;;; image data represented as an (unsigned-byte 32) array (defclass rgb-image () ((width :initarg :width :accessor image-width) (height :initarg :height :accessor image-height) (data :initarg :data :accessor image-data :type (or null (simple-array (unsigned-byte 32) (* *)))) (alphap :initarg :alphap :initform nil :accessor image-alpha-p))) ;; Applications (closure in particular) might want to cache any ;; backend-specific data required to draw an RGB-IMAGE. ;; ;; To implement this caching, designs must be created separately for each ;; medium, so that mediums can put their own data into them. (defclass rgb-image-design (design) ((medium :initform nil :initarg :medium) (image :reader image :initarg :image) (medium-data :initform nil))) (defun make-rgb-image-design (image) (make-instance 'rgb-image-design :image image)) ;; Protocol to free cached data (defgeneric medium-free-image-design (medium design)) (defun free-image-design (design) (medium-free-image-design (slot-value design 'medium) design)) ;; Drawing protocol (defgeneric medium-draw-image-design* (medium design x y)) ;; Fetching protocol (defun sheet-rgb-image (sheet &key x y width height) (multiple-value-bind (data alphap) (sheet-rgb-data (port sheet) sheet :x x :y y :width width :height height) (destructuring-bind (height width) (array-dimensions data) (make-instance 'rgb-image :width width :height height :data data :alphap alphap)))) (defgeneric sheet-rgb-data (port sheet &key x y width height)) (defmethod draw-design (medium (design rgb-image-design) &rest options &key (x 0) (y 0) &allow-other-keys) (with-medium-options (medium options) (medium-draw-image-design* medium design x y))) ;; PATTERN is just the an abstract class of all pattern-like design. ;; For performance might consider to sort out pattern, which consists ;; of uniform designs only and convert them to an RGBA-image. (define-protocol-class pattern (design)) (defclass indexed-pattern (pattern) ((array :initarg :array :reader pattern-array) (designs :initarg :designs :reader pattern-designs))) (defun make-pattern (array designs) (make-instance 'indexed-pattern :array array :designs designs)) (defmethod pattern-width ((pattern indexed-pattern)) (array-dimension (pattern-array pattern) 1)) (defmethod pattern-height ((pattern indexed-pattern)) (array-dimension (pattern-array pattern) 0)) (defclass stencil (pattern) ((array :initarg :array))) (defun make-stencil (array) (make-instance 'stencil :array array)) (defmethod pattern-width ((pattern stencil)) (with-slots (array) pattern (array-dimension array 1))) (defmethod pattern-height ((pattern stencil)) (with-slots (array) pattern (array-dimension array 0))) ;; These methods are included mostly for completeness and are likely ;; of little use in practice. (defmethod pattern-array ((pattern stencil)) (let ((array (make-array (list (pattern-height pattern) (pattern-width pattern))))) (dotimes (i (pattern-height pattern)) (dotimes (j (pattern-width pattern)) (setf (aref array i j) (+ (* i (array-dimension array 1)) j)))) array)) (defmethod pattern-designs ((pattern stencil)) (with-slots (array) pattern (let ((designs (make-array (* (pattern-height pattern) (pattern-width pattern))))) (dotimes (i (length designs)) (setf (aref designs i) (make-opacity (row-major-aref array i)))) array))) (defclass rgb-pattern (pattern rgb-image-design) ()) (defmethod pattern-width ((pattern rgb-pattern)) (image-width (image pattern))) (defmethod pattern-height ((pattern rgb-pattern)) (image-height (image pattern))) ;; RGB-PATTERNs must be treated specially... (defmethod medium-draw-pattern* (medium (pattern rgb-pattern) x y) (medium-draw-image-design* medium pattern x y)) ;;; (defclass transformed-design (design) ((transformation :initarg :transformation :reader transformed-design-transformation) (design :initarg :design :reader transformed-design-design))) (defmethod transform-region (transformation (design design)) (make-instance 'transformed-design :transformation transformation :design design)) (defmethod transform-region (transformation (design pattern)) (make-instance 'transformed-design :transformation transformation :design design)) ;;; (defclass rectangular-tile (design) ((width :initarg :width :reader rectangular-tile-width) (height :initarg :height :reader rectangular-tile-height) (design :initarg :design :reader rectangular-tile-design))) (defun make-rectangular-tile (design width height) (make-instance 'rectangular-tile :width width :height height :design design)) ;;; (defclass masked-compositum (design) ((ink :initarg :ink :reader compositum-ink) (mask :initarg :mask :reader compositum-mask))) (defmethod print-object ((object masked-compositum) stream) (print-unreadable-object (object stream :identity nil :type t) (format stream "~S ~S ~S ~S" :ink (compositum-ink object) :mask (compositum-mask object)))) (defclass in-compositum (masked-compositum) ()) (defmethod compose-in ((ink design) (mask design)) (make-instance 'in-compositum :ink ink :mask mask)) (defclass out-compositum (masked-compositum) ()) (defmethod compose-out ((ink design) (mask design)) (make-instance 'out-compositum :ink ink :mask mask)) (defclass over-compositum (design) ((foreground :initarg :foreground :reader compositum-foreground) (background :initarg :background :reader compositum-background))) (defmethod compose-over ((foreground design) (background design)) (make-instance 'over-compositum :foreground foreground :background background)) (defclass uniform-compositum (in-compositum) ;; we use this class to represent rgbo values ()) ;;; ;;; color ;;; opacity ;;; indirect-ink ;;; in-compositum ;;; over-compositum ;;; out-compositum ;;; uniform-compositum ;;; ;;;; ------------------------------------------------------------------------------------------ ;;;; ;;;; COMPOSE-IN ;;;; (defun make-uniform-compositum (ink opacity-value) (cond ((= opacity-value 0) +transparent-ink+) ((= opacity-value 1) ink) (t (make-instance 'uniform-compositum :ink ink :mask (make-opacity opacity-value))))) ;;; COLOR (defmethod compose-in ((ink design) (mask color)) (declare (ignorable ink)) ink) ;;; OPACITY (defmethod compose-in ((ink opacity) (mask opacity)) (make-opacity (* (opacity-value ink) (opacity-value mask)))) (defmethod compose-in ((ink color) (mask opacity)) (make-uniform-compositum ink (opacity-value mask))) ;;; UNIFORM-COMPOSITUM (defmethod compose-in ((ink uniform-compositum) (mask uniform-compositum)) (make-uniform-compositum (compositum-ink ink) (* (opacity-value (compositum-mask ink)) (opacity-value (compositum-mask mask))))) (defmethod compose-in ((ink uniform-compositum) (mask opacity)) (make-uniform-compositum (compositum-ink ink) (* (opacity-value (compositum-mask ink)) (opacity-value mask)))) (defmethod compose-in ((ink opacity) (mask uniform-compositum)) (make-opacity (* (opacity-value mask) (opacity-value (compositum-mask mask))))) (defmethod compose-in ((ink color) (mask uniform-compositum)) (make-uniform-compositum ink (opacity-value mask))) (defmethod compose-in ((design design) (mask everywhere-mixin)) (declare (ignore mask)) design) (defmethod compose-in ((design design) (mask nowhere-mixin)) (declare (ignore design mask)) +nowhere+) ;;; IN-COMPOSITUM ;; Since compose-in is associative, we can write it this way: (defmethod compose-in ((ink in-compositum) (mask design)) (compose-in (compositum-ink ink) (compose-in (compositum-mask ink) mask))) #+nyi (defmethod compose-in ((ink opacity) (mask in-compositum)) (declare (ignorable ink mask)) ) #+nyi (defmethod compose-in ((ink color) (mask in-compositum)) (declare (ignorable ink mask)) ) ;;; OUT-COMPOSITUM #+nyi (defmethod compose-in ((ink out-compositum) (mask out-compositum)) (declare (ignorable ink mask)) ) #+nyi (defmethod compose-in ((ink out-compositum) (mask in-compositum)) (declare (ignorable ink mask)) ) #+nyi (defmethod compose-in ((ink out-compositum) (mask uniform-compositum)) (declare (ignorable ink mask)) ) #+nyi (defmethod compose-in ((ink out-compositum) (mask opacity)) (declare (ignorable ink mask)) ) #+nyi (defmethod compose-in ((ink uniform-compositum) (mask out-compositum)) (declare (ignorable ink mask)) ) #+nyi (defmethod compose-in ((ink opacity) (mask out-compositum)) (declare (ignorable ink mask)) ) #+nyi (defmethod compose-in ((ink color) (mask out-compositum)) (declare (ignorable ink mask)) ) ;;; OVER-COMPOSITUM #+nyi (defmethod compose-in ((ink over-compositum) (mask over-compositum)) (declare (ignorable ink mask)) ) #+nyi (defmethod compose-in ((ink over-compositum) (mask out-compositum)) (declare (ignorable ink mask)) ) #+nyi (defmethod compose-in ((ink over-compositum) (mask in-compositum)) (declare (ignorable ink mask)) ) #+nyi (defmethod compose-in ((ink over-compositum) (mask uniform-compositum)) (declare (ignorable ink mask)) ) #+nyi (defmethod compose-in ((ink over-compositum) (mask opacity)) (declare (ignorable ink mask)) ) #+nyi (defmethod compose-in ((ink out-compositum) (mask over-compositum)) (declare (ignorable ink mask)) ) #+nyi (defmethod compose-in ((ink uniform-compositum) (mask over-compositum)) (declare (ignorable ink mask)) ) #+nyi (defmethod compose-in ((ink opacity) (mask over-compositum)) (declare (ignorable ink mask)) ) #+nyi (defmethod compose-in ((ink color) (mask over-compositum)) (declare (ignorable ink mask)) ) ;;;; ------------------------------------------------------------------------------------------ ;;;; ;;;; Compose-Out ;;;; (defmethod compose-out ((design design) (mask everywhere-mixin)) (declare (ignore design mask)) +nowhere+) (defmethod compose-out ((design design) (mask nowhere-mixin)) (declare (ignore mask)) design) (defmethod compose-out ((design design) (mask color)) (declare (ignore design mask)) +nowhere+) (defmethod compose-out ((design design) (mask uniform-compositum)) (compose-in design (make-opacity (- 1.0 (compositum-mask (opacity-value mask)))))) (defmethod compose-out ((design design) (mask standard-opacity)) (compose-in design (make-opacity (- 1.0 (opacity-value mask))))) ;;;; ------------------------------------------------------------------------------------------ ;;;; ;;;; Compose-Over ;;;; ;;; COLOR (defmethod compose-over ((foreground color) (background design)) (declare (ignorable background)) foreground) ;;; OPACITY (defmethod compose-over ((foreground opacity) (background opacity)) (make-opacity (+ (opacity-value foreground) (* (- 1 (opacity-value foreground)) (opacity-value background))))) (defmethod compose-over ((foreground opacity) (background color)) (make-instance 'over-compositum :foreground foreground :background background)) ;;; UNIFORM-COMPOSITUM (defmethod compose-over ((foreground uniform-compositum) (background uniform-compositum)) (multiple-value-bind (r g b o) (multiple-value-call #'color-blend-function (color-rgb (compositum-ink foreground)) (opacity-value (compositum-mask foreground)) (color-rgb (compositum-ink background)) (opacity-value (compositum-mask background))) (make-uniform-compositum (make-rgb-color r g b) o))) (defmethod compose-over ((foreground uniform-compositum) (background opacity)) (make-instance 'over-compositum :foreground foreground :background background)) (defmethod compose-over ((foreground uniform-compositum) (background color)) (multiple-value-bind (r g b o) (multiple-value-call #'color-blend-function (color-rgb (compositum-ink foreground)) (opacity-value (compositum-mask foreground)) (color-rgb background) 1) (make-uniform-compositum (make-rgb-color r g b) o))) (defmethod compose-over ((foreground opacity) (background uniform-compositum)) (multiple-value-bind (r g b o) (multiple-value-call #'color-blend-function (color-rgb foreground) (color-rgb (compositum-ink background)) (opacity-value (compositum-mask background))) (make-uniform-compositum (make-rgb-color r g b) o))) ;;; IN-COMPOSITUM #+nyi (defmethod compose-over ((foreground in-compositum) (background in-compositum)) (declare (ignorable foreground background)) ) #+nyi (defmethod compose-over ((foreground in-compositum) (background uniform-compositum)) (declare (ignorable foreground background)) ) #+nyi (defmethod compose-over ((foreground in-compositum) (background opacity)) (declare (ignorable foreground background)) ) #+nyi (defmethod compose-over ((foreground in-compositum) (background color)) (declare (ignorable foreground background)) ) #+nyi (defmethod compose-over ((foreground uniform-compositum) (background in-compositum)) (declare (ignorable foreground background)) ) #+nyi (defmethod compose-over ((foreground opacity) (background in-compositum)) (declare (ignorable foreground background)) ) ;;; OUT-COMPOSITUM #+nyi (defmethod compose-over ((foreground out-compositum) (background out-compositum)) (declare (ignorable foreground background)) ) #+nyi (defmethod compose-over ((foreground out-compositum) (background in-compositum)) (declare (ignorable foreground background)) ) #+nyi (defmethod compose-over ((foreground out-compositum) (background uniform-compositum)) (declare (ignorable foreground background)) ) #+nyi (defmethod compose-over ((foreground out-compositum) (background opacity)) (declare (ignorable foreground background)) ) #+nyi (defmethod compose-over ((foreground out-compositum) (background color)) (declare (ignorable foreground background)) ) #+nyi (defmethod compose-over ((foreground in-compositum) (background out-compositum)) (declare (ignorable foreground background)) ) #+nyi (defmethod compose-over ((foreground uniform-compositum) (background out-compositum)) (declare (ignorable foreground background)) ) #+nyi (defmethod compose-over ((foreground color) (background out-compositum)) (declare (ignorable foreground background)) ) ;;; OVER-COMPOSITUM #+nyi (defmethod compose-over ((foreground over-compositum) (background over-compositum)) (declare (ignorable foreground background)) ) #+nyi (defmethod compose-over ((foreground over-compositum) (background out-compositum)) (declare (ignorable foreground background)) ) #+nyi (defmethod compose-over ((foreground over-compositum) (background in-compositum)) (declare (ignorable foreground background)) ) #+nyi (defmethod compose-over ((foreground over-compositum) (background uniform-compositum)) (declare (ignorable foreground background)) ) #+nyi (defmethod compose-over ((foreground over-compositum) (background opacity)) (declare (ignorable foreground background)) ) #+nyi (defmethod compose-over ((foreground over-compositum) (background color)) (declare (ignorable foreground background)) ) #+nyi (defmethod compose-over ((foreground out-compositum) (background over-compositum)) (declare (ignorable foreground background)) ) #+nyi (defmethod compose-over ((foreground in-compositum) (background over-compositum)) (declare (ignorable foreground background)) ) #+nyi (defmethod compose-over ((foreground uniform-compositum) (background over-compositum)) (declare (ignorable foreground background)) ) #+nyi (defmethod compose-over ((foreground opacity) (background over-compositum)) (declare (ignorable foreground background)) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Comparison of designs. (defgeneric design-equalp (design1 design2)) (defmethod design-equalp :around ((design1 t) (design2 t)) (or (eql design1 design2) (call-next-method))) (defmethod design-equalp ((design1 t) (design2 t)) nil) (defmethod design-equalp ((design1 standard-color) (design2 standard-color)) (multiple-value-bind (r1 g1 b1) (color-rgb design1) (multiple-value-bind (r2 g2 b2) (color-rgb design2) (and (= r1 r2) (= g1 g2) (= b1 b2))))) ;;; The two default colors (defconstant +white+ (make-named-color "white" 1.0000 1.0000 1.0000)) (defconstant +black+ (make-named-color "black" 0.0000 0.0000 0.0000)) ;;; Color utilities (defgeneric highlight-shade (ink) (:documentation "Produce an alternate shade of the given ink for the purpose of highlighting. Typically the ink will be brightened, but very light inks may be darkened.")) (defmethod highlight-shade (ink) ink) (defmethod highlight-shade ((ink (eql +background-ink+))) +foreground-ink+) (defmethod highlight-shade ((ink (eql +foreground-ink+))) +background-ink+) (defmethod highlight-shade ((ink standard-color)) (let ((brighten-factor 0.5) (darken-factor 0.15)) (multiple-value-bind (r g b) (color-rgb ink) (multiple-value-bind (blend-ink factor) (if (> (- 3.0 r g b) 0.2) (values +white+ brighten-factor) (values +black+ darken-factor)) (compose-over (compose-in blend-ink (make-opacity factor)) ink))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/regions.lisp0000644000175000017500000027526611345155772017372 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-INTERNALS; -*- ;;; -------------------------------------------------------------------------------------- ;;; Title: The CLIM Region Datatype ;;; Created: 1998-12-02 19:26 ;;; Author: Gilbert Baumann ;;; License: LGPL (See file COPYING for details). ;;; $Id: regions.lisp,v 1.39 2009-06-03 20:33:16 ahefner Exp $ ;;; -------------------------------------------------------------------------------------- ;;; (c) copyright 1998,1999,2001 by Gilbert Baumann ;;; (c) copyright 2001 by Arnaud Rouanet (rouanet@emi.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;;; Changes ;;; When Who What ;;; -------------------------------------------------------------------------------------- ;;; 2002-06-27 GB REGION-INTERSECTS-REGION-P has an :around method on bounding ;;; rectangles. ;;; 2002-06-04 APD partially fixed (BOUNDING-RECTANGLE* STANDARD-ELLIPSE) ;;; 2001-07-16 GB added (REGION-CONTAINS-POSITION-P STANDARD-ELLIPSE ..) ;;; added (BOUNDING-RECTANGLE* STANDARD-ELLIPSE) ;;; added (REGION-INTERSECTION LINE STANDARD-ELLIPSE) and vice versa ;;; 2001-07-12 GB fixed bugs in ;;; (BOUNDING-RECTANGLE* STANDARD-REGION-UNION) ;;; (BOUNDING-RECTANGLE* STANDARD-REGION-INTERSECTION) ;;; 2001-07-09 GB maybe fixed a bug in MAP-OVER-SCHNITT-GERADE/POLYGON. ;;; 2001-03-09 AR fixed a bug in MAKE-ELLIPICAL-THING ;;; fixed STANDARD-ELLIPTICAL-ARC defclass ;;; 2001-03-06 AR fixed bug in (REGION-EQUAL STANDARD-RECTANGLE STANDARD-RECTANGLE) ;;; REGION is now a subclass of DESIGN. ;;; 2001-01-21 GB fixed bug in (TRANSFORM-REGION T RECTANGLE-SET) ;;; added some documentation ;;; GB = Gilbert Baumann ;;; AR = Arnaud Rouanet ;;; ---- TODO ---------------------------------------------------------------------------- ;; - ellipses: The intersection of two ellipses is there, but ;; handling the start/end angle is not implemented. ;; - This code is anything else than well organized. ;; - provide better (faster) implementations for REGION-EQUAL, ;; REGION-CONTAINS-REGION-P, and REGION-INTERSECTS-REGION-P. ;; - Compute a union/intersection/difference of an union of polygon vs another ;; polygon or union of polygons directly via POLYGON-OP. ;; - STANDARD-REGION-UNION should either become a subclass ;; 'STANDARD-DISJUNCT-REGION-UNION' or a flag. Some set operations could take ;; advantage out the information, if the subregions of an union are disjunct. ;; - provide sensible PRINT-OBJECT methods. ;; - while you are are at it; provide a reasonable fast vertical scan routine. ;; polygons should make use of the sweep line algorithm. ;; - implement bounding rectangle cache for polygons and polylines ;; - make REGION-CONTAINS-POSITION-P for polygons faster by handling the special ;; case of the intersection of a horizontal line and the polygons ;; - MAKE-POLY{LINE,GON} should canonise its arguments; no edges of length 0 and ;; no co-linear vertexes. Maybe: canonise rectangles? Also a polygon of less ;; than three vertexes is to be considered empty aka +nowhere+. (in-package :clim-internals) (defclass nowhere-region (region nowhere-mixin) ()) (defclass everywhere-region (region everywhere-mixin) ()) ;; coordinate is defined in coordinates.lisp (defvar +everywhere+ (make-instance 'everywhere-region)) (defvar +nowhere+ (make-instance 'nowhere-region)) (defmethod bounding-rectangle* ((x nowhere-region)) (values 0 0 0 0)) ;; 2.5.1.1 Region Predicates in CLIM (defgeneric region-equal (region1 region2)) (defgeneric region-contains-region-p (region1 region2)) (defgeneric region-contains-position-p (region x y)) (defgeneric region-intersects-region-p (region1 region2)) ;; 2.5.1.2 Composition of CLIM Regions (defclass standard-region-union (region-set) ((regions :initarg :regions :reader standard-region-set-regions))) (defclass standard-region-intersection (region-set) ((regions :initarg :regions :reader standard-region-set-regions))) (defclass standard-region-difference (region-set) ((a :initarg :a :reader standard-region-difference-a) (b :initarg :b :reader standard-region-difference-b))) ;; Protocol: (defgeneric region-set-regions (region &key normalize)) (defgeneric map-over-region-set-regions (function region &key normalize)) (defgeneric region-union (region1 region2)) (defgeneric region-intersection (region1 region2)) (defgeneric region-difference (region1 region2)) ;;; ---- 2.5.2 CLIM Point Objects -------------------------------------------------------- (defclass standard-point (point) ((x :type coordinate :initarg :x) (y :type coordinate :initarg :y))) (defun make-point (x y) (make-instance 'standard-point :x (coerce x 'coordinate) :y (coerce y 'coordinate))) (defmethod print-object ((self standard-point) sink) (with-slots (x y) self (format sink "#<~S ~S ~S>" 'standard-point x y))) ;; Point protocol: point-position (defgeneric point-position (point)) (defmethod point-position ((self standard-point)) (with-slots (x y) self (values x y))) (defmethod point-x ((self point)) (nth-value 0 (point-position self))) (defmethod point-y ((self point)) (nth-value 1 (point-position self))) (defmethod transform-region (transformation (self standard-point)) (with-slots (x y) self (multiple-value-bind (x* y*) (transform-position transformation x y) (make-point x* y*)))) (defmethod region-contains-position-p ((self standard-point) px py) (with-slots (x y) self (and (coordinate= x px) (coordinate= y py)))) ;;; ---- 2.5.3 Polygons and Polylines in CLIM -------------------------------------------- ;; Protocol: (defclass standard-polyline (polyline) ((points :initarg :points) (closed :initarg :closed))) (defclass standard-polygon (polygon) ((points :initarg :points)) ) ;;; ---- 2.5.3.1 Constructors for CLIM Polygons and Polylines --------------------------- (defun coord-seq->point-seq (sequence) (let ((res nil)) (do-sequence ((x y) sequence) (push (make-point x y) res)) (nreverse res))) (defun make-polyline (point-seq &key closed) (assert (every #'pointp point-seq)) (setq point-seq (coerce point-seq 'list)) (cond ((every (lambda (x) (region-equal x (car point-seq))) (cdr point-seq)) +nowhere+) (t (make-instance 'standard-polyline :points point-seq :closed closed)))) (defun make-polyline* (coord-seq &key closed) (make-polyline (coord-seq->point-seq coord-seq) :closed closed)) (defun make-polygon (point-seq) (assert (every #'pointp point-seq)) (setq point-seq (coerce point-seq 'list)) (cond ((every (lambda (x) (region-equal x (car point-seq))) (cdr point-seq)) +nowhere+) (t (make-instance 'standard-polygon :points point-seq)))) (defun make-polygon* (coord-seq) (make-polygon (coord-seq->point-seq coord-seq))) (defmethod polygon-points ((self standard-polygon)) (with-slots (points) self points)) (defmethod map-over-polygon-coordinates (fun (self standard-polygon)) (with-slots (points) self (mapc (lambda (p) (funcall fun (point-x p) (point-y p))) points))) (defmethod map-over-polygon-segments (fun (self standard-polygon)) (with-slots (points) self (do ((q points (cdr q))) ((null (cdr q)) (funcall fun (point-x (car q)) (point-y (car q)) (point-x (car points)) (point-y (car points)))) (funcall fun (point-x (car q)) (point-y (car q)) (point-x (cadr q)) (point-y (cadr q)))))) (defmethod polygon-points ((self standard-polyline)) (with-slots (points) self points)) (defmethod map-over-polygon-coordinates (fun (self standard-polyline)) (with-slots (points) self (mapc (lambda (p) (funcall fun (point-x p) (point-y p))) points))) (defmethod map-over-polygon-segments (fun (self standard-polyline)) (with-slots (points closed) self (do ((q points (cdr q))) ((null (cdr q)) (when closed (funcall fun (point-x (car q)) (point-y (car q)) (point-x (car points)) (point-y (car points))))) (funcall fun (point-x (car q)) (point-y (car q)) (point-x (cadr q)) (point-y (cadr q)))))) (defmethod polyline-closed ((self standard-polyline)) (with-slots (closed) self closed)) (defmethod transform-region (transformation (self standard-polyline)) (with-slots (points closed) self (make-polyline (mapcar (lambda (p) (multiple-value-bind (x* y*) (transform-position transformation (point-x p) (point-y p)) (make-point x* y*))) points) :closed closed))) (defmethod transform-region (transformation (self standard-polygon)) (with-slots (points) self (make-polygon (mapcar (lambda (p) (multiple-value-bind (x* y*) (transform-position transformation (point-x p) (point-y p)) (make-point x* y*))) points)))) (defmethod region-contains-position-p ((self standard-polyline) x y) (setf x (coerce x 'coordinate) y (coerce y 'coordinate)) (block nil (map-over-polygon-segments (lambda (x1 y1 x2 y2) (when (line-contains-point-p* x1 y1 x2 y2 x y) (return t))) self) nil)) (defun line-contains-point-p* (x1 y1 x2 y2 px py) (and (or (<= x1 px x2) (>= x1 px x2)) (or (<= y1 py y2) (>= y1 py y2)) (coordinate= (* (- py y1) (- x2 x1)) (* (- px x1) (- y2 y1))))) (defun line-contains-point-p** (x1 y1 x2 y2 px py) (coordinate= (* (- py y1) (- x2 x1)) (* (- px x1) (- y2 y1)))) ;;; ---- 2.5.4 Lines in CLIM ------------------------------------------------------------- ;; Line protocol: line-start-point* line-end-point* (defclass standard-line (line) ((x1 :type coordinate :initarg :x1) (y1 :type coordinate :initarg :y1) (x2 :type coordinate :initarg :x2) (y2 :type coordinate :initarg :y2))) (defun make-line (start-point end-point) (make-line* (point-x start-point) (point-y start-point) (point-x end-point) (point-y end-point))) (defun make-line* (start-x start-y end-x end-y) (setf start-x (coerce start-x 'coordinate) start-y (coerce start-y 'coordinate) end-x (coerce end-x 'coordinate) end-y (coerce end-y 'coordinate)) (if (and (coordinate= start-x end-x) (coordinate= start-y end-y)) +nowhere+ (make-instance 'standard-line :x1 start-x :y1 start-y :x2 end-x :y2 end-y))) (defmethod line-start-point* ((line standard-line)) (with-slots (x1 y1 x2 y2) line (values x1 y1))) (defmethod line-end-point* ((line standard-line)) (with-slots (x1 y1 x2 y2) line (values x2 y2))) (defmethod line-start-point ((line line)) (multiple-value-bind (x y) (line-start-point* line) (make-point x y))) (defmethod line-end-point ((line line)) (multiple-value-bind (x y) (line-end-point* line) (make-point x y))) ;; polyline protocol for standard-line's: (defmethod polygon-points ((line standard-line)) (with-slots (x1 y1 x2 y2) line (list (make-point x1 y1) (make-point x2 y2)))) (defmethod map-over-polygon-coordinates (fun (line standard-line)) (with-slots (x1 y1 x2 y2) line (funcall fun x1 y1) (funcall fun x2 y2))) (defmethod map-over-polygon-segments (fun (line standard-line)) (with-slots (x1 y1 x2 y2) line (funcall fun x1 y1 x2 y2))) (defmethod polyline-closed ((line standard-line)) nil) (defmethod transform-region (transformation (line standard-line)) (with-slots (x1 y1 x2 y2) line (multiple-value-bind (x1* y1*) (transform-position transformation x1 y1) (multiple-value-bind (x2* y2*) (transform-position transformation x2 y2) (make-line* x1* y1* x2* y2*))))) (defmethod region-contains-position-p ((self standard-line) x y) (multiple-value-bind (x1 y1) (line-start-point* self) (multiple-value-bind (x2 y2) (line-end-point* self) (line-contains-point-p* x1 y1 x2 y2 x y)))) (defmethod print-object ((self standard-line) sink) (with-slots (x1 y1 x2 y2) self (format sink "#<~S ~D ~D ~D ~D>" (type-of self) x1 y1 x2 y2))) ;;; ---- 2.5.5 Rectangles in CLIM -------------------------------------------------------- ;; protocol: ;; rectangle-edges* (defclass standard-rectangle (rectangle) ((coordinates :initform (make-array 4 :element-type 'coordinate)))) (defmethod initialize-instance :after ((obj standard-rectangle) &key (x1 0.0d0) (y1 0.0d0) (x2 0.0d0) (y2 0.0d0)) (let ((coords (slot-value obj 'coordinates))) (setf (aref coords 0) x1) (setf (aref coords 1) y1) (setf (aref coords 2) x2) (setf (aref coords 3) y2))) (defmacro with-standard-rectangle ((x1 y1 x2 y2) rectangle &body body) (with-gensyms (coords) `(let ((,coords (slot-value ,rectangle 'coordinates))) (declare (type (simple-array coordinate (4)) ,coords)) (let ((,x1 (aref ,coords 0)) (,y1 (aref ,coords 1)) (,x2 (aref ,coords 2)) (,y2 (aref ,coords 3))) (declare (type coordinate ,x1 ,y1 ,x2 ,y2)) ,@body)))) (defmacro with-standard-rectangle* ((&key x1 y1 x2 y2) rectangle &body body) (with-gensyms (coords) `(let ((,coords (slot-value ,rectangle 'coordinates))) (declare (type (simple-array coordinate (4)) ,coords)) (let (,@(and x1 `((,x1 (aref ,coords 0)))) ,@(and y1 `((,y1 (aref ,coords 1)))) ,@(and x2 `((,x2 (aref ,coords 2)))) ,@(and y2 `((,y2 (aref ,coords 3))))) (declare (type coordinate ,@(and x1 `(,x1)) ,@(and y1 `(,y1)) ,@(and x2 `(,x2)) ,@(and y2 `(,y2)))) ,@body)))) (defun make-rectangle (point1 point2) (make-rectangle* (point-x point1) (point-y point1) (point-x point2) (point-y point2))) (defun make-rectangle* (x1 y1 x2 y2) (psetq x1 (coerce (min x1 x2) 'coordinate) x2 (coerce (max x1 x2) 'coordinate) y1 (coerce (min y1 y2) 'coordinate) y2 (coerce (max y1 y2) 'coordinate)) (if (or (coordinate= x1 x2) (coordinate= y1 y2)) +nowhere+ (make-instance 'standard-rectangle :x1 x1 :x2 x2 :y1 y1 :y2 y2))) (defmethod rectangle-edges* ((rect standard-rectangle)) (with-standard-rectangle (x1 y1 x2 y2) rect (values x1 y1 x2 y2))) ;;; standard-rectangles are immutable and all that, but we still need to set ;;; their positions and dimensions (in output recording) (defgeneric* (setf rectangle-edges*) (x1 y1 x2 y2 rectangle)) (defmethod* (setf rectangle-edges*) (x1 y1 x2 y2 (rectangle standard-rectangle)) (let ((coords (slot-value rectangle 'coordinates))) (declare (type (simple-array coordinate (4)) coords)) (setf (aref coords 0) x1) (setf (aref coords 1) y1) (setf (aref coords 2) x2) (setf (aref coords 3) y2)) (values x1 y1 x2 y2)) (defmethod rectangle-min-point ((rect rectangle)) (multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* rect) (declare (ignore x2 y2)) (make-point x1 y1))) (defmethod rectangle-min-point ((rect standard-rectangle)) (with-standard-rectangle* (:x1 x1 :y1 y1) rect (make-point x1 y1))) (defmethod rectangle-max-point ((rect rectangle)) (multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* rect) (declare (ignore x1 y1)) (make-point x2 y2))) (defmethod rectangle-max-point ((rect standard-rectangle)) (with-standard-rectangle* (:x2 x2 :y2 y2) rect (make-point x2 y2))) (defmethod rectangle-min-x ((rect rectangle)) (nth-value 0 (rectangle-edges* rect))) (defmethod rectangle-min-x ((rect standard-rectangle)) (with-standard-rectangle* (:x1 x1) rect x1)) (defmethod rectangle-min-y ((rect rectangle)) (nth-value 1 (rectangle-edges* rect))) (defmethod rectangle-min-y ((rect standard-rectangle)) (with-standard-rectangle* (:y1 y1) rect y1)) (defmethod rectangle-max-x ((rect rectangle)) (nth-value 2 (rectangle-edges* rect))) (defmethod rectangle-max-x ((rect standard-rectangle)) (with-standard-rectangle* (:x2 x2) rect x2)) (defmethod rectangle-max-y ((rect rectangle)) (nth-value 3 (rectangle-edges* rect))) (defmethod rectangle-max-y ((rect standard-rectangle)) (with-standard-rectangle* (:y2 y2) rect y2)) (defmethod rectangle-width ((rect rectangle)) (multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* rect) (declare (ignore y1 y2)) (- x2 x1))) (defmethod rectangle-width ((rect standard-rectangle)) (with-standard-rectangle* (:x1 x1 :x2 x2) rect (- x2 x1))) (defmethod rectangle-height ((rect rectangle)) (multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* rect) (declare (ignore x1 x2)) (- y2 y1))) (defmethod rectangle-height ((rect standard-rectangle)) (with-standard-rectangle* (:y1 y1 :y2 y2) rect (- y2 y1))) (defmethod rectangle-size ((rect rectangle)) (multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* rect) (values (- x2 x1) (- y2 y1)))) (defmethod rectangle-size ((rect standard-rectangle)) (with-standard-rectangle (x1 y1 x2 y2) rect (values (- x2 x1) (- y2 y1)))) ;; polyline/polygon protocol for standard-rectangle's (defmethod polygon-points ((rect standard-rectangle)) (with-standard-rectangle (x1 y1 x2 y2) rect (list (make-point x1 y1) (make-point x1 y2) (make-point x2 y2) (make-point x2 y1)))) (defmethod map-over-polygon-coordinates (fun (rect standard-rectangle)) (with-standard-rectangle (x1 y1 x2 y2) rect (funcall fun x1 y1) (funcall fun x1 y2) (funcall fun x2 y2) (funcall fun x2 y1))) (defmethod map-over-polygon-segments (fun (rect standard-rectangle)) (with-standard-rectangle (x1 y1 x2 y2) rect (funcall fun x1 y1 x1 y2) (funcall fun x1 y2 x2 y2) (funcall fun x2 y2 x2 y1) (funcall fun x2 y1 x1 y1))) (defmethod transform-region (transformation (rect standard-rectangle)) (cond ((rectilinear-transformation-p transformation) (with-standard-rectangle (x1 y1 x2 y2) rect (multiple-value-bind (x1* y1*) (transform-position transformation x1 y1) (multiple-value-bind (x2* y2*) (transform-position transformation x2 y2) (make-rectangle* x1* y1* x2* y2*))))) (t (make-polygon (mapcar (lambda (p) (transform-region transformation p)) (polygon-points rect)))) )) (defmethod region-contains-position-p ((self standard-rectangle) x y) (with-standard-rectangle (x1 y1 x2 y2) self (and (<= x1 (coerce x 'coordinate) x2) (<= y1 (coerce y 'coordinate) y2)))) ;;; ---- 2.5.6 Ellipses and Elliptical Arcs in CLIM -------------------------------------- (defclass elliptical-thing () ((start-angle :initarg :start-angle) (end-angle :initarg :end-angle) (tr :initarg :tr))) ;a transformation from the unit circle to get the elliptical object (defmethod print-object ((ell elliptical-thing) stream) (with-slots (start-angle end-angle tr) ell (format stream "#<~A [~A ~A] ~A>" (type-of ell) (and start-angle (* (/ 180 pi) start-angle)) (and end-angle (* (/ 180 pi) end-angle)) tr))) (defclass standard-ellipse (elliptical-thing ellipse) ()) (defclass standard-elliptical-arc (elliptical-thing elliptical-arc) ()) ;;; ---- 2.5.6.1 Constructor Functions for Ellipses and Elliptical Arcs in CLIM --------- (defun make-ellipse (center-point radius-1-dx radius-1-dy radius-2-dx radius-2-dy &key start-angle end-angle) (make-ellipse* (point-x center-point) (point-y center-point) radius-1-dx radius-1-dy radius-2-dx radius-2-dy :start-angle start-angle :end-angle end-angle)) (defun make-ellipse* (center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy &key start-angle end-angle) (make-ellipical-thing 'standard-ellipse center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy start-angle end-angle)) (defun make-elliptical-arc (center-point radius-1-dx radius-1-dy radius-2-dx radius-2-dy &key start-angle end-angle) (make-elliptical-arc* (point-x center-point) (point-y center-point) radius-1-dx radius-1-dy radius-2-dx radius-2-dy :start-angle start-angle :end-angle end-angle)) (defun make-elliptical-arc* (center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy &key start-angle end-angle) (make-ellipical-thing 'standard-elliptical-arc center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy start-angle end-angle)) (defun make-ellipical-thing (class center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy start-angle end-angle) (setf center-x (coerce center-x 'coordinate) center-y (coerce center-y 'coordinate) radius-1-dx (coerce radius-1-dx 'coordinate) radius-1-dy (coerce radius-1-dy 'coordinate) radius-2-dx (coerce radius-2-dx 'coordinate) radius-2-dy (coerce radius-2-dy 'coordinate) start-angle (and start-angle (coerce start-angle 'coordinate)) end-angle (and end-angle (coerce end-angle 'coordinate)) ) (let ((tr (make-3-point-transformation* 0 0 1 0 0 1 center-x center-y (+ center-x radius-1-dx) (+ center-y radius-1-dy) (+ center-x radius-2-dx) (+ center-y radius-2-dy)))) (cond ((and (null start-angle) (null end-angle))) ((null start-angle) (setf start-angle 0)) ((null end-angle) (setf end-angle (* 2 pi)))) (make-instance class :tr tr :start-angle start-angle :end-angle end-angle) )) (defmethod transform-region (transformation (self elliptical-thing)) (with-slots (start-angle end-angle tr) self ;; I think this should be untransform-angle below, as the ellipse angles ;; go counter-clockwise in screen coordinates, whereas our transformations ;; rotate clockwise.. -Hefner (let ((start-angle* (and start-angle (untransform-angle transformation start-angle))) (end-angle* (and end-angle (untransform-angle transformation end-angle)))) (when (reflection-transformation-p transformation) (rotatef start-angle* end-angle*)) (make-instance (type-of self) :tr (compose-transformations transformation tr) :start-angle start-angle* :end-angle end-angle*)))) (defmethod region-contains-position-p ((self standard-ellipse) x y) ;; XXX start/end angle still missing (with-slots (tr) self (multiple-value-bind (x y) (untransform-position tr x y) (<= (+ (* x x) (* y y)) 1)))) (defmethod bounding-rectangle* ((region standard-ellipse)) ;; XXX start/end angle still missing (with-slots (tr) region (flet ((contact-radius* (x y) "Returns coordinates of the radius of the point, in which the vector field (x y) touches the ellipse." (multiple-value-bind (xc yc) (untransform-distance tr x y) (let* ((d (sqrt (+ (* xc xc) (* yc yc)))) (xn (- (/ yc d))) (yn (/ xc d))) (transform-distance tr xn yn))))) (multiple-value-bind (cx cy) (ellipse-center-point* region) (if (zerop (ellipse-radii region)) (values cx cy cx cy) (multiple-value-bind (vdx vdy) (contact-radius* 1 0) (declare (ignore vdx)) (multiple-value-bind (hdx hdy) (contact-radius* 0 1) (declare (ignore hdy)) (let ((rx (abs hdx)) (ry (abs vdy))) (values (- cx rx) (- cy ry) (+ cx rx) (+ cy ry)))))))))) (defun intersection-line/unit-circle (x1 y1 x2 y2) "Computes the intersection of the line from (x1,y1) to (x2,y2) and the unit circle. If the intersection is empty, NIL is returned. Otherwise four values are returned: x1, y1, x2, y2; the start and end point of the resulting line." (let* ((dx (- x2 x1)) (dy (- y2 y1)) (a (+ (expt dx 2) (expt dy 2))) (b (+ (* 2 x1 dx) (* 2 y1 dy))) (c (+ (expt x1 2) (expt y1 2) -1))) (let ((s1 (- (/ (+ (sqrt (- (expt b 2) (* 4 a c))) b) (* 2 a)))) (s2 (- (/ (- b (sqrt (- (expt b 2) (* 4 a c)))) (* 2 a))))) (cond ((and (realp s1) (realp s2) (not (and (< s1 0) (< s2 0))) (not (and (> s1 1) (> s2 1)))) (let ((s1 (max 0 (min 1 s1))) (s2 (max 0 (min 1 s2)))) (values (+ x1 (* s1 dx)) (+ y1 (* s1 dy)) (+ x1 (* s2 dx)) (+ y1 (* s2 dy))))) (t nil))))) (defmethod region-intersection ((line line) (ellipse standard-ellipse)) (with-slots (tr) ellipse (multiple-value-bind (x1 y1 x2 y2) (multiple-value-call #'intersection-line/unit-circle (multiple-value-call #'untransform-position tr (line-start-point* line)) (multiple-value-call #'untransform-position tr (line-end-point* line))) (if x1 (multiple-value-call #'make-line* (transform-position tr x1 y1) (transform-position tr x2 y2)) +nowhere+)))) (defmethod region-intersection ((ellipse standard-ellipse) (line standard-line)) (region-intersection ellipse line)) ;;; ---- 2.5.6.2 Accessors for CLIM Elliptical Objects ----------------------------------- (defmethod ellipse-center-point* ((self elliptical-thing)) (with-slots (tr) self (transform-position tr 0 0))) (defmethod ellipse-center-point ((self elliptical-thing)) (with-slots (tr) self (transform-region tr (make-point 0 0)))) (defmethod ellipse-radii ((self elliptical-thing)) (with-slots (tr) self (multiple-value-bind (dx1 dy1) (transform-distance tr 1 0) (multiple-value-bind (dx2 dy2) (transform-distance tr 0 1) (values dx1 dy1 dx2 dy2))))) (defmethod ellipse-start-angle ((self elliptical-thing)) (with-slots (start-angle) self start-angle)) (defmethod ellipse-end-angle ((self elliptical-thing)) (with-slots (end-angle) self end-angle)) (defun ellipse-coefficients (ell) ;; Returns the coefficients of the equation specifing the ellipse as in ;; ax^2 + by^2 + cxy + dx + dy - f = 0 ;; Note 1: ;; The `f' here may seem to be superfluous, since you ;; could simply multiply the whole equation by 1/f. But this is ;; not the case, since `f' may as well be 0. ;; Note 2: ;; In the literature you often find something like ;; (x^2)/a + (y^2)/b - 1 = 0 for an axis aligned ellipse, but ;; I rather choose to treat all coefficients as simple factors instead ;; of denominators. (with-slots (tr) ell ;;warum die inverse hier? (multiple-value-bind (a b d e c f) (get-transformation (invert-transformation tr)) (values (+ (* a a) (* d d)) ; x**2 (+ (* b b) (* e e)) ; y**2 (+ (* 2 a b) (* 2 d e)) ; xy (+ (* 2 a c) (* 2 d f)) ; x (+ (* 2 b c) (* 2 e f)) ; y (+ (* c c) (* f f) -1)))) ) ;;; Straight from the horse's mouth -- moore ;;; ;;; Axis of an ellipse ;;; ------------------------- ;; Given an ellipse with its center at the origin, as ;; ax^2 + by^2 + cxy - 1 = 0 ;; The two axis of an ellipse are characterized by minimizing and ;; maximizing the radius. Let (x,y) be a point on the delimiter of the ;; ellipse. It's radius (distance from the origin) then is: ;; r^2 = x^2 + y^2 ;; To find the axis can now be stated as an minimization problem with ;; constraints. So mechanically construct the auxiliarry function H: ;; H = x^2 + y^2 - k(ax^2 + by^2 + cxy - 1) ;; So the following set of equations remain to be solved ;; (I) dH/dx = 0 = 2x + 2kax + kcy ;; (II) dH/dy = 0 = 2y + 2kby + kcx ;; (III) dH/dk = 0 = ax^2 + by^2 + cxy - 1 ;; Unfortunately, as I always do the math work - hopelessly, even - ;; Maxima is the tool of my choice: ;; g1: 2*x + 2*k*a*x + k*c*y$ ;; g2: 2*y + 2*k*b*y + k*c*x$ ;; g3: a*x*x + b*y*y + c*x*y -1$ ;; sol1: solve ([g1,g2],[k,y])$ ;; /* This yields two solutions because of the squares with occur. The ;; * last equation (G3) must therefore be handled for both solutions for ;; * y. ;; */ ;; y1: rhs(first(rest(first(sol1))))$ ;; y2: rhs(first(rest(first(rest(sol1)))))$ ;; /* Substitute the 'y' found. */ ;; sol2: solve(subst(y1,y,g3),x); ;; x11: rhs(first(sol2)); ;; x12: rhs(first(rest(sol2))); ;; sol3: solve(subst(y2,y,g3),x); ;; x21: rhs(first(sol3)); ;; x22: rhs(first(rest(sol3))); ;; /* dump everything */ ;; dumpsol([[x=x11,y=y1], [x=x12,y=y1], [x=x21,y=y2], [x=x22,y=y2]]); (defun ellipse-normal-radii* (ell) (multiple-value-bind (a b c) (ellipse-coefficients ell) (cond ((coordinate= 0 c) ;; this is the unit circle (values 0 (sqrt (/ 1 b)) (sqrt (/ 1 a)) 0)) (t (let* ((x1 (- (/ c (sqrt (+ (- (* (* c c) (sqrt (+ (* c c) (* b b) (- (* 2 a b)) (* a a))))) (- (* 2 (* b b) (sqrt (+ (* c c) (* b b) (- (* 2 a b)) (* a a))))) (* 2 a b (sqrt (+ (* c c) (* b b) (- (* 2 a b)) (* a a)))) (* 2 b (* c c)) (* 2 (expt b 3)) (- (* 4 a (* b b))) (* 2 (* a a) b)))))) (y1 (- (/ (+ (* (sqrt (+ (* c c) (* b b) (- (* 2 a b)) (* a a))) x1) (- (* b x1)) (* a x1)) c))) (x2 (- (/ c (sqrt (+ (* (* c c) (sqrt (+ (* c c) (* b b) (- (* 2 a b)) (* a a)))) (* 2 (* b b) (sqrt (+ (* c c) (* b b) (- (* 2 a b)) (* a a)))) (- (* 2 a b (sqrt (+ (* c c) (* b b) (- (* 2 a b)) (* a a))))) (* 2 b (* c c)) (* 2 (expt b 3)) (- (* 4 a (* b b))) (* 2 (* a a) b)))))) (y2 (- (/ (+ (- (* (sqrt (+ (* c c) (* b b) (- (* 2 a b)) (* a a))) x2)) (- (* b x2)) (* a x2)) c)))) (values x1 y1 x2 y2)))))) ;;; ---- Intersection of Ellipse vs. Ellipse --------------------------------------------- ;; Das ganze ist so unverstaendlich, ich muss noch mal nach meinen Notizen ;; fanden, um die Herleitung der Loesung fuer das Schnittproblem praesentieren ;; zu koennen. (defun intersection-ellipse/ellipse (e1 e2) ;; Eine der beiden Ellipsen fuehren wir zuerst auf den Einheitskreis zurueck. (let ((a (invert-transformation (slot-value e1 'tr)))) (let ((r (intersection-ellipse/unit-circle (transform-region a e2)))) (if (atom r) r (mapcar (lambda (p) (multiple-value-bind (x y) (transform-position (slot-value e1 'tr) (car p) (cdr p)) (make-point x y))) r))))) (defun intersection-ellipse/unit-circle (ell) (multiple-value-bind (a b c d e f) (ellipse-coefficients ell) (let ((pn (elli-polynom ell))) (cond ((= (length pn) 0) :coincident) (t (let ((ys (newton-iteration pn 0d0)) (res nil)) (dolist (y ys) (let ((x (sqrt (- 1 (* y y))))) (when (realp x) (when (coordinate= 0 (ellipse-equation a b c d e f x y)) (pushnew (cons x y) res :test #'equal)) (when (coordinate= 0 (ellipse-equation a b c d e f (- x) y)) (pushnew (cons (- x) y) res :test #'equal)) ))) res)) )))) (defun ellipse-equation (a b c d e f x y) (+ (* a x x) (* b y y) (* c x y) (* d x) (* e y) f)) (defun elli-polynom (ell) ;; Was ganz lustig ist, ist dass wir bei Kreisen immer ein Polynom ;; vom Grade zwei bekommen. (multiple-value-bind (a b c d e f) (ellipse-coefficients ell) (canonize-polynom (vector (+ (* (- b a) (- b a)) (* c c)) (+ (* 2 b e) (* -2 a e) (* 2 c d)) (+ (* e e) (* 2 (- b a) (+ a f)) (* -1 c c) (* d d)) (+ (* 2 e a) (* 2 e f) (* -2 c d)) (+ (* (+ a f) (+ a f)) (* -1 d d)) ))) ) ;; Wir basteln uns mal eine einfache Newtoniteration. Manchmal ;; scheitern wir noch hoffungslos an lokalen Minima. Ansonsten ist das ;; Konvergenzverhalten fuer unsere Aufgabe schon ganz gut. Aber wir ;; handeln uns durch das Abdividieren der Nullstellen z.T. noch ;; beachtliche Fehler ein; ich versuche das zu mildern in dem ich nach ;; Finden einer Nullstell noch eine paar Newtonschritte mit dem ;; Original-Polynom mache (newton-ziel-gerade). ;; Ich sollte man nicht so faul sein und die reichhaltige Literatur zu ;; Rate ziehen tun; es muss auch etwas bessers als Newtoniteration ;; geben. Ich habe da noch so vage Erinnerungen an die ;; Numerik-Vorlesung ... (defun newton-ziel-gerade (pn x &optional (n 4)) (cond ((= n 0) x) ((multiple-value-bind (f p2) (horner-schema pn x) (multiple-value-bind (f*) (horner-schema p2 x) (newton-ziel-gerade pn (- x (/ f f*)) (- n 1))))))) (defun solve-p1 (b c) (if (= b 0) nil (list (- (/ c b))))) (defun solve-p2 (a b c) (cond ((= a 0) (solve-p1 b c)) (t (let* ((p (/ b a)) (q (/ c a)) (d (- (/ (* p p) 4) q))) (cond ((< d 0) nil) ((= d 0) (list (/ p 2))) (t (list (+ (/ p 2) (sqrt d)) (- (/ p 2) (sqrt d))))))) )) (defun maybe-solve-polynom-trivially (pn) (case (length pn) (0 (values nil t)) (1 (values nil t)) (2 (values (solve-p1 (aref pn 0) (aref pn 1)) t)) (3 (values (solve-p2 (aref pn 0) (aref pn 1) (aref pn 2)) t)) (t (values nil nil)))) (defun canonize-polynom (pn) (cond ((= (length pn) 0) pn) ((coordinate= (aref pn 0) 0) (canonize-polynom (subseq pn 1))) (t pn))) (defun newton-iteration (polynom x-start) ;; ACHTUNG: Speziell auf unser problem angepasst, nicht ohne lesen uebernehmen! (multiple-value-bind (sol done?) (maybe-solve-polynom-trivially polynom) (cond (done? sol) (t (let ((x x-start) x1 (n 0) (pn polynom) (eps-f 0d0) (eps-f* 0d-16) (eps-x 1d-20) (m 20) ;maximal zahl schritte (res nil) ) (loop (cond ((> n m) (return))) (multiple-value-bind (f p2) (horner-schema pn x) (multiple-value-bind (f*) (horner-schema p2 x) (cond ((<= (abs f*) eps-f*) ;; Wir haengen an einer Extremstelle fest -- mit zufaelligem Startwert weiter. (setf x1 (+ 1d0 (random 2d0)))) (t (setf x1 (- x (/ f f*))) (cond ((or (<= (abs f) eps-f) (<= (abs (- x1 x)) eps-x)) ;; noch ein paar newton schritte, um das ergebnis zu verbessern (setf x1 (newton-ziel-gerade polynom x1)) (push x1 res) ;; abdividieren (multiple-value-bind (f p2) (horner-schema pn x1) f (setq pn (canonize-polynom p2)) (multiple-value-bind (sol done?) (maybe-solve-polynom-trivially pn) (when done? ;; Hier trotzdem noch nachiterieren -- ist das eine gute Idee? (setf sol (mapcar (lambda (x) (newton-ziel-gerade polynom x)) sol)) (setf res (nconc sol res)) (return)))) (setf x1 x-start) (setq n 0)) )))) (setf x (min 1d0 (max -1d0 x1))) ;Darf man das machen? (incf n))) res)) ))) (defun horner-schema (polynom x) ;; Wertet das polynom `polynom' mit Hilfe des Hornerschemas an der ;; Stelle `x' aus; Gibt zwei Werte zurueck: ;; - den Funktionswert ;; - die letzte Zeile des Hornerschemas (Divisionsergebnis) (let ((n (length polynom))) (cond ((= n 0) (values 0)) ((= n 1) (values (aref polynom 0) '#())) (t (let ((b (make-array (1- n)))) (setf (aref b 0) (aref polynom 0)) (do ((i 1 (+ i 1))) ((= i (- n 1)) (values (+ (* (aref b (- i 1)) x) (aref polynom i)) b)) (setf (aref b i) (+ (* (aref b (- i 1)) x) (aref polynom i))))))) )) ;;;; ==================================================================================================== (defmethod region-union ((a point) (b point)) (cond ((region-equal a b) a) (t (make-instance 'standard-region-union :regions (list a b))))) (defmethod region-intersection ((a point) (b point)) (cond ((region-equal a b) a) (t +nowhere+))) (defmethod region-equal ((a point) (b point)) (and (coordinate= (point-x a) (point-x b)) (coordinate= (point-y a) (point-y b)))) ;;; ==================================================================================================== ;;; ---- Rectangle Sets --------------------------------------------------------------------------------- (defclass standard-rectangle-set (region-set bounding-rectangle) ((bands ;; Represents the set of rectangles. This is list like: ;; ;; (( . ) ;; ( . ) ;; : ;; ()) ;; ;; := (x_i_1 u_i_1 x_i_2 u_i_2 ... x_i_m u_i_m) ;; ;; Now a point (x,y) is member of the rectangle set, if there is an ;; i, such that y member of [y_i, y_(i+1)] and x member of x_band_i. ;; ;; An x is member of an band i, if there is an j, such that x ;; member [x_i_j, u_i_j]. ;; ;; That is describes the possible x-coordinates in the ;; y-range [y_i, y_(i+1)]. ;; :initarg :bands :reader standard-rectangle-set-bands) ;; (bounding-rectangle ;; Caches the regions bounding-rectangle. Is either NIL or the ;; bounding-rectangle, represented by a list (x1 y1 x2 y2). :initform nil))) (defmethod map-over-region-set-regions (fun (self standard-rectangle-set) &key normalize) (with-slots (bands) self (cond ((or (null normalize) (eql normalize :x-banding)) (map-over-bands-rectangles (lambda (x1 y1 x2 y2) (funcall fun (make-rectangle* x1 y1 x2 y2))) bands)) ((eql normalize :y-banding) (map-over-bands-rectangles (lambda (y1 x1 y2 x2) (funcall fun (make-rectangle* x1 y1 x2 y2))) (xy-bands->yx-bands bands))) (t (error "Bad ~S argument to ~S: ~S" :normalize 'map-over-region-set-regions normalize)) ))) (defmethod region-set-regions ((self standard-rectangle-set) &key normalize) (let ((res nil)) (map-over-region-set-regions (lambda (r) (push r res)) self :normalize normalize) res)) (defun make-standard-rectangle-set (bands) (cond ((null bands) +nowhere+) ((and (= (length bands) 2) (null (cdr (second bands))) (= (length (cdr (first bands))) 2)) (make-rectangle* (first (cdar bands)) (caar bands) (second (cdar bands)) (caadr bands))) ((= (length (first bands)) 1) (make-standard-rectangle-set (rest bands))) (t (make-instance 'standard-rectangle-set :bands bands)) )) ;;; rectangle-set vs. rectangle-set (defmethod region-union ((xs standard-rectangle-set) (ys standard-rectangle-set)) (make-standard-rectangle-set (bands-union (standard-rectangle-set-bands xs) (standard-rectangle-set-bands ys)))) (defmethod region-intersection ((xs standard-rectangle-set) (ys standard-rectangle-set)) (make-standard-rectangle-set (bands-intersection (standard-rectangle-set-bands xs) (standard-rectangle-set-bands ys)))) (defmethod region-difference ((xs standard-rectangle-set) (ys standard-rectangle-set)) (make-standard-rectangle-set (bands-difference (standard-rectangle-set-bands xs) (standard-rectangle-set-bands ys)))) ;;; rectangle-set vs. rectangle and vice versa (defmethod region-union ((xs standard-rectangle-set) (ys standard-rectangle)) (region-union xs (rectangle->standard-rectangle-set ys))) (defmethod region-union ((xs standard-rectangle) (ys standard-rectangle-set)) (region-union (rectangle->standard-rectangle-set xs) ys)) (defmethod region-difference ((xs standard-rectangle-set) (ys standard-rectangle)) (region-difference xs (rectangle->standard-rectangle-set ys))) (defmethod region-difference ((xs standard-rectangle) (ys standard-rectangle-set)) (region-difference (rectangle->standard-rectangle-set xs) ys)) (defmethod region-intersection ((xs standard-rectangle-set) (ys standard-rectangle)) (region-intersection xs (rectangle->standard-rectangle-set ys))) (defmethod region-intersection ((xs standard-rectangle) (ys standard-rectangle-set)) (region-intersection (rectangle->standard-rectangle-set xs) ys)) ;;; rectangle vs rectangle (defmethod region-union ((xs standard-rectangle) (ys standard-rectangle)) (region-union (rectangle->standard-rectangle-set xs) (rectangle->standard-rectangle-set ys))) (defmethod region-difference ((xs standard-rectangle) (ys standard-rectangle)) (region-difference (rectangle->standard-rectangle-set xs) (rectangle->standard-rectangle-set ys))) (defmethod region-intersection ((xs standard-rectangle) (ys standard-rectangle)) (region-intersection (rectangle->standard-rectangle-set xs) (rectangle->standard-rectangle-set ys))) (defmethod region-intersection ((xr rectangle) (yr rectangle)) (region-intersection (rectangle->standard-rectangle-set xr) (rectangle->standard-rectangle-set yr))) ;;; (defmethod region-equal ((xs standard-rectangle-set) (ys standard-rectangle-set)) ;; Our bands representation is canonic (equal (standard-rectangle-set-bands xs) (standard-rectangle-set-bands ys))) (defmethod region-contains-position-p ((self standard-rectangle-set) x y) (block nil (map-over-bands (lambda (y1 y2 isum) (when (<= y1 y y2) (when (isum-member x isum) (return t))) (when (> y y2) (return nil))) (standard-rectangle-set-bands self)) nil)) (defmethod region-contains-region-p ((xs standard-rectangle-set) (point point)) (multiple-value-bind (x y) (point-position point) (region-contains-position-p xs x y))) ;;; ---- interval sums ---------------------------------------------------------------------------------- (defun isum-union* (xs ys) (isum-op xs ys boole-ior 0 0 nil)) (defun isum-difference* (xs ys) (isum-op xs ys boole-andc2 0 0 nil)) (defun isum-intersection* (xs ys) (isum-op xs ys boole-and 0 0 nil)) ;; You could optimize all this like hell, but I better let the code ;; alone. ;; BTW this is the first time I make use of boole-xyz (defun isum-op (as bs boole-op in-a in-b x0) (let (x) (cond ((and (null as) (null bs)) nil) (t (cond ((null bs) (setq in-a (- 1 in-a)) (setq x (pop as))) ((null as) (setq in-b (- 1 in-b)) (setq x (pop bs))) ((< (first as) (first bs)) (setq in-a (- 1 in-a)) (setq x (pop as))) ((< (first bs) (first as)) (setq in-b (- 1 in-b)) (setq x (pop bs))) (t (setq in-a (- 1 in-a) in-b (- 1 in-b)) (setq x (pop as)) (pop bs))) (cond ((zerop (boole boole-op in-a in-b)) (if x0 (list* x0 x (isum-op as bs boole-op in-a in-b nil)) (isum-op as bs boole-op in-a in-b x0))) (t (if (null x0) (isum-op as bs boole-op in-a in-b x) (isum-op as bs boole-op in-a in-b x0)))))))) ;;; ---- Bands ------------------------------------------------------------------------------------------ ;; A band list is represented by ;; ((x_0 . a_0) (x_1 . a_1) ... (x_n . nil)) ;; The a_i are the relevant interval sums for x in [x_i, x_(i+1)]. ;; The empty band could have been representated as ;; ((x . nil)) x arbitrary ;; But to get a cononic representation, I'll choose simply NIL. ;; A better representation would be ;; (x_0 a_0 x_1 a_1 ... x_n) ;; Pro: Unlimited bands could be represented by simply skipping the ;; first or last 'x'. So similar representation could apply to ;; interval sums also. But I let the representation as it is, since ;; this version is well tested. (defun bands-op (as bs isum-op z0 a b) (let (z1) (cond ((and (null as) (null bs)) (if z0 (list (cons z0 nil)) nil)) (t (setq z1 (cond ((null as) (caar bs)) ((null bs) (caar as)) (t (min (caar as) (caar bs))))) (let ((rest (bands-op (if (and as (= z1 (caar as))) (cdr as) as) (if (and bs (= z1 (caar bs))) (cdr bs) bs) isum-op z1 (if (and as (= z1 (caar as))) (cdar as) a) (if (and bs (= z1 (caar bs))) (cdar bs) b))) (isum (funcall isum-op a b))) (if z0 (if (and rest (equal isum (cdar rest))) (cons (cons z0 isum) (cdr rest)) (cons (cons z0 isum) rest)) rest))) ))) (defun canon-empty-bands (x) (cond ((null (cdr x)) nil) (t x))) (defun bands-union (as bs) (canon-empty-bands (bands-op as bs #'isum-union* nil nil nil))) (defun bands-intersection (as bs) (canon-empty-bands (bands-op as bs #'isum-intersection* nil nil nil))) (defun bands-difference (as bs) (canon-empty-bands (bands-op as bs #'isum-difference* nil nil nil))) (defun rectangle->xy-bands* (x1 y1 x2 y2) (list (list y1 x1 x2) (cons y2 nil))) (defun rectangle->yx-bands* (x1 y1 x2 y2) (list (list x1 y1 y2) (cons x2 nil))) (defun xy-bands->yx-bands (bands) ;; Das kann man sicherlich noch viel geschicker machen ... (let ((res nil)) (map-over-bands-rectangles (lambda (x1 y1 x2 y2) (setf res (bands-union res (rectangle->yx-bands* x1 y1 x2 y2)))) bands) res)) (defun map-over-bands-rectangles (fun bands) (map-over-bands (lambda (y1 y2 isum) (do ((p isum (cddr p))) ((null p)) (funcall fun (car p) y1 (cadr p) y2))) bands)) (defun map-over-bands (fun bands) (do ((q bands (cdr q))) ((null (cdr q))) (funcall fun (caar q) (caadr q) (cdar q)))) (defun isum-member (elt isum) (cond ((null isum) nil) ((< elt (car isum)) nil) ((<= elt (cadr isum)) t) (t (isum-member elt (cddr isum))))) (defun rectangle->standard-rectangle-set (rect) (multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* rect) (make-instance 'standard-rectangle-set :bands (rectangle->xy-bands* x1 y1 x2 y2)))) (defmethod transform-region (tr (self standard-rectangle-set)) (cond ((scaling-transformation-p tr) (multiple-value-bind (mxx mxy myx myy tx ty) (get-transformation tr) (declare (ignore mxy myx)) (let ((rev-x-p (< mxx 0)) (rev-y-p (< myy 0))) (flet ((correct (bands) (loop for ((y . nil) (nil . xs)) on (nreverse bands) collect `(,y . ,xs)))) (make-standard-rectangle-set (loop for band in (standard-rectangle-set-bands self) for new-band = (loop for x in (cdr band) collect (+ (* mxx x) tx) into new-xs finally (return (cons (+ (* myy (car band)) ty) (if rev-x-p (nreverse new-xs) new-xs)))) collect new-band into new-bands finally (return (if rev-y-p (correct new-bands) new-bands)))))))) (t ;; We have insufficient knowledge about the transformation, ;; so we have to take the union of all transformed rectangles. ;; Maybe there is a faster way to do this. (let ((res +nowhere+)) (map-over-region-set-regions (lambda (rect) (setf res (region-union res (transform-region tr rect)))) self) res)) )) ;;; ==================================================================================================== (defclass standard-bounding-rectangle (standard-rectangle) ()) (defmethod region-equal ((a everywhere-region) (b everywhere-region)) t) (defmethod region-equal ((a nowhere-region) (b nowhere-region)) t) (defmethod region-equal ((a everywhere-region) (b region)) nil) (defmethod region-equal ((a nowhere-region) (b region)) nil) (defmethod region-equal ((a region) (b everywhere-region)) nil) (defmethod region-equal ((a region) (b nowhere-region)) nil) (defmethod region-equal ((a standard-rectangle) (b standard-rectangle)) (multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* a) (multiple-value-bind (u1 v1 u2 v2) (rectangle-edges* b) (and (coordinate= x1 u1) (coordinate= y1 v1) (coordinate= x2 u2) (coordinate= y2 v2))))) (defmethod region-equal ((a standard-rectangle) (b path)) nil) (defmethod region-equal ((a path) (b standard-rectangle)) nil) (defmethod transform-region (tr (self everywhere-region)) (declare (ignore tr)) +everywhere+) (defmethod transform-region (tr (self nowhere-region)) (declare (ignore tr)) +nowhere+) (defmethod region-contains-position-p ((self everywhere-region) x y) (declare (ignore x y)) t) (defmethod region-contains-position-p ((self nowhere-region) x y) (declare (ignore x y)) nil) (defmethod region-contains-position-p ((self standard-region-union) x y) (some (lambda (r) (region-contains-position-p r x y)) (standard-region-set-regions self))) (defmethod region-contains-position-p ((self standard-region-intersection) x y) (every (lambda (r) (region-contains-position-p r x y)) (standard-region-set-regions self))) (defmethod region-contains-position-p ((self standard-region-difference) x y) (and (region-contains-position-p (standard-region-difference-a self) x y) (not (region-contains-position-p (standard-region-difference-b self) x y)))) ;; Trivial set operations (defmethod region-union ((a everywhere-region) (b region)) +everywhere+) (defmethod region-union ((a region) (b everywhere-region)) +everywhere+) (defmethod region-union ((a nowhere-region) (b region)) b) (defmethod region-union ((a region) (b nowhere-region)) a) (defmethod region-intersection ((a everywhere-region) (b region)) b) (defmethod region-intersection ((a region) (b everywhere-region)) a) (defmethod region-intersection ((a nowhere-region) (b region)) +nowhere+) (defmethod region-intersection ((a region) (b nowhere-region)) +nowhere+) ;;;(defmethod region-difference ((a everywhere-region) (b region)) b) (defmethod region-difference ((a region) (b everywhere-region)) +nowhere+) ;mit ohne alles (defmethod region-difference ((a nowhere-region) (b region)) +nowhere+) (defmethod region-difference ((a region) (b nowhere-region)) a) ;; dimensionally rule (defmethod region-union ((a area) (b path)) a) (defmethod region-union ((a path) (b point)) a) (defmethod region-union ((a area) (b point)) a) (defmethod region-union ((a path) (b area)) b) (defmethod region-union ((a point) (b path)) b) (defmethod region-union ((a point) (b area)) b) (defmethod transform-region (tr (self standard-region-difference)) (with-slots (a b) self (make-instance 'standard-region-difference :a (transform-region tr a) :b (transform-region tr b)))) (defmethod transform-region (tr (self standard-region-union)) (with-slots (regions) self (make-instance 'standard-region-union :regions (mapcar (lambda (r) (transform-region tr r)) regions)))) (defmethod transform-region (tr (self standard-region-intersection)) (with-slots (regions) self (make-instance 'standard-region-intersection :regions (mapcar (lambda (r) (transform-region tr r)) regions)))) (defmethod region-set-regions ((self standard-region-union) &key normalize) (declare (ignorable normalize)) (standard-region-set-regions self)) (defmethod region-set-regions ((self standard-region-intersection) &key normalize) (declare (ignorable normalize)) (standard-region-set-regions self)) (defmethod region-set-regions ((self standard-region-difference) &key normalize) (declare (ignorable normalize)) (list (standard-region-difference-a self) (standard-region-difference-b self))) (defmethod region-set-regions ((self region) &key normalize) (declare (ignorable normalize)) (list self)) (defmethod map-over-region-set-regions (fun (self standard-region-union) &key normalize) (declare (ignorable normalize)) (mapc fun (standard-region-set-regions self))) (defmethod map-over-region-set-regions (fun (self standard-region-intersection) &key normalize) (declare (ignorable normalize)) (mapc fun (standard-region-set-regions self))) (defmethod map-over-region-set-regions (fun (self standard-region-difference) &key normalize) (declare (ignorable normalize)) (funcall fun (standard-region-difference-a self)) (funcall fun (standard-region-difference-b self))) (defmethod map-over-region-set-regions (fun (self region) &key normalize) (declare (ignorable normalize)) (funcall fun self)) (defun line-intersection* (x1 y1 x2 y2 u1 v1 u2 v2) (let ((dx (- x2 x1)) (dy (- y2 y1)) (du (- u2 u1)) (dv (- v2 v1))) (let ((q (- (* dx dv) (* du dy)))) (cond ((not (and (<= (min x1 x2) (max u1 u2)) (<= (min u1 u2) (max x1 x2)) (<= (min y1 y2) (max v1 v2)) (<= (min v1 v2) (max y1 y2)))) nil) ((coordinate= 0 q) (cond ((coordinate= (* (- v1 y1) dx) (* (- u1 x1) dy)) ;; koninzident (cond ((> (abs dx) (abs dy)) (let* ((sx1 (max (min x1 x2) (min u1 u2))) (sx2 (min (max x1 x2) (max u1 u2))) (sy1 (+ (* (- sx1 x1) (/ dy dx)) x1)) (sy2 (+ (* (- sx2 x1) (/ dy dx)) x1))) (values :coincident sx1 sy1 sx2 sy2))) (t (let* ((sy1 (max (min y1 y2) (min v1 v2))) (sy2 (min (max y1 y2) (max v1 v2))) (sx1 (+ (* (- sy1 y1) (/ dx dy)) y1)) (sx2 (+ (* (- sy2 y1) (/ dx dy)) y1))) (values :coincident sx1 sy1 sx2 sy2))))) (t ;;paralell -- kein Schnitt nil))) (t (let ((x (/ (+ (* dx (- (* u1 dv) (* v1 du))) (* du (- (* y1 dx) (* x1 dy)))) q)) (y (/ (+ (* dy (- (* u1 dv) (* v1 du))) (* dv (- (* y1 dx) (* x1 dy)))) q))) (if (and (or (<= x1 x x2) (<= x2 x x1)) (or (<= u1 x u2) (<= u2 x u1)) (or (<= y1 y y2) (<= y2 y y1)) (or (<= v1 y v2) (<= v2 y v1))) (values :hit x y) nil)) ) )) )) (defmethod region-intersection ((a standard-line) (b standard-line)) (multiple-value-bind (x1 y1) (line-start-point* a) (multiple-value-bind (x2 y2) (line-end-point* a) (multiple-value-bind (u1 v1) (line-start-point* b) (multiple-value-bind (u2 v2) (line-end-point* b) (multiple-value-bind (r sx1 sy1 sx2 sy2) (line-intersection* x1 y1 x2 y2 u1 v1 u2 v2) (case r (:hit (make-point sx1 sy1)) (:coincident (make-line* sx1 sy1 sx2 sy2)) ((nil) +nowhere+)))))))) ;; IHMO the CLIM dimensionality rule is brain dead! (defmethod region-intersection ((a standard-polyline) (b region)) (let ((res +nowhere+)) ;; hack alert (map-over-polygon-segments (lambda (x1 y1 x2 y2) (setf res (region-union res (region-intersection (make-line* x1 y1 x2 y2) b)))) a) res)) (defmethod region-difference ((a standard-polyline) (b region)) (let ((res +nowhere+)) (map-over-polygon-segments (lambda (x1 y1 x2 y2) (setf res (region-union res (region-difference (make-line* x1 y1 x2 y2) b)))) a) res)) (defmethod region-difference ((a region) (b standard-polyline)) (map-over-polygon-segments (lambda (x1 y1 x2 y2) (setf a (region-difference a (make-line* x1 y1 x2 y2)))) b) a) (defmethod region-intersection ((b region) (a standard-polyline)) (region-intersection a b)) (defmethod region-intersection ((a region) (p point)) (multiple-value-bind (x y) (point-position p) (if (region-contains-position-p a x y) p +nowhere+))) (defmethod region-intersection ((p point) (a region)) (region-intersection a p)) (defmethod region-intersection ((a standard-region-union) (b region)) (let ((res +nowhere+)) (map-over-region-set-regions (lambda (r) (setf res (region-union res (region-intersection r b)))) a) res)) (defmethod region-intersection ((a region) (b standard-region-union)) (region-intersection b a)) (defmethod region-intersection ((a standard-rectangle-set) (b region)) (let ((res +nowhere+)) (map-over-region-set-regions (lambda (r) (setf res (region-union res (region-intersection r b)))) a) res)) (defmethod region-intersection ((a region) (b standard-rectangle-set)) (region-intersection b a)) (defmethod region-intersection ((a region) (b standard-region-intersection)) (map-over-region-set-regions (lambda (r) (setf a (region-intersection a r))) b) a) (defmethod region-intersection ((a standard-region-intersection) (b region)) (region-intersection b a)) (defmethod region-intersection ((a region) (b region)) (make-instance 'standard-region-intersection :regions (list a b))) (defmethod region-intersection ((x region) (y standard-region-difference)) (with-slots (a b) y (region-difference (region-intersection x a) b))) (defmethod region-intersection ((x standard-region-difference) (y region)) (with-slots (a b) x (region-difference (region-intersection y a) b))) (defmethod region-difference ((x area) (y path)) x) (defmethod region-difference ((x area) (y point)) x) (defmethod region-difference ((x path) (y point)) x) (defmethod region-difference ((x everywhere-region) (y region)) (make-instance 'standard-region-difference :a x :b y)) (defmethod region-difference ((x everywhere-region) (y nowhere-region)) x) (defmethod region-difference ((x everywhere-region) (y everywhere-region)) +nowhere+) (defmethod region-difference ((x region) (y standard-region-difference)) (with-slots (a b) y (region-union (region-difference x a) (region-intersection x b)))) (defmethod region-difference ((x region) (y standard-region-union)) ;; A \ (B1 u B2 .. u Bn) = ((((A \ B1) \ B2) ... ) \ Bn) (let ((res x)) (map-over-region-set-regions (lambda (a) (setf res (region-difference res a))) y) res)) (defmethod region-difference ((x standard-region-union) (y region)) ;; (A u B) \ C = A\C u B\C (let ((res +nowhere+)) (map-over-region-set-regions (lambda (a) (setf res (region-union res (region-difference a y)))) x) res)) (defmethod region-difference ((x region) (y standard-rectangle-set)) (let ((res x)) (map-over-region-set-regions (lambda (a) (setf res (region-difference res a))) y) res)) (defmethod region-difference ((x standard-rectangle-set) (y region)) (let ((res +nowhere+)) (map-over-region-set-regions (lambda (a) (setf res (region-union res (region-difference a y)))) x) res)) (defmethod region-difference ((x point) (y region)) (multiple-value-bind (px py) (point-position x) (if (region-contains-position-p y px py) +nowhere+ x))) (defmethod region-difference ((x standard-region-difference) (y region)) ;; (A\B)\C = A \ (B u C) (with-slots (a b) x (region-difference a (region-union b y)))) (defmethod region-difference ((x region) (y standard-region-intersection)) (let ((res +nowhere+)) (map-over-region-set-regions (lambda (b) (setf res (region-union res (region-difference x b)))) y) res)) ;; Diese CLIM dimensionality rule ist in hoechsten ma?e inkonsistent ;; und bringt mehr probleme als sie beseitigt. ;;; ---- Set operations on polygons --------------------------------------------------------------------- (defstruct (pg-edge (:constructor make-pg-edge* (x1 y1 x2 y2 extra))) x1 y1 x2 y2 extra) (defstruct pg-splitter links ;liste von punkten rechts) ; von unten nach oben (defun make-pg-edge (p1 p2 extra) (multiple-value-bind (x1 y1) (point-position p1) (multiple-value-bind (x2 y2) (point-position p2) (make-pg-edge* x1 y1 x2 y2 extra)))) (defmethod region-intersection ((a standard-polygon) (b standard-polygon)) (polygon-op a b #'logand)) (defmethod region-union ((a standard-polygon) (b standard-polygon)) (polygon-op a b #'logior)) (defmethod region-difference ((a standard-polygon) (b standard-polygon)) (polygon-op a b #'logandc2)) (defmethod region-intersection ((a standard-polygon) (b standard-rectangle)) (polygon-op a b #'logand)) (defmethod region-union ((a standard-polygon) (b standard-rectangle)) (polygon-op a b #'logior)) (defmethod region-difference ((a standard-polygon) (b standard-rectangle)) (polygon-op a b #'logandc2)) (defmethod region-intersection ((a standard-rectangle) (b standard-polygon)) (polygon-op a b #'logand)) (defmethod region-union ((a standard-rectangle) (b standard-polygon)) (polygon-op a b #'logior)) (defmethod region-difference ((a standard-rectangle) (b standard-polygon)) (polygon-op a b #'logandc2)) (defun polygon-op (pg1 pg2 &optional logop) (let ((sps nil)) (over-sweep-bands pg1 pg2 (lambda (sy0 sy1 S &aux (ys nil)) (setq ys (list sy0 sy1)) (dolist (k1 S) (dolist (k2 S) (multiple-value-bind (px py) (line-intersection** (pg-edge-x1 k1) (pg-edge-y1 k1) (pg-edge-x2 k1) (pg-edge-y2 k1) (pg-edge-x1 k2) (pg-edge-y1 k2) (pg-edge-x2 k2) (pg-edge-y2 k2)) (when (and px (< sy0 py sy1)) (pushnew py ys :test #'coordinate=))))) (setq ys (sort ys #'<)) (do ((q ys (cdr q))) ((null (cdr q))) (let ((by0 (car q)) (by1 (cadr q)) (R nil)) (dolist (k S) (when (> (pg-edge-y2 k) (pg-edge-y1 k)) (multiple-value-bind (x1 y1 x2 y2) (restrict-line-on-y-interval* (pg-edge-x1 k) (pg-edge-y1 k) (pg-edge-x2 k) (pg-edge-y2 k) by0 by1) (declare (ignore y1 y2)) (push (list x1 x2 (pg-edge-extra k)) R)))) (setq R (sort R #'< :key (lambda (x) (+ (first x) (second x))))) (labels ((add (lo lu ro ru) (dolist (s sps ;; ansonsten (push (make-pg-splitter :links (list lu lo) :rechts (list ru ro)) sps) ) (when (and (region-equal lo (car (pg-splitter-links s))) (region-equal ro (car (pg-splitter-rechts s)))) (push lu (pg-splitter-links s)) (push ru (pg-splitter-rechts s)) (return))) )) (let ((eintritt nil) (ina 0) (inb 0)) (dolist (k R) (ecase (third k) (:a (setq ina (- 1 ina))) (:b (setq inb (- 1 inb)))) (cond ((/= 0 (funcall logop ina inb)) (when (null eintritt) (setq eintritt k))) (t (when eintritt (add (make-point (first eintritt) by0) (make-point (second eintritt) by1) (make-point (first k) by0) (make-point (second k) by1)) (setq eintritt nil)) )))) ) )) ) ) (setq sps (delete +nowhere+ (mapcar #'pg-splitter->polygon sps))) (cond ((null sps) +nowhere+) ((null (cdr sps)) (car sps)) ((make-instance 'standard-region-union :regions sps))) )) (defun over-sweep-bands (pg1 pg2 fun) (let ((es (nconc (polygon->pg-edges pg1 :a) (polygon->pg-edges pg2 :b)))) (setq es (sort es #'< :key #'pg-edge-y1)) (let ((ep es) (sy (pg-edge-y1 (car es))) (S nil)) (do () ((null ep)) (setq S (delete-if (lambda (e) (<= (pg-edge-y2 e) sy)) S)) (do () ((or (null ep) (/= sy (pg-edge-y1 (car ep))))) (push (pop ep) S)) (let ((sy2 (or (and ep (pg-edge-y1 (car ep))) (reduce #'max (mapcar #'pg-edge-y2 S))))) (funcall fun sy sy2 S) (setq sy sy2)) )))) (defun polygon->pg-edges (pg extra) (let ((pts (polygon-points pg)) (res nil)) (let ((prev pts) (cur (cdr pts)) (next (cddr pts))) (loop (when (or (> (point-y (car next)) (point-y (car cur))) (and (= (point-y (car next)) (point-y (car cur))) (> (point-x (car next)) (point-x (car cur))))) (push (make-pg-edge (car cur) (car next) extra) res)) (when (or (> (point-y (car prev)) (point-y (car cur))) (and (= (point-y (car prev)) (point-y (car cur))) (> (point-x (car prev)) (point-x (car cur))))) (push (make-pg-edge (car cur) (car prev) extra) res)) (when (not (or (> (point-y (car next)) (point-y (car cur))) (and (= (point-y (car next)) (point-y (car cur))) (> (point-x (car next)) (point-x (car cur)))) (> (point-y (car next)) (point-y (car cur))) (and (= (point-y (car next)) (point-y (car cur))) (> (point-x (car next)) (point-x (car cur)))))) (push (make-pg-edge (car cur) (car cur) extra) res)) (psetq prev cur cur next next (or (cdr next) pts)) (when (eq prev pts) (return)) )) res)) (defun restrict-line-on-y-interval* (x1 y1 x2 y2 ry0 ry1) (let ((dx (- x2 x1)) (dy (- y2 y1))) (values (+ (* (- ry0 y1) (/ dx dy)) x1) ry0 (+ (* (- ry1 y1) (/ dx dy)) x1) ry1))) (defun pg-splitter->polygon (s) (make-polygon (clean-up-point-sequence (nconc (pg-splitter-links s) (reverse (pg-splitter-rechts s)))))) (defun clean-up-point-sequence (pts) (cond ((null (cdr pts)) pts) ((region-equal (car pts) (cadr pts)) (clean-up-point-sequence (cdr pts))) ((null (cddr pts)) pts) ((colinear-p (car pts) (cadr pts) (caddr pts)) (clean-up-point-sequence (list* (car pts) (caddr pts) (cdddr pts)))) (t (cons (car pts) (clean-up-point-sequence (cdr pts)))) )) (defun colinear-p (p1 p2 p3) (multiple-value-bind (x1 y1) (point-position p1) (multiple-value-bind (x2 y2) (point-position p2) (multiple-value-bind (x3 y3) (point-position p3) (coordinate= (* (- x2 x1) (- y3 y2)) (* (- x3 x2) (- y2 y1))))))) (defun line-intersection** (x1 y1 x2 y2 u1 v1 u2 v2) (let ((dx (- x2 x1)) (dy (- y2 y1)) (du (- u2 u1)) (dv (- v2 v1))) (let ((q (- (* dx dv) (* du dy)))) (cond ((coordinate= 0 q) nil) (t (let ((x (/ (+ (* dx (- (* u1 dv) (* v1 du))) (* du (- (* y1 dx) (* x1 dy)))) q)) (y (/ (+ (* dy (- (* u1 dv) (* v1 du))) (* dv (- (* y1 dx) (* x1 dy)))) q))) (values x y))))))) ;;; ----------------------------------------------------------------------------------------------------- (defmethod region-union ((a standard-region-union) (b nowhere-region)) a) (defmethod region-union ((b nowhere-region) (a standard-region-union)) a) (defmethod region-union ((a standard-region-union) (b region)) (assert (not (eq b +nowhere+))) (make-instance 'standard-region-union :regions (cons b (standard-region-set-regions a)))) (defmethod region-union ((b region) (a standard-region-union)) (assert (not (eq b +nowhere+))) (make-instance 'standard-region-union :regions (cons b (standard-region-set-regions a)))) (defmethod region-union ((a standard-region-union) (b standard-region-union)) (assert (not (eq b +nowhere+))) (assert (not (eq a +nowhere+))) (make-instance 'standard-region-union :regions (append (standard-region-set-regions a) (standard-region-set-regions b)))) (defmethod region-union ((a region) (b region)) (make-instance 'standard-region-union :regions (list a b))) (defmethod region-union ((a standard-rectangle-set) (b path)) a) (defmethod region-union ((b path) (a standard-rectangle-set)) a) (defmethod region-union ((a standard-rectangle-set) (b point)) a) (defmethod region-union ((b point) (a standard-rectangle-set)) a) ;;; ---- Intersection Line/Polygon ---------------------------------------------------------------------- (defun geraden-schnitt/prim (x1 y1 x12 y12 x2 y2 x22 y22) (let ((dx1 (- x12 x1)) (dy1 (- y12 y1)) (dx2 (- x22 x2)) (dy2 (- y22 y2))) ;; zwei geraden gegeben als ;; g : s -> (x1 + s*dx1, y1 + s*dy1) ;; h : t -> (x2 + t*dx2, y2 + t*dy2) ;; -> NIL | (s ; t) (let ((quot (- (* DX2 DY1) (* DX1 DY2)))) (if (coordinate= quot 0) nil (values (- (/ (+ (* DX2 (- Y1 Y2)) (* DY2 X2) (- (* DY2 X1))) quot)) (- (/ (+ (* DX1 (- Y1 Y2)) (* DY1 X2) (- (* DY1 X1))) quot)))) )) ) (defun geraden-gleichung (x0 y0 x1 y1 px py) ;; ??? This somehow tries to calculate the distance between a point ;; and a line. The sign of the result depends upon the side the point ;; is on wrt to the line. --GB (- (* (- py y0) (- x1 x0)) (* (- px x0) (- y1 y0)))) (defun position->geraden-fktn-parameter (x0 y0 x1 y1 px py) (let ((dx (- x1 x0)) (dy (- y1 y0))) (if (> (abs dx) (abs dy)) (/ (- px x0) dx) (/ (- py y0) dy)))) (defun map-over-schnitt-gerade/polygon (fun x1 y1 x2 y2 points) ;; This calles 'fun' with the "Geradenfunktionsparameter" of each ;; intersection of the line (x1,y1),(x2,y2) and the polygon denoted ;; by 'points' in a "sensible" way. --GB (let ((n (length points))) (dotimes (i n) (let ((pv (elt points (mod (- i 1) n))) ;the point before (po (elt points (mod i n))) ;the "current" point (pn (elt points (mod (+ i 1) n))) ;the point after (pnn (elt points (mod (+ i 2) n)))) ;the point after**2 (cond ;; The line goes directly thru' po ((line-contains-point-p** x1 y1 x2 y2 (point-x po) (point-y po)) (let ((sign-1 (geraden-gleichung x1 y1 x2 y2 (point-x pn) (point-y pn))) (sign-2 (geraden-gleichung x1 y1 x2 y2 (point-x pv) (point-y pv)))) (cond ((or (and (> sign-1 0) (< sign-2 0)) (and (< sign-1 0) (> sign-2 0))) ;; clear cases: the line croses the polygon's border (funcall fun (position->geraden-fktn-parameter x1 y1 x2 y2 (point-x po) (point-y po)) )) ((= sign-1 0) ;; more difficult: ;; The line is coincident with the edge po/pn (let ((sign-1 (geraden-gleichung x1 y1 x2 y2 (point-x pnn) (point-y pnn)))) (cond ((or (and (> sign-1 0) (< sign-2 0)) (and (< sign-1 0) (> sign-2 0))) ;; The line goes through the polygons border, by edge po/pn (funcall fun (position->geraden-fktn-parameter x1 y1 x2 y2 (point-x po) (point-y po)) )) (t ;; otherwise the line touches the polygon at the edge po/pn, ;; return both points (funcall fun (position->geraden-fktn-parameter x1 y1 x2 y2 (point-x po) (point-y po)) ) (funcall fun (position->geraden-fktn-parameter x1 y1 x2 y2 (point-x pn) (point-y pn)) ) )))) (t ;; all other cases: Line either touches polygon in ;; a point or in an edge [handled above]. --GB nil) ))) ((line-contains-point-p** x1 y1 x2 y2 (point-x pn) (point-y pn)) nil) (t (multiple-value-bind (k m) (geraden-schnitt/prim x1 y1 x2 y2 (point-x po) (point-y po) (point-x pn) (point-y pn)) (when (and k (<= 0 m 1)) ;Moegliche numerische Instabilitaet (funcall fun k))))))))) (defun schnitt-gerade/polygon-prim (x1 y1 x2 y2 points) (let ((res nil)) (map-over-schnitt-gerade/polygon (lambda (k) (push k res)) x1 y1 x2 y2 points) (sort res #'<))) (defun schnitt-line/polygon (x1 y1 x2 y2 polygon) (let ((ks (schnitt-gerade/polygon-prim x1 y1 x2 y2 (polygon-points polygon)))) (assert (evenp (length ks))) (let ((res nil)) (do ((q ks (cddr q))) ((null q)) (let ((k1 (max 0d0 (min 1d0 (car q)))) (k2 (max 0d0 (min 1d0 (cadr q))))) (when (/= k1 k2) (push (make-line* (+ x1 (* k1 (- x2 x1))) (+ y1 (* k1 (- y2 y1))) (+ x1 (* k2 (- x2 x1))) (+ y1 (* k2 (- y2 y1)))) res)))) (cond ((null res) +nowhere+) ((null (cdr res)) (car res)) (t (make-instance 'standard-region-union :regions res)) )))) (defmethod region-contains-position-p ((pg polygon) x y) (setf x (coerce x 'coordinate)) (setf y (coerce y 'coordinate)) (let ((n 0) (m 0)) (map-over-schnitt-gerade/polygon (lambda (k) (when (>= k 0) (incf n)) (incf m)) x y (+ x 1) y (polygon-points pg)) (assert (evenp m)) (oddp n))) (defmethod region-intersection ((a standard-line) (b standard-polygon)) (multiple-value-bind (x1 y1) (line-start-point* a) (multiple-value-bind (x2 y2) (line-end-point* a) (schnitt-line/polygon x1 y1 x2 y2 b)))) (defmethod region-intersection ((b standard-polygon) (a standard-line)) (multiple-value-bind (x1 y1) (line-start-point* a) (multiple-value-bind (x2 y2) (line-end-point* a) (schnitt-line/polygon x1 y1 x2 y2 b)))) (defmethod region-intersection ((a standard-line) (b standard-rectangle)) (multiple-value-bind (x1 y1) (line-start-point* a) (multiple-value-bind (x2 y2) (line-end-point* a) (schnitt-line/polygon x1 y1 x2 y2 b)))) (defmethod region-intersection ((b standard-rectangle) (a standard-line)) (multiple-value-bind (x1 y1) (line-start-point* a) (multiple-value-bind (x2 y2) (line-end-point* a) (schnitt-line/polygon x1 y1 x2 y2 b)))) (defmethod region-difference ((a standard-line) (b standard-polygon)) (multiple-value-bind (x1 y1) (line-start-point* a) (multiple-value-bind (x2 y2) (line-end-point* a) (differenz-line/polygon x1 y1 x2 y2 b)))) (defmethod region-difference ((a standard-line) (b standard-rectangle)) (multiple-value-bind (x1 y1) (line-start-point* a) (multiple-value-bind (x2 y2) (line-end-point* a) (differenz-line/polygon x1 y1 x2 y2 b)))) (defun differenz-line/polygon (x1 y1 x2 y2 polygon) (let ((ks (schnitt-gerade/polygon-prim x1 y1 x2 y2 (polygon-points polygon)))) (assert (evenp (length ks))) (let ((res nil) (res2 nil)) (push 0d0 res) (do ((q ks (cddr q))) ((null q)) (let ((k1 (max 0d0 (min 1d0 (car q)))) (k2 (max 0d0 (min 1d0 (cadr q))))) (when (/= k1 k2) (push k1 res) (push k2 res)))) (push 1d0 res) (setf res (nreverse res)) (do ((q res (cddr q))) ((null q)) (let ((k1 (car q)) (k2 (cadr q))) (when (/= k1 k2) (push (make-line* (+ x1 (* k1 (- x2 x1))) (+ y1 (* k1 (- y2 y1))) (+ x1 (* k2 (- x2 x1))) (+ y1 (* k2 (- y2 y1)))) res2)))) (cond ((null res2) +nowhere+) ((null (cdr res2)) (car res2)) (t (make-instance 'standard-region-union :regions res2)) )))) (defmethod region-difference ((a standard-line) (b standard-line)) (multiple-value-bind (x1 y1) (line-start-point* a) (multiple-value-bind (x2 y2) (line-end-point* a) (multiple-value-bind (u1 v1) (line-start-point* b) (multiple-value-bind (u2 v2) (line-end-point* b) (cond ((and (coordinate= 0 (geraden-gleichung x1 y1 x2 y2 u1 v1)) (coordinate= 0 (geraden-gleichung x1 y1 x2 y2 u2 v2))) (let ((k1 (position->geraden-fktn-parameter x1 y1 x2 y2 u1 v1)) (k2 (position->geraden-fktn-parameter x1 y1 x2 y2 u2 v2))) (psetq k1 (max 0 (min k1 k2)) k2 (min 1 (max k1 k2))) (let ((r (nconc (if (> k1 0) (list (make-line* x1 y1 (+ x1 (* k1 (- x2 x1))) (+ y1 (* k1 (- y2 y1))))) nil) (if (< k2 1) (list (make-line* (+ x1 (* k2 (- x2 x1))) (+ y1 (* k2 (- y2 y1))) x2 y2)) nil)))) (cond ((null r) +nowhere+) ((null (cdr r)) (car r)) (t (make-instance 'standard-region-union :regions r)) )))) (t a))))))) (defmethod region-union ((a standard-line) (b standard-line)) (multiple-value-bind (x1 y1) (line-start-point* a) (multiple-value-bind (x2 y2) (line-end-point* a) (multiple-value-bind (u1 v1) (line-start-point* b) (multiple-value-bind (u2 v2) (line-end-point* b) (cond ((and (coordinate= 0 (geraden-gleichung x1 y1 x2 y2 u1 v1)) (coordinate= 0 (geraden-gleichung x1 y1 x2 y2 u2 v2))) (let ((k1 (position->geraden-fktn-parameter x1 y1 x2 y2 u1 v1)) (k2 (position->geraden-fktn-parameter x1 y1 x2 y2 u2 v2))) (psetq k1 (min k1 k2) k2 (max k1 k2)) (cond ((and (<= k1 1) (>= k2 0)) (let ((k1 (min 0 k1)) (k2 (max 1 k2))) (make-line* (+ x1 (* k1 (- x2 x1))) (+ y1 (* k1 (- y2 y1))) (+ x1 (* k2 (- x2 x1))) (+ y1 (* k2 (- y2 y1)))))) (t (make-instance 'standard-region-union :regions (list a b)))))) ((and (coordinate= x1 u1) (coordinate= y1 v1)) (make-polyline* (list u2 v2 x1 y1 x2 y2))) ((and (coordinate= x2 u2) (coordinate= y2 v2)) (make-polyline* (list x1 y1 x2 y2 u1 v1))) ((and (coordinate= x1 u2) (coordinate= y1 v2)) (make-polyline* (list u1 v1 x1 y1 x2 y2))) ((and (coordinate= x2 u1) (coordinate= y2 v1)) (make-polyline* (list x1 y1 x2 y2 u2 v2))) (t (make-instance 'standard-region-union :regions (list a b))) )))))) (defmethod region-union ((a standard-polyline) (b standard-line)) (with-slots (points) a (cond ((polyline-closed a) (make-instance 'standard-region-union :regions (list a b))) ((region-equal (car points) (line-end-point b)) (make-polyline (cons (line-start-point b) points))) ((region-equal (car points) (line-start-point b)) (make-polyline (cons (line-end-point b) points))) ((region-equal (car (last points)) (line-end-point b)) (make-polyline (append points (list (line-start-point b))))) ((region-equal (car (last points)) (line-start-point b)) (make-polyline (append points (list (line-end-point b))))) (t (make-instance 'standard-region-union :regions (list a b)))))) (defmethod region-union ((a standard-line) (b standard-polyline)) (region-union b a)) (defmethod region-union ((a standard-polyline) (b standard-polyline)) (with-slots ((a-points points)) a (with-slots ((b-points points)) b (cond ((polyline-closed a) (make-instance 'standard-region-union :regions (list a b))) ((polyline-closed b) (make-instance 'standard-region-union :regions (list a b))) ((region-equal (car a-points) (car b-points)) (make-polyline (append (reverse (cdr a-points)) b-points))) ((region-equal (car (last a-points)) (car (last b-points))) (make-polyline (append a-points (reverse (cdr b-points))))) ((region-equal (car a-points) (car (last b-points))) (make-polyline (append b-points (cdr a-points)))) ((region-equal (car (last a-points)) (car b-points)) (make-polyline (append a-points (cdr b-points)))) (t (make-instance 'standard-region-union :regions (list a b))))))) (defmethod region-union ((a standard-rectangle-set) (b polygon)) (region-union (rectangle-set->polygon-union a) b)) (defmethod region-union ((a polygon) (b standard-rectangle-set)) (region-union a (rectangle-set->polygon-union b))) (defun rectangle-set->polygon-union (rs) (let ((res nil)) (map-over-region-set-regions (lambda (r) (push r res)) rs) (make-instance 'standard-region-union :regions res))) (defmethod region-union ((a standard-region-difference) (b region)) (make-instance 'standard-region-union :regions (list a b))) (defmethod region-union ((a region) (b standard-region-difference)) (make-instance 'standard-region-union :regions (list a b))) (defmethod region-equal ((a standard-line) (b standard-line)) (or (and (region-equal (line-start-point a) (line-start-point b)) (region-equal (line-end-point a) (line-end-point b))) (and (region-equal (line-start-point a) (line-end-point b)) (region-equal (line-end-point a) (line-start-point b))))) (defmethod region-union ((a nowhere-region) (b nowhere-region)) +nowhere+) (defmethod region-exclusive-or ((a region) (b region)) (region-union (region-difference a b) (region-difference b a))) (defmethod region-contains-region-p ((a region) (b point)) (region-contains-position-p a (point-x b) (point-y b))) ;; xxx was ist mit (region-contains-region-p x +nowhere+) ? (defmethod region-contains-region-p ((a everywhere-region) (b region)) t) (defmethod region-contains-region-p ((a nowhere-region) (b region)) nil) (defmethod region-contains-region-p ((a everywhere-region) (b everywhere-region)) t) (defmethod region-contains-region-p ((a region) (b everywhere-region)) ;; ??? was ist mit ;; (region-union (region-difference +everywhere+ X) X) ??? nil) (defmethod region-contains-region-p ((a region) (b nowhere-region)) t) ;; REGION-CONTAINS-REGION-P region1 region2 ;; ;; Returns t if all points in the region region2 are members of the ;; region region1; otherwise, it returns nil. ;; ;; aka region2 ist teilmenge von region1 aka B\A = 0 ;; ;; REGION-INTERSECTS-REGION-P region1 region2 ;; ;; Returns nil if region-intersection of the two regions region1 and ;; region2 would be +nowhere+; otherwise, it returns t. ;; ;; aka region1 und region2 sind nicht disjunkt aka AB /= 0 ;; ;; generic versions (defmethod region-equal ((a region) (b region)) (region-equal +nowhere+ (region-exclusive-or a b))) (defmethod region-intersects-region-p ((a region) (b region)) (not (region-equal +nowhere+ (region-intersection a b)))) (defmethod region-contains-region-p ((a region) (b region)) (or (eq a b) (region-equal +nowhere+ (region-difference b a)))) ;;;; ==================================================================================================== (defmethod bounding-rectangle* ((a standard-line)) (with-slots (x1 y1 x2 y2) a (values (min x1 x2) (min y1 y2) (max x1 x2) (max y1 y2)))) (defmethod bounding-rectangle* ((a standard-rectangle)) (with-standard-rectangle (x1 y1 x2 y2) a (values x1 y1 x2 y2))) (defmethod bounding-rectangle* ((self standard-rectangle-set)) (with-slots (bands bounding-rectangle) self (values-list (or bounding-rectangle (setf bounding-rectangle (let (bx1 by1 bx2 by2) (map-over-bands-rectangles (lambda (x1 y1 x2 y2) (setf bx1 (min (or bx1 x1) x1) bx2 (max (or bx2 x2) x2) by1 (min (or by1 y1) y1) by2 (max (or by2 y2) y2))) bands) (list bx1 by1 bx2 by2))))))) (defmethod bounding-rectangle* ((self standard-polygon)) (values (reduce #'min (mapcar #'point-x (polygon-points self))) (reduce #'min (mapcar #'point-y (polygon-points self))) (reduce #'max (mapcar #'point-x (polygon-points self))) (reduce #'max (mapcar #'point-y (polygon-points self))))) (defmethod bounding-rectangle* ((self standard-polyline)) (values (reduce #'min (mapcar #'point-x (polygon-points self))) (reduce #'min (mapcar #'point-y (polygon-points self))) (reduce #'max (mapcar #'point-x (polygon-points self))) (reduce #'max (mapcar #'point-y (polygon-points self))))) (defmethod bounding-rectangle* ((self standard-point)) (with-slots (x y) self (values x y x y))) (defmethod bounding-rectangle* ((self standard-region-union)) (let (bx1 by1 bx2 by2) (map-over-region-set-regions (lambda (r) (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* r) (setf bx1 (min (or bx1 x1) x1) bx2 (max (or bx2 x2) x2) by1 (min (or by1 y1) y1) by2 (max (or by2 y2) y2)))) self) (values bx1 by1 bx2 by2))) (defmethod bounding-rectangle* ((self standard-region-difference)) (with-slots (a b) self (cond ((eq a +everywhere+) (bounding-rectangle* b)) (t (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* a) (multiple-value-bind (u1 v1 u2 v2) (bounding-rectangle* b) (values (min x1 u1) (min y1 v1) (max x2 u2) (min y2 v2))))) ))) (defmethod bounding-rectangle* ((self standard-region-intersection)) ;; kill+yank alert (let (bx1 by1 bx2 by2) (map-over-region-set-regions (lambda (r) (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* r) (setf bx1 (min (or bx1 x1) x1) bx2 (max (or bx2 x2) x2) by1 (min (or by1 y1) y1) by2 (max (or by2 y2) y2)))) self) (values bx1 by1 bx2 by2))) ;;;; ==================================================================================================== (defun make-bounding-rectangle (x1 y1 x2 y2) (setf x1 (coerce x1 'coordinate) y1 (coerce y1 'coordinate) x2 (coerce x2 'coordinate) y2 (coerce y2 'coordinate)) (make-instance 'standard-bounding-rectangle :x1 (min x1 x2) :y1 (min y1 y2) :x2 (max x1 x2) :y2 (max y1 y2))) (defmethod bounding-rectangle ((region rectangle)) region) (defmethod bounding-rectangle ((region region)) (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* region) (make-bounding-rectangle x1 y1 x2 y2))) (defmacro with-bounding-rectangle* ((min-x min-y max-x max-y) region &body body) ;; What is the purpose of this macro; IHMO m.-v.-b. looks as nice as with-b.-.r. . `(multiple-value-bind (,min-x ,min-y ,max-x ,max-y) (bounding-rectangle* ,region) ,@body)) (defmethod bounding-rectangle-position ((self bounding-rectangle)) (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* self) (declare (ignore x2 y2)) (values x1 y1))) (defmethod set-bounding-rectangle-position ((self standard-rectangle) x y) ;;(error "DO NOT CALL ME") ;;Yes, but... output records are based on rectangles (with-standard-rectangle (x1 y1 x2 y2) self (setf (rectangle-edges* self) (values x y (+ x (- x2 x1)) (+ y (- y2 y1)))))) (defmethod bounding-rectangle-min-x ((self bounding-rectangle)) (nth-value 0 (bounding-rectangle* self))) (defmethod bounding-rectangle-min-y ((self bounding-rectangle)) (nth-value 1 (bounding-rectangle* self))) (defmethod bounding-rectangle-max-x ((self bounding-rectangle)) (nth-value 2 (bounding-rectangle* self))) (defmethod bounding-rectangle-max-y ((self bounding-rectangle)) (nth-value 3 (bounding-rectangle* self))) (defmethod bounding-rectangle-width ((self bounding-rectangle)) (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* self) (declare (ignore y1 y2)) (- x2 x1))) (defmethod bounding-rectangle-height ((self bounding-rectangle)) (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* self) (declare (ignore x1 x2)) (- y2 y1))) (defmethod bounding-rectangle-size ((self bounding-rectangle)) (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* self) (values (- x2 x1) (- y2 y1)))) ;;; (defmethod print-object ((self standard-rectangle) stream) (print-unreadable-object (self stream :type t :identity t) (with-standard-rectangle (x1 y1 x2 y2) self (format stream "X ~S:~S Y ~S:~S" x1 x2 y1 y2)))) ;;;; (defmethod region-intersects-region-p :around ((a bounding-rectangle) (b bounding-rectangle)) (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* a) (multiple-value-bind (u1 v1 u2 v2) (bounding-rectangle* b) (cond ((and (<= u1 x2) (<= x1 u2) (<= v1 y2) (<= y1 v2)) (call-next-method)) (t nil))))) (defmethod region-intersects-region-p ((a standard-rectangle) (b standard-rectangle)) (declare (ignorable a b)) ;; for rectangles, the bounding rectangle test is correct, so if we ;; wind up here, we just can return T. t ;;(multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* a) ;; (multiple-value-bind (u1 v1 u2 v2) (rectangle-edges* b) ;; (and (<= u1 x2) (<= x1 u2) ;; (<= v1 y2) (<= y1 v2)))) ) ;;; Internal helpers (defmacro with-grown-rectangle* (((out-x1 out-y1 out-x2 out-y2) (in-x1 in-y1 in-x2 in-y2) &key radius (radius-x radius) (radius-y radius) (radius-left radius-x) (radius-right radius-x) (radius-top radius-y) (radius-bottom radius-y)) &body body) `(multiple-value-bind (,out-x1 ,out-y1 ,out-x2 ,out-y2) (values (- ,in-x1 ,radius-left) (- ,in-y1 ,radius-top) (+ ,in-x2 ,radius-right) (+ ,in-y2 ,radius-bottom)) ,@body)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/0000750000175000017500000000000011347763412015665 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/modes.lisp0000644000175000017500000001336011345155772017677 0ustar pdmpdm;;; -*- Mode: Lisp; Package: DREI -*- ;;; (c) copyright 2007-2008 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; ;;; This file contains the implementation of the infrastructure for ;;; Drei "modes", loosely equivalent to Emacs minor modes. They modify ;;; aspects of the behavior of a view or syntax. (in-package :drei) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; The general mode protocol and macros. (defvar *global-modes* '() "A list of the names of modes globally available to Drei instances. Do not use this list to retrieve modes, use the function `available-modes' instead. The modes on this list are available to all Drei variants.") (defun applicable-modes (drei) "Return a list of the names of all modes applicable for `drei'." (remove-if-not #'(lambda (mode) (mode-applicable-p (view drei) mode)) (available-modes drei))) (defclass view-mode (mode) () (:documentation "The superclass for all view modes.")) (defclass syntax-mode (mode) () (:documentation "The superclass for all syntax modes.")) (defmacro define-mode (name (&rest superclasses) (&rest slot-specs) &rest options) "Define a toggable Drei mode. It is essentially a class, with the provided `name', `superclasses', `slot-specs' and `options'. It will automatically be a subclass of `mode'. Apart from the normal class options, `options' can also have a `:global' option, which when true signifies that the mode is globally available to all Drei instances. This option is true by default. Note that modes created via this macro are not applicable to anything." (let ((global t) (actual-options '())) (dolist (option options) (case (first option) (:global (setf global (second option))) (t (push option actual-options)))) `(progn (defclass ,name (,@superclasses mode) (,@slot-specs) ,@actual-options) ,(when global `(push ',name *global-modes*))))) (defmacro define-view-mode (name (&rest superclasses) (&rest slot-specs) &rest options) "Define a mode (as `define-mode') that is applicable to views. Apart from taking the same options as `define-mode', it also takes an `:applicable-views' option (nil by default) that is a list of views the mode should be applicable to. Multiple uses of this option are cumulative." (let ((applicable-views '()) (actual-options '())) (dolist (option options) (case (first option) (:applicable-views (setf applicable-views (append applicable-views (rest option)))) (t (push option actual-options)))) `(progn (define-mode ,name (,@superclasses view-mode) (,@slot-specs) ,@actual-options) ,@(loop for view in applicable-views collecting `(defmethod mode-directly-applicable-p or ((view ,view) (mode-name (eql ',name))) t))))) (defmacro define-syntax-mode (name (&rest superclasses) (&rest slot-specs) &rest options) "Define a mode (as `define-mode') that is applicable to syntaxes. Apart from taking the same options as `define-mode', it also takes an `:applicable-syntaxes' option (nil by default) that is a list of syntaxes the mode should be applicable to. Multiple uses of this option are cumulative." (let ((applicable-syntaxes '()) (actual-options '())) (dolist (option options) (case (first option) (:applicable-syntaxes (setf applicable-syntaxes (append applicable-syntaxes (rest option)))) (t (push option actual-options)))) `(progn (define-mode ,name (,@superclasses syntax-mode) (,@slot-specs) ,@actual-options) ,@(loop for syntax in applicable-syntaxes collecting `(defmethod mode-directly-applicable-p or ((syntax ,syntax) (mode-name (eql ',name))) t))))) (defmacro define-mode-toggle-commands (command-name (mode-name &optional (string-form (capitalize (string mode-name)))) &key (name t) command-table) "Define a simple command (named `command-name') for toggling the mode named by `mode-name' on and off. `String-form' is the name of the mode that will be put in the docstring, `name' and `command-table' work as in `define-command'." (check-type command-name symbol) (check-type mode-name symbol) (check-type string-form string) `(define-command (,command-name :name ,name :command-table ,command-table) () ,(concatenate 'string "Toggle " string-form " mode.") (if (mode-enabled-p (drei-instance) ',mode-name) (disable-mode (drei-instance) ',mode-name) (enable-mode (drei-instance) ',mode-name)))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/Persistent/0000750000175000017500000000000011347763412020025 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/Persistent/binseq-package.lisp0000640000175000017500000000422310524227664023572 0ustar pdmpdm;;; -*- mode: lisp -*- ;;; ;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic@yahoo.com) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (defpackage :binseq (:use :common-lisp) (:export #:binseq-p #:list-binseq #:binseq-list #:vector-binseq #:binseq-vector #:binseq-empty #:binseq-length #:binseq-front #:binseq-back #:binseq-get #:binseq-set #:binseq-sub #:binseq-cons #:binseq-snoc #:binseq-append #:binseq-insert #:binseq-insert* #:binseq-remove #:binseq-remove* #:obinseq-p #:list-obinseq #:obinseq-list #:vector-obinseq #:obinseq-vector #:obinseq-empty #:obinseq-length #:obinseq-front #:obinseq-back #:obinseq-get #:obinseq-set #:obinseq-sub #:obinseq-cons #:obinseq-snoc #:obinseq-append #:obinseq-insert #:obinseq-insert* #:obinseq-remove #:obinseq-remove* #:binseq2-p #:list-binseq2 #:binseq2-list #:vector-binseq2 #:binseq2-vector #:binseq2-empty #:binseq2-length #:binseq2-size #:binseq2-front #:binseq2-offset #:binseq2-back #:binseq2-front2 #:binseq2-line2 #:binseq2-back2 #:binseq2-get #:binseq2-set #:binseq2-get2 #:binseq2-set2 #:binseq2-sub #:binseq2-sub2 #:binseq2-cons #:binseq2-snoc #:binseq2-append #:binseq2-insert #:binseq2-insert2 #:binseq2-insert* #:binseq2-insert*2 #:binseq2-remove #:binseq2-remove2 #:binseq2-remove* #:binseq2-remove*2))cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/Persistent/obinseq.lisp0000640000175000017500000001550410524227664022364 0ustar pdmpdm;;; -*- mode: lisp -*- ;;; ;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic@yahoo.com) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Adaptation of binary sequences by Robert Will (real-world-phenomena.org) ;;; Optimized version of binseq.lisp: ;;; the contents of a leaf node must not be nil nor a cons. (in-package :binseq) (defun obinseq-p (s) (or (null s) (atom s) (and (consp s) (and (integerp (car s)) ; might wanna check the value (consp (cdr s)) (obinseq-p (cadr s)) (obinseq-p (cddr s)))))) (defun list-obinseq (l) (flet ((%split (l n) ; TODO: use side-effects to avoid consing (loop for b on l and i from 0 if (< i n) collect (car b) into a else do (return (values a b)) finally (return (values l nil))))) (cond ((null l) nil) ((null (cdr l)) (let ((e (car l))) (assert (and e (atom e)) nil "Sequence element must be a non-nil atom: ~S" e) e)) (t (let ((len (length l))) (multiple-value-bind (a b) (%split l (floor len 2)) `(,len . (,(list-obinseq a) . ,(list-obinseq b))))))))) (defun obinseq-list (s) (labels ((%to-list (s l) (cond ((null s) nil) ((atom s) (cons s l)) (t (%to-list (cadr s) (%to-list (cddr s) l)))))) (%to-list s nil))) (defun vector-obinseq (v &optional (start 0) (end (length v))) (cond ((= start end) nil) ((= (- end start) 1) (let ((e (aref v start))) (assert (and e (atom e)) nil "Sequence element must be a non-nil atom: ~S" e) e)) (t (let* ((len (- end start)) (mid (+ start (floor len 2)))) `(,len . (,(vector-obinseq v start mid) . ,(vector-obinseq v mid end))))))) (defun obinseq-vector (s) (let ((v (make-array (obinseq-length s)))) (labels ((%set-v (s o) (cond ((null s)) ((atom s) (setf (aref v o) s)) (t (let ((a (cadr s)) (b (cddr s))) (%set-v a o) (%set-v b (+ o (obinseq-length a)))))))) (%set-v s 0) v))) (defun obinseq-empty (s) (null s)) (defun obinseq-length (s) (cond ((null s) 0) ((atom s) 1) (t (car s)))) (defun obinseq-cons (e s) (obinseq-append e s)) (defun obinseq-snoc (e s) (obinseq-append s e)) (defun obinseq-append (a b) (labels ((%not-much-longer (a b) (<= (obinseq-length a) (* *imbalance-bound* (obinseq-length b)))) (%much-shorter (a b) (not (%not-much-longer b a))) (%similar-in-length (a b) (and (%not-much-longer a b) (%not-much-longer b a))) (%cond-single (la lb lc) (and (<= lb (* *imbalance-bound* lc)) (<= (+ lb lc) (* *imbalance-bound* la)))) (%cond-double (la lb lc) (<= (+ la lb) (* (+ 1 *imbalance-bound*) lc))) (%cons (a b) (let ((len (+ (obinseq-length a) (obinseq-length b)))) (assert (>= len 2)) `(,len . (,a . ,b)))) (%rotate-right (s1 s2) (cond ((consp s1) (let* ((a (cadr s1)) (b (cddr s1)) (la (obinseq-length a)) (lb (obinseq-length b)) (ls2 (obinseq-length s2))) (cond ((%cond-single la lb ls2) (%cons a (%cons b s2))) ((%cond-double la lb ls2) (let ((s11 (cadr b)) (s12 (cddr b))) (%cons (%cons a s11) (%cons s12 s2)))) (t (%append a (%append b s2)))))) (t (%append a (%append b s2))))) (%rotate-left (s1 s2) (cond ((consp s2) (let* ((a (cddr s2)) (b (cadr s2)) (la (obinseq-length a)) (lb (obinseq-length b)) (ls1 (obinseq-length s1))) (cond ((%cond-single la lb ls1) (%cons (%cons s1 b) a)) ((%cond-double la lb ls1) (let ((s21 (cddr b)) (s22 (cadr b))) (%cons (%cons s1 s22) (%cons s21 a)))) (t (%append (%append s1 b) a))))) (t (%append (%append s1 b) a)))) (%append (a b) (cond ((%similar-in-length a b) (%cons a b)) ((%much-shorter a b) (%rotate-left a b)) (t (%rotate-right a b))))) (cond ((null a) b) ((null b) a) (t (%append a b))))) (defun obinseq-front (s i) (cond ((<= i 0) nil) ((<= (obinseq-length s) i) s) ((<= i (obinseq-length (cadr s))) (obinseq-front (cadr s) i)) (t (obinseq-append (cadr s) (obinseq-front (cddr s) (- i (obinseq-length (cadr s)))))))) (defun obinseq-back (s i) (cond ((<= i 0) nil) ((<= (obinseq-length s) i) s) ((<= i (obinseq-length (cddr s))) (obinseq-back (cddr s) i)) (t (obinseq-append (obinseq-back (cadr s) (- i (obinseq-length (cddr s)))) (cddr s))))) (defun %ohas-index (s i) (and (<= 0 i) (< i (obinseq-length s)))) (defun %ohas-gap (s i) (and (<= 0 i) (<= i (obinseq-length s)))) (defun obinseq-get (s i) (assert (%ohas-index s i) nil "Index out of bounds: ~S, ~S" s i) (obinseq-back (obinseq-front s (1+ i)) 1)) (defun obinseq-set (s i e) (assert (%ohas-index s i) nil "Index out of bounds: ~S, ~S, ~S" s i e) (obinseq-append (obinseq-front s i) (obinseq-cons e (obinseq-back s (- (obinseq-length s) i 1))))) (defun obinseq-sub (s i n) (assert (and (>= n 0) (<= (+ i n) (obinseq-length s))) nil "Invalid subsequence bounds: ~S, ~S, ~S" s i n) (obinseq-back (obinseq-front s (+ i n)) n)) (defun obinseq-insert (s i e) (assert (%ohas-gap s i) nil "Index out of bounds: ~S, ~S, ~S" s i e) (obinseq-append (obinseq-front s i) (obinseq-cons e (obinseq-back s (- (obinseq-length s) i))))) (defun obinseq-insert* (s i s2) (assert (%ohas-gap s i) nil "Index out of bounds: ~S, ~S, ~S" s i s2) (if (null s2) s (obinseq-append (obinseq-front s i) (obinseq-append s2 (obinseq-back s (- (obinseq-length s) i)))))) (defun obinseq-remove (s i) (assert (%ohas-index s i) nil "Index out of bounds: ~S, ~S" s i) (obinseq-append (obinseq-front s i) (obinseq-back s (- (obinseq-length s) i 1)))) (defun obinseq-remove* (s i n) (assert (%ohas-index s i) nil "Start index out of bounds: ~S, ~S, ~S" s i n) (assert (and (>= n 0) (<= (+ i n) (obinseq-length s))) nil "Count out of range: ~S, ~S, ~S" s i n) (if (zerop n) s (obinseq-append (obinseq-front s i) (obinseq-back s (- (obinseq-length s) i n)))))cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/Persistent/README0000640000175000017500000000072210524227664020707 0ustar pdmpdmThis directory contains code with persistent data structures that are primarily meant to be used for buffer implementation, but may also be used as just balanced trees. To use any of these buffer implementations (binseq-buffer or obinseq-buffer), pass them as the :implementation argument when instatiating climacs-buffer class in pane.lisp. NOTE: There is a dependency of Persistent/persistent-buffer.lisp on Flexichain/utilities.lisp (the weak pointer handling).cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/Persistent/binseq2.lisp0000640000175000017500000002717610524227664022277 0ustar pdmpdm;;; -*- mode: lisp -*- ;;; ;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic@yahoo.com) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Adaptation of binary sequences by Robert Will (real-world-phenomena.org) ;;; Differs from binseq in: ;;; nodes contain two counts: number of lines and number of objects ;;; leafs contain obinseqs representing lines (in-package :binseq) (defun binseq2-p (s) ; NOTE: should use a 3-vector instead of the 3-list... (or (eq s 'empty) (and (consp s) (or (and (eq (car s) 'leaf) (obinseq-p (cdr s))) (and (eq (car s) 'node) (let ((nc (cadr s))) (and (consp nc) (integerp (car nc)) (integerp (cdr nc)))) (consp (cddr s)) (binseq2-p (caddr s)) (binseq2-p (cdddr s))))))) (defun list-binseq2* (l) ; l is a list of obinseqs (flet ((%split (l n) ; TODO: use side-effects to avoid consing (loop for b on l and i from 0 if (< i n) collect (car b) into a else do (return (values a b)) finally (return (values l nil))))) (cond ((null l) 'empty) ((null (cdr l)) `(leaf . ,(car l))) (t (let ((len (length l))) (multiple-value-bind (a b) (%split l (floor len 2)) (let* ((sa (list-binseq2* a)) (sb (list-binseq2* b)) (size (+ (binseq2-size sa) (binseq2-size sb)))) `(node . ((,len . ,size) . (,sa . ,sb)))))))))) (defun list-binseq2 (l) ; TODO: use side-effects to avoid consing (list-binseq2* (loop with curr = nil and ll = nil for e in l do (push e curr) (when (eql e #\Newline) (push (list-obinseq (nreverse curr)) ll) (setf curr nil)) finally (when curr (push (list-obinseq (nreverse curr)) ll)) (return (nreverse ll))))) (defun binseq2-list (s) (labels ((%to-list (s l) (cond ((eq s 'empty) l) ((eq (car s) 'leaf) (nconc (obinseq-list (cdr s)) l)) (t (%to-list (caddr s) (%to-list (cdddr s) l)))))) (%to-list s nil))) (defun vector-binseq2 (v) (list-binseq2* (loop with len = (length v) for start = 0 then end while (< start len) for end = (1+ (or (position #\Newline v :start start) (1- len))) collect (vector-obinseq v start end)))) (defun binseq2-vector (s) (let ((v (make-array (binseq2-size s)))) (labels ((%set2-v (s o) (cond ((eq s 'empty)) ((eq (car s) 'leaf) (%set-v (cdr s) o)) (t (let ((a (caddr s)) (b (cdddr s))) (%set2-v a o) (%set2-v b (+ o (binseq2-size a))))))) (%set-v (s o) (cond ((null s)) ((atom s) (setf (aref v o) s)) (t (let ((a (cadr s)) (b (cddr s))) (%set-v a o) (%set-v b (+ o (obinseq-length a)))))))) (%set2-v s 0)) v)) (defun binseq2-empty (s) (eq s 'empty)) (defun binseq2-length (s) (cond ((eq s 'empty) 0) ((eq (car s) 'leaf) 1) (t (caadr s)))) (defun binseq2-size (s) (cond ((eq s 'empty) 0) ((eq (car s) 'leaf) (obinseq-length (cdr s))) (t (cdadr s)))) (defun binseq2-cons (e s) (binseq2-append `(leaf . ,e) s)) (defun binseq2-snoc (e s) (binseq2-append s `(leaf . ,e))) (defun binseq2-possibly-append-end-lines (a b) "If the last line of A does not end with a newline, remove the first line of B and append it to the last line of A; otherwise, do nothing." (let ((a-last-line (cdr (binseq2-back a 1)))) (if (eql (obinseq-back a-last-line 1) #\Newline) (values a b) (values (binseq2-set a (1- (binseq2-length a)) (obinseq-append a-last-line (cdr (binseq2-front b 1)))) (binseq2-back b (1- (binseq2-length b))))))) ;;;(defparameter *imbalance-bound* 3) ; must be >= 3 (defun binseq2-append (a b) (labels ((%not-much-longer (a b) (<= (binseq2-length a) (* *imbalance-bound* (binseq2-length b)))) (%much-shorter (a b) (not (%not-much-longer b a))) (%similar-in-length (a b) (and (%not-much-longer a b) (%not-much-longer b a))) (%cond-single (la lb lc) (and (<= lb (* *imbalance-bound* lc)) (<= (+ lb lc) (* *imbalance-bound* la)))) (%cond-double (la lb lc) (<= (+ la lb) (* (+ 1 *imbalance-bound*) lc))) (%cons (a b) (let ((len (+ (binseq2-length a) (binseq2-length b))) (size (+ (binseq2-size a) (binseq2-size b)))) (assert (>= len 2)) `(node . ((,len . ,size) . (,a . ,b))))) (%rotate-right (s1 s2) (cond ((and (consp s1) (eq (car s1) 'node)) (let* ((a (caddr s1)) (b (cdddr s1)) (la (binseq2-length a)) (lb (binseq2-length b)) (ls2 (binseq2-length s2))) (cond ((%cond-single la lb ls2) (%cons a (%cons b s2))) ((%cond-double la lb ls2) (let ((s11 (caddr b)) (s12 (cdddr b))) (%cons (%cons a s11) (%cons s12 s2)))) (t (%append a (%append b s2)))))) (t (%append a (%append b s2))))) (%rotate-left (s1 s2) (cond ((and (consp s2) (eq (car s2) 'node)) (let* ((a (cdddr s2)) (b (caddr s2)) (la (binseq2-length a)) (lb (binseq2-length b)) (ls1 (binseq2-length s1))) (cond ((%cond-single la lb ls1) (%cons (%cons s1 b) a)) ((%cond-double la lb ls1) (let ((s21 (cdddr b)) (s22 (caddr b))) (%cons (%cons s1 s22) (%cons s21 a)))) (t (%append (%append s1 b) a))))) (t (%append (%append s1 b) a)))) (%append (a b) (cond ((%similar-in-length a b) (%cons a b)) ((%much-shorter a b) (%rotate-left a b)) (t (%rotate-right a b))))) (cond ((eq a 'empty) b) ((eq b 'empty) a) (t (multiple-value-bind (a2 b2) (binseq2-possibly-append-end-lines a b) (cond ((eq a2 'empty) b2) ((eq b2 'empty) a2) (t (%append a2 b2)))))))) ;;; Functions whose names end with '2' are passed objects and object offsets ;;; and return binseq2s that are possibly accordingly truncated (defun binseq2-front (s i) (cond ((<= i 0) 'empty) ((<= (binseq2-length s) i) s) ((<= i (binseq2-length (caddr s))) (binseq2-front (caddr s) i)) (t (binseq2-append (caddr s) (binseq2-front (cdddr s) (- i (binseq2-length (caddr s)))))))) (defun binseq2-offset (s i) (labels ((%offset (s i o) (cond ((or (eq s 'empty) (<= i 0) (eq (car s) 'leaf)) o) ((< i (binseq2-length (caddr s))) (%offset (caddr s) i o)) (t (%offset (cdddr s) (- i (binseq2-length (caddr s))) (+ o (binseq2-size (caddr s)))))))) (%offset s i 0))) (defun binseq2-front2 (s i) (cond ((<= i 0) 'empty) ((<= (binseq2-size s) i) s) ((eq (car s) 'leaf) `(leaf . ,(obinseq-front (cdr s) i))) ((<= i (binseq2-size (caddr s))) (binseq2-front2 (caddr s) i)) (t (binseq2-append (caddr s) (binseq2-front2 (cdddr s) (- i (binseq2-size (caddr s)))))))) (defun binseq2-line2 (s i) (labels ((%line (s i o) (cond ((or (eq s 'empty) (<= i 0) (eq (car s) 'leaf)) o) ((< i (binseq2-size (caddr s))) (%line (caddr s) i o)) (t (%line (cdddr s) (- i (binseq2-size (caddr s))) (+ o (binseq2-length (caddr s)))))))) (%line s i 0))) (defun binseq2-back (s i) (cond ((<= i 0) 'empty) ((<= (binseq2-length s) i) s) ((<= i (binseq2-length (cdddr s))) (binseq2-back (cdddr s) i)) (t (binseq2-append (binseq2-back (caddr s) (- i (binseq2-length (cdddr s)))) (cdddr s))))) (defun binseq2-back2 (s i) (cond ((<= i 0) 'empty) ((<= (binseq2-size s) i) s) ((eq (car s) 'leaf) `(leaf . ,(obinseq-back (cdr s) i))) ((<= i (binseq2-size (cdddr s))) (binseq2-back2 (cdddr s) i)) (t (binseq2-append (binseq2-back2 (caddr s) (- i (binseq2-size (cdddr s)))) (cdddr s))))) (defun %has2-index (s i) (and (<= 0 i) (< i (binseq2-length s)))) (defun %has2-index2 (s i) (and (<= 0 i) (< i (binseq2-size s)))) (defun %has2-gap (s i) (and (<= 0 i) (<= i (binseq2-length s)))) (defun %has2-gap2 (s i) (and (<= 0 i) (<= i (binseq2-size s)))) (defun binseq2-get (s i) (assert (%has2-index s i) nil "Index out of bounds: ~S, ~S" s i) (cdr (binseq2-back (binseq2-front s (1+ i)) 1))) (defun binseq2-get2 (s i) (assert (%has2-index2 s i) nil "Index out of bounds: ~S, ~S" s i) (cdr (binseq2-back2 (binseq2-front2 s (1+ i)) 1))) (defun binseq2-set (s i e) (assert (%has2-index s i) nil "Index out of bounds: ~S, ~S" s i) (binseq2-append (binseq2-front s i) (binseq2-cons e (binseq2-back s (- (binseq2-length s) i 1))))) (defun binseq2-set2 (s i e) ; an object is also a leaf obinseq! (assert (%has2-index2 s i) nil "Index out of bounds: ~S, ~S" s i) (assert (and e (atom e))) (binseq2-append (binseq2-front2 s i) (binseq2-cons e (binseq2-back2 s (- (binseq2-size s) i 1))))) (defun binseq2-sub (s i n) (assert (and (>= n 0) (<= (+ i n) (binseq2-length s))) nil "Invalid subsequence bounds: ~S, ~S, ~S" s i n) (binseq2-back (binseq2-front s (+ i n)) n)) (defun binseq2-sub2 (s i n) (assert (and (>= n 0) (<= (+ i n) (binseq2-size s))) nil "Invalid subsequence bounds: ~S, ~S, ~S" s i n) (binseq2-back2 (binseq2-front2 s (+ i n)) n)) (defun binseq2-insert (s i e) (assert (%has2-gap s i) nil "Index out of bounds: ~S, ~S, ~S" s i e) (binseq2-append (binseq2-front s i) (binseq2-cons e (binseq2-back s (- (binseq2-length s) i))))) (defun binseq2-insert2 (s i e) ; an object is also a leaf obinseq! (assert (%has2-gap2 s i) nil "Index out of bounds: ~S, ~S, ~S" s i e) (assert (and e (atom e))) (binseq2-append (binseq2-front2 s i) (binseq2-cons e (binseq2-back2 s (- (binseq2-size s) i))))) (defun binseq2-insert* (s i s2) (assert (%has2-gap s i) nil "Index out of bounds: ~S, ~S, ~S" s i s2) (if (eq s2 'empty) s (binseq2-append (binseq2-front s i) (binseq2-append s2 (binseq2-back s (- (binseq2-length s) i)))))) (defun binseq2-insert*2 (s i s2) (assert (%has2-gap2 s i) nil "Index out of bounds: ~S, ~S, ~S" s i s2) (if (eq s2 'empty) s (binseq2-append (binseq2-front2 s i) (binseq2-append s2 (binseq2-back2 s (- (binseq2-size s) i)))))) (defun binseq2-remove (s i) (assert (%has2-index s i) nil "Index out of bounds: ~S, ~S" s i) (binseq2-append (binseq2-front s i) (binseq2-back s (- (binseq2-length s) i 1)))) (defun binseq2-remove2 (s i) (assert (%has2-index2 s i) nil "Index out of bounds: ~S, ~S" s i) (binseq2-append (binseq2-front2 s i) (binseq2-back2 s (- (binseq2-size s) i 1)))) (defun binseq2-remove* (s i n) (assert (%has2-index s i) nil "Start index out of bounds: ~S, ~S, ~S" s i n) (assert (and (>= n 0) (<= (+ i n) (binseq2-length s))) nil "Count out of range: ~S, ~S, ~S" s i n) (if (zerop n) s (binseq2-append (binseq2-front s i) (binseq2-back s (- (binseq2-length s) i n))))) (defun binseq2-remove*2 (s i n) (assert (%has2-index2 s i) nil "Start index out of bounds: ~S, ~S, ~S" s i n) (assert (and (>= n 0) (<= (+ i n) (binseq2-size s))) nil "Count out of range: ~S, ~S, ~S" s i n) (if (zerop n) s (binseq2-append (binseq2-front2 s i) (binseq2-back2 s (- (binseq2-size s) i n)))))cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/Persistent/persistent-buffer.lisp0000640000175000017500000006301010741375213024361 0ustar pdmpdm;;; -*- mode: lisp -*- ;;; ;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic@yahoo.com) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; A persistent buffer uses a persistent data structure for its ;;; contents, provides cursors into contents, and contains cursors ;;; into the current contents. (in-package :drei-buffer) ;;; For now, pos contains just an integer, while it might contain a cons ;;; of two adjacent buffer elements for higher performance (with the help ;;; of buffer implementation, especially the rebalancing part). (defclass persistent-cursor () ((buffer :reader buffer :initarg :buffer) ; TODO: fix overlap with mark? (pos :accessor cursor-pos)) (:documentation "The (non-persistent) cursor into PERSISTENT-BUFFER.")) (defclass left-sticky-persistent-cursor (persistent-cursor) ()) (defclass right-sticky-persistent-cursor (persistent-cursor) ()) (defclass line-cursor-mixin () () (:documentation "Support for line-oriented buffers.")) (defclass left-sticky-line-persistent-cursor (left-sticky-persistent-cursor line-cursor-mixin) ()) (defclass right-sticky-line-persistent-cursor (right-sticky-persistent-cursor line-cursor-mixin) ()) (defmethod cursor-pos ((cursor left-sticky-persistent-cursor)) (1+ (slot-value cursor 'pos))) (defmethod (setf cursor-pos) (position (cursor left-sticky-persistent-cursor)) (assert (<= 0 position (size (buffer cursor))) () "Cursor position out of bounds: ~S, ~S" cursor position) (setf (slot-value cursor 'pos) (1- position))) (defmethod cursor-pos ((cursor right-sticky-persistent-cursor)) (slot-value cursor 'pos)) (defmethod (setf cursor-pos) (position (cursor right-sticky-persistent-cursor)) (assert (<= 0 position (size (buffer cursor))) () "Cursor position out of bounds: ~S, ~S" cursor position) (setf (slot-value cursor 'pos) position)) (defclass persistent-buffer (buffer) ((cursors :accessor cursors :initform nil)) (:documentation "The Climacs persistent buffer base class \(non-instantiable).")) (defmethod initialize-instance :after ((cursor left-sticky-persistent-cursor) &rest initargs &key (position 0)) (declare (ignorable initargs)) (with-slots (buffer pos) cursor (setf pos (1- position)) (with-slots (cursors) buffer (push (flexichain::make-weak-pointer cursor) cursors)))) (defmethod initialize-instance :after ((cursor right-sticky-persistent-cursor) &rest initargs &key (position 0)) (declare (ignorable initargs)) (with-slots (buffer pos) cursor (setf pos position) (with-slots (cursors) buffer (push (flexichain::make-weak-pointer cursor) cursors)))) (defclass binseq-buffer (persistent-buffer) ((contents :initform (list-binseq nil))) (:documentation "An instantiable subclass of PERSISTENT-BUFFER that uses a binary sequence for the CONTENTS slot.")) (defclass obinseq-buffer (persistent-buffer) ((contents :initform (list-obinseq nil))) (:documentation "An instantiable subclass of PERSISTENT-BUFFER that uses an optimized binary sequence (only non-nil atoms are allowed as elements) for the CONTENTS slot.")) (defclass binseq2-buffer (persistent-buffer) ((contents :initform (list-binseq2 nil))) (:documentation "An instantiable subclass of PERSISTENT-BUFFER that uses a binary sequence for lines and optimized binary sequences for line contents, all kept in the CONTENTS slot.")) (defclass p-mark-mixin () ((buffer :initarg :buffer :reader buffer) (cursor :reader cursor)) (:documentation "A mixin class used in the initialization of a mark that is used in a PERSISTENT-BUFFER.")) (defclass p-line-mark-mixin (p-mark-mixin) () (:documentation "A persistent mark mixin class that works with cursors that can efficiently work with lines.")) (defmethod backward-object ((mark p-mark-mixin) &optional (count 1)) (decf (offset mark) count)) (defmethod forward-object ((mark p-mark-mixin) &optional (count 1)) (incf (offset mark) count)) (defmethod offset ((mark p-mark-mixin)) (cursor-pos (cursor mark))) (defmethod (setf offset) (new-offset (mark p-mark-mixin)) (assert (<= 0 new-offset) () (make-condition 'motion-before-beginning :offset new-offset)) (assert (<= new-offset (size (buffer mark))) () (make-condition 'motion-after-end :offset new-offset)) (setf (cursor-pos (cursor mark)) new-offset)) (defclass persistent-left-sticky-mark (left-sticky-mark p-mark-mixin) () (:documentation "A LEFT-STICKY-MARK subclass suitable for use in a PERSISTENT-BUFFER.")) (defclass persistent-right-sticky-mark (right-sticky-mark p-mark-mixin) () (:documentation "A RIGHT-STICKY-MARK subclass suitable for use in a PERSISTENT-BUFFER.")) (defclass persistent-left-sticky-line-mark (left-sticky-mark p-line-mark-mixin) () (:documentation "A LEFT-STICKY-MARK subclass with line support, suitable for use in a PERSISTENT-BUFFER.")) (defclass persistent-right-sticky-line-mark (right-sticky-mark p-line-mark-mixin) () (:documentation "A RIGHT-STICKY-MARK subclass with line support, suitable for use in a PERSISTENT-BUFFER.")) (defmethod initialize-instance :after ((mark persistent-left-sticky-mark) &rest args &key (offset 0)) "Associates a created mark with the buffer for which it was created." (declare (ignorable args)) (assert (<= 0 offset) () (make-condition 'motion-before-beginning :offset offset)) (assert (<= offset (size (buffer mark))) () (make-condition 'motion-after-end :offset offset)) (setf (slot-value mark 'cursor) (make-instance 'left-sticky-persistent-cursor :buffer (buffer mark) :position offset))) (defmethod initialize-instance :after ((mark persistent-right-sticky-mark) &rest args &key (offset 0)) "Associates a created mark with the buffer for which it was created." (declare (ignorable args)) (assert (<= 0 offset) () (make-condition 'motion-before-beginning :offset offset)) (assert (<= offset (size (buffer mark))) () (make-condition 'motion-after-end :offset offset)) (setf (slot-value mark 'cursor) (make-instance 'right-sticky-persistent-cursor :buffer (buffer mark) :position offset))) (defmethod initialize-instance :after ((mark persistent-left-sticky-line-mark) &rest args &key (offset 0)) "Associates a created mark with the buffer for which it was created." (declare (ignorable args)) (assert (<= 0 offset) () (make-condition 'motion-before-beginning :offset offset)) (assert (<= offset (size (buffer mark))) () (make-condition 'motion-after-end :offset offset)) (setf (slot-value mark 'cursor) (make-instance 'left-sticky-line-persistent-cursor :buffer (buffer mark) :position offset))) (defmethod initialize-instance :after ((mark persistent-right-sticky-line-mark) &rest args &key (offset 0)) "Associates a created mark with the buffer for which it was created." (declare (ignorable args)) (assert (<= 0 offset) () (make-condition 'motion-before-beginning :offset offset)) (assert (<= offset (size (buffer mark))) () (make-condition 'motion-after-end :offset offset)) (setf (slot-value mark 'cursor) (make-instance 'right-sticky-line-persistent-cursor :buffer (buffer mark) :position offset))) (defmethod clone-mark ((mark persistent-left-sticky-mark) &optional stick-to) (cond ((or (null stick-to) (eq stick-to :left)) (make-instance 'persistent-left-sticky-mark :buffer (buffer mark) :offset (offset mark))) ((eq stick-to :right) (make-instance 'persistent-right-sticky-mark :buffer (buffer mark) :offset (offset mark))) (t (error "invalid value for stick-to")))) (defmethod clone-mark ((mark persistent-right-sticky-mark) &optional stick-to) (cond ((or (null stick-to) (eq stick-to :right)) (make-instance 'persistent-right-sticky-mark :buffer (buffer mark) :offset (offset mark))) ((eq stick-to :left) (make-instance 'persistent-left-sticky-mark :buffer (buffer mark) :offset (offset mark))) (t (error "invalid value for stick-to")))) (defmethod clone-mark ((mark persistent-left-sticky-line-mark) &optional stick-to) (cond ((or (null stick-to) (eq stick-to :left)) (make-instance 'persistent-left-sticky-line-mark :buffer (buffer mark) :offset (offset mark))) ((eq stick-to :right) (make-instance 'persistent-right-sticky-line-mark :buffer (buffer mark) :offset (offset mark))) (t (error "invalid value for stick-to")))) (defmethod clone-mark ((mark persistent-right-sticky-line-mark) &optional stick-to) (cond ((or (null stick-to) (eq stick-to :right)) (make-instance 'persistent-right-sticky-line-mark :buffer (buffer mark) :offset (offset mark))) ((eq stick-to :left) (make-instance 'persistent-left-sticky-line-mark :buffer (buffer mark) :offset (offset mark))) (t (error "invalid value for stick-to")))) (defmethod size ((buffer binseq-buffer)) (binseq-length (slot-value buffer 'contents))) (defmethod size ((buffer obinseq-buffer)) (obinseq-length (slot-value buffer 'contents))) (defmethod size ((buffer binseq2-buffer)) (binseq2-size (slot-value buffer 'contents))) (defmethod number-of-lines ((buffer persistent-buffer)) (loop for offset from 0 below (size buffer) count (eql (buffer-object buffer offset) #\Newline))) (defmethod number-of-lines ((buffer binseq2-buffer)) (let ((len (binseq2-length (slot-value buffer 'contents))) (size (size buffer))) (if (or (eql 0 size) (eq (buffer-object buffer (1- size)) #\Newline)) len (max 0 (1- len))))) ; weird? (defmethod mark< ((mark1 p-mark-mixin) (mark2 p-mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) (< (offset mark1) (offset mark2))) (defmethod mark< ((mark1 p-mark-mixin) (mark2 integer)) (< (offset mark1) mark2)) (defmethod mark< ((mark1 integer) (mark2 p-mark-mixin)) (< mark1 (offset mark2))) (defmethod mark<= ((mark1 p-mark-mixin) (mark2 p-mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) (<= (offset mark1) (offset mark2))) (defmethod mark<= ((mark1 p-mark-mixin) (mark2 integer)) (<= (offset mark1) mark2)) (defmethod mark<= ((mark1 integer) (mark2 p-mark-mixin)) (<= mark1 (offset mark2))) (defmethod mark= ((mark1 p-mark-mixin) (mark2 p-mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) (= (offset mark1) (offset mark2))) (defmethod mark= ((mark1 p-mark-mixin) (mark2 integer)) (= (offset mark1) mark2)) (defmethod mark= ((mark1 integer) (mark2 p-mark-mixin)) (= mark1 (offset mark2))) (defmethod mark> ((mark1 p-mark-mixin) (mark2 p-mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) (> (offset mark1) (offset mark2))) (defmethod mark> ((mark1 p-mark-mixin) (mark2 integer)) (> (offset mark1) mark2)) (defmethod mark> ((mark1 integer) (mark2 p-mark-mixin)) (> mark1 (offset mark2))) (defmethod mark>= ((mark1 p-mark-mixin) (mark2 p-mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) (>= (offset mark1) (offset mark2))) (defmethod mark>= ((mark1 p-mark-mixin) (mark2 integer)) (>= (offset mark1) mark2)) (defmethod mark>= ((mark1 integer) (mark2 p-mark-mixin)) (>= mark1 (offset mark2))) (defmethod beginning-of-buffer ((mark p-mark-mixin)) (setf (offset mark) 0)) (defmethod end-of-buffer ((mark p-mark-mixin)) (setf (offset mark) (size (buffer mark)))) (defmethod beginning-of-buffer-p ((mark p-mark-mixin)) (zerop (offset mark))) (defmethod end-of-buffer-p ((mark p-mark-mixin)) (= (offset mark) (size (buffer mark)))) (defmethod beginning-of-line-p ((mark p-mark-mixin)) (or (beginning-of-buffer-p mark) (eql (object-before mark) #\Newline))) (defmethod end-of-line-p ((mark p-mark-mixin)) (or (end-of-buffer-p mark) (eql (object-after mark) #\Newline))) (defmethod beginning-of-line ((mark p-mark-mixin)) (loop until (beginning-of-line-p mark) do (decf (offset mark)))) (defmethod beginning-of-line ((mark p-line-mark-mixin)) (setf (offset mark) (binseq2-offset (slot-value (buffer mark) 'contents) (line-number mark)))) (defmethod end-of-line ((mark p-mark-mixin)) (let* ((offset (offset mark)) (buffer (buffer mark)) (size (size buffer))) (loop until (or (= offset size) (eql (buffer-object buffer offset) #\Newline)) do (incf offset)) (setf (offset mark) offset))) (defmethod end-of-line ((mark p-line-mark-mixin)) (let* ((offset (offset mark)) (buffer (buffer mark)) (size (size buffer)) (contents (slot-value buffer 'contents)) (next-line-offset (binseq2-offset contents (1+ (binseq2-line2 contents offset))))) (setf (offset mark) (cond ((> next-line-offset offset) (1- next-line-offset)) ((and (> size 0) (eql (binseq2-get2 contents (1- size)) #\Newline)) (1- size)) (t size))))) (defmethod buffer-line-number ((buffer persistent-buffer) (offset integer)) (loop for i from 0 below offset count (eql (buffer-object buffer i) #\Newline))) (defmethod buffer-line-number ((buffer binseq2-buffer) (offset integer)) (binseq2-line2 (slot-value buffer 'contents) offset)) (defmethod line-number ((mark p-mark-mixin)) (buffer-line-number (buffer mark) (offset mark))) (defmethod buffer-line-offset ((buffer binseq2-buffer) (line-no integer)) (binseq2-offset (slot-value buffer 'contents) line-no)) (defmethod buffer-column-number ((buffer persistent-buffer) (offset integer)) (loop for i downfrom offset while (> i 0) until (eql (buffer-object buffer (1- i)) #\Newline) count t)) (defmethod buffer-column-number ((buffer binseq2-buffer) (offset integer)) (- offset (binseq2-offset (slot-value buffer 'contents) (buffer-line-number buffer offset)))) (defmethod column-number ((mark p-mark-mixin)) (buffer-column-number (buffer mark) (offset mark))) ;;; the old value of the CONTENTS slot is dropped upon modification ;;; it can be saved for UNDO purposes in a history tree, by an UNDOABLE-BUFFER (defmethod insert-buffer-object ((buffer binseq-buffer) offset object) (assert (<= 0 offset) () (make-condition 'offset-before-beginning :offset offset)) (assert (<= offset (size buffer)) () (make-condition 'offset-after-end :offset offset)) (setf (slot-value buffer 'contents) (binseq-insert (slot-value buffer 'contents) offset object))) (defmethod insert-buffer-object ((buffer obinseq-buffer) offset object) (assert (<= 0 offset) () (make-condition 'offset-before-beginning :offset offset)) (assert (<= offset (size buffer)) () (make-condition 'offset-after-end :offset offset)) (setf (slot-value buffer 'contents) (obinseq-insert (slot-value buffer 'contents) offset object))) (defmethod insert-buffer-object ((buffer binseq2-buffer) offset object) (assert (<= 0 offset) () (make-condition 'offset-before-beginning :offset offset)) (assert (<= offset (size buffer)) () (make-condition 'offset-after-end :offset offset)) (setf (slot-value buffer 'contents) (binseq2-insert2 (slot-value buffer 'contents) offset object))) (defmethod insert-object ((mark p-mark-mixin) object) (insert-buffer-object (buffer mark) (offset mark) object)) (defmethod insert-buffer-sequence ((buffer binseq-buffer) offset sequence) (assert (<= 0 offset) () (make-condition 'offset-before-beginning :offset offset)) (assert (<= offset (size buffer)) () (make-condition 'offset-after-end :offset offset)) (let ((binseq (vector-binseq sequence))) (setf (slot-value buffer 'contents) (binseq-insert* (slot-value buffer 'contents) offset binseq)))) (defmethod insert-buffer-sequence ((buffer obinseq-buffer) offset sequence) (assert (<= 0 offset) () (make-condition 'offset-before-beginning :offset offset)) (assert (<= offset (size buffer)) () (make-condition 'offset-after-end :offset offset)) (let ((obinseq (vector-obinseq sequence))) (setf (slot-value buffer 'contents) (obinseq-insert* (slot-value buffer 'contents) offset obinseq)))) (defmethod insert-buffer-sequence ((buffer binseq2-buffer) offset sequence) (assert (<= 0 offset) () (make-condition 'offset-before-beginning :offset offset)) (assert (<= offset (size buffer)) () (make-condition 'offset-after-end :offset offset)) (let ((binseq2 (vector-binseq2 sequence))) (setf (slot-value buffer 'contents) (binseq2-insert*2 (slot-value buffer 'contents) offset binseq2)))) (defmethod insert-sequence ((mark p-mark-mixin) sequence) (insert-buffer-sequence (buffer mark) (offset mark) sequence)) (defmethod delete-buffer-range ((buffer binseq-buffer) offset n) (assert (<= 0 offset) () (make-condition 'offset-before-beginning :offset offset)) (assert (<= offset (size buffer)) () (make-condition 'offset-after-end :offset offset)) (assert (<= (+ offset n) (size buffer)) () (make-condition 'offset-after-end :offset (+ offset n))) (setf (slot-value buffer 'contents) (binseq-remove* (slot-value buffer 'contents) offset n))) (defmethod delete-buffer-range ((buffer obinseq-buffer) offset n) (assert (<= 0 offset) () (make-condition 'offset-before-beginning :offset offset)) (assert (<= offset (size buffer)) () (make-condition 'offset-after-end :offset offset)) (assert (<= (+ offset n) (size buffer)) () (make-condition 'offset-after-end :offset (+ offset n))) (setf (slot-value buffer 'contents) (obinseq-remove* (slot-value buffer 'contents) offset n))) (defmethod delete-buffer-range ((buffer binseq2-buffer) offset n) (assert (<= 0 offset) () (make-condition 'offset-before-beginning :offset offset)) (assert (<= offset (size buffer)) () (make-condition 'offset-after-end :offset offset)) (assert (<= (+ offset n) (size buffer)) () (make-condition 'offset-after-end :offset (+ offset n))) (setf (slot-value buffer 'contents) (binseq2-remove*2 (slot-value buffer 'contents) offset n))) (defmethod delete-range ((mark p-mark-mixin) &optional (n 1)) (cond ((plusp n) (delete-buffer-range (buffer mark) (offset mark) n)) ((minusp n) (delete-buffer-range (buffer mark) (+ (offset mark) n) (- n))) (t nil))) (defmethod delete-region ((mark1 p-mark-mixin) (mark2 p-mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) (let ((offset1 (offset mark1)) (offset2 (offset mark2))) (when (> offset1 offset2) (rotatef offset1 offset2)) (delete-buffer-range (buffer mark1) offset1 (- offset2 offset1)))) (defmethod delete-region ((mark1 p-mark-mixin) offset2) (let ((offset1 (offset mark1))) (when (> offset1 offset2) (rotatef offset1 offset2)) (delete-buffer-range (buffer mark1) offset1 (- offset2 offset1)))) (defmethod delete-region (offset1 (mark2 p-mark-mixin)) (let ((offset2 (offset mark2))) (when (> offset1 offset2) (rotatef offset1 offset2)) (delete-buffer-range (buffer mark2) offset1 (- offset2 offset1)))) (defmethod buffer-object ((buffer binseq-buffer) offset) (assert (<= 0 offset) () (make-condition 'offset-before-beginning :offset offset)) (assert (<= offset (1- (size buffer))) () (make-condition 'offset-after-end :offset offset)) (binseq-get (slot-value buffer 'contents) offset)) (defmethod (setf buffer-object) (object (buffer binseq-buffer) offset) (assert (<= 0 offset) () (make-condition 'offset-before-beginning :offset offset)) (assert (<= offset (1- (size buffer))) () (make-condition 'offset-after-end :offset offset)) (setf (slot-value buffer 'contents) (binseq-set (slot-value buffer 'contents) offset object))) (defmethod buffer-object ((buffer obinseq-buffer) offset) (assert (<= 0 offset) () (make-condition 'offset-before-beginning :offset offset)) (assert (<= offset (1- (size buffer))) () (make-condition 'offset-after-end :offset offset)) (obinseq-get (slot-value buffer 'contents) offset)) (defmethod (setf buffer-object) (object (buffer obinseq-buffer) offset) (assert (<= 0 offset) () (make-condition 'offset-before-beginning :offset offset)) (assert (<= offset (1- (size buffer))) () (make-condition 'offset-after-end :offset offset)) (setf (slot-value buffer 'contents) (obinseq-set (slot-value buffer 'contents) offset object))) (defmethod buffer-object ((buffer binseq2-buffer) offset) (assert (<= 0 offset) () (make-condition 'offset-before-beginning :offset offset)) (assert (<= offset (1- (size buffer))) () (make-condition 'offset-after-end :offset offset)) (binseq2-get2 (slot-value buffer 'contents) offset)) (defmethod (setf buffer-object) (object (buffer binseq2-buffer) offset) (assert (<= 0 offset) () (make-condition 'offset-before-beginning :offset offset)) (assert (<= offset (1- (size buffer))) () (make-condition 'offset-after-end :offset offset)) (setf (slot-value buffer 'contents) (binseq2-set2 (slot-value buffer 'contents) offset object))) (defmethod buffer-sequence ((buffer binseq-buffer) offset1 offset2) (assert (<= 0 offset1) () (make-condition 'offset-before-beginning :offset offset1)) (assert (<= offset1 (size buffer)) () (make-condition 'offset-after-end :offset offset1)) (assert (<= 0 offset2) () (make-condition 'offset-before-beginning :offset offset2)) (assert (<= offset2 (size buffer)) () (make-condition 'offset-after-end :offset offset2)) (let ((len (- offset2 offset1))) (if (> len 0) (binseq-vector (binseq-sub (slot-value buffer 'contents) offset1 len)) (make-array 0)))) (defmethod buffer-sequence ((buffer obinseq-buffer) offset1 offset2) (assert (<= 0 offset1) () (make-condition 'offset-before-beginning :offset offset1)) (assert (<= offset1 (size buffer)) () (make-condition 'offset-after-end :offset offset1)) (assert (<= 0 offset2) () (make-condition 'offset-before-beginning :offset offset2)) (assert (<= offset2 (size buffer)) () (make-condition 'offset-after-end :offset offset2)) (let ((len (- offset2 offset1))) (if (> len 0) (obinseq-vector (obinseq-sub (slot-value buffer 'contents) offset1 len)) (make-array 0)))) (defmethod buffer-sequence ((buffer binseq2-buffer) offset1 offset2) (assert (<= 0 offset1) () (make-condition 'offset-before-beginning :offset offset1)) (assert (<= offset1 (size buffer)) () (make-condition 'offset-after-end :offset offset1)) (assert (<= 0 offset2) () (make-condition 'offset-before-beginning :offset offset2)) (assert (<= offset2 (size buffer)) () (make-condition 'offset-after-end :offset offset2)) (let ((len (- offset2 offset1))) (if (> len 0) (binseq2-vector (binseq2-sub2 (slot-value buffer 'contents) offset1 len)) (make-array 0)))) (defmethod object-before ((mark p-mark-mixin)) (buffer-object (buffer mark) (1- (offset mark)))) (defmethod object-after ((mark p-mark-mixin)) (buffer-object (buffer mark) (offset mark))) (defmethod region-to-sequence ((mark1 p-mark-mixin) (mark2 p-mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) (let ((offset1 (offset mark1)) (offset2 (offset mark2))) (when (> offset1 offset2) (rotatef offset1 offset2)) (buffer-sequence (buffer mark1) offset1 offset2))) (defmethod region-to-sequence ((offset1 integer) (mark2 p-mark-mixin)) (let ((offset2 (offset mark2))) (when (> offset1 offset2) (rotatef offset1 offset2)) (buffer-sequence (buffer mark2) offset1 offset2))) (defmethod region-to-sequence ((mark1 p-mark-mixin) (offset2 integer)) (let ((offset1 (offset mark1))) (when (> offset1 offset2) (rotatef offset1 offset2)) (buffer-sequence (buffer mark1) offset1 offset2))) (defmacro filter-and-update (l filter-fn update-fn) (let ((prev (gensym)) (curr (gensym)) (kept (gensym))) `(loop with ,prev = nil and ,curr = ,l and ,kept = nil do (cond ((null ,curr) (return)) ((setf ,kept (funcall ,filter-fn (car ,curr))) (funcall ,update-fn ,kept) (setf ,prev ,curr ,curr (cdr ,curr))) (t (if ,prev (setf (cdr ,prev) (cdr ,curr)) (setf ,l (cdr ,l))) (setf ,curr (cdr ,curr))))))) (defun adjust-cursors-on-insert (buffer start &optional (increment 1)) (filter-and-update (cursors buffer) #'(lambda (c) (flexichain::weak-pointer-value c)) #'(lambda (wpc) (when (<= start (slot-value wpc 'pos)) (incf (slot-value wpc 'pos) increment))))) (defun adjust-cursors-on-delete (buffer start n) (let ((end (+ start n))) (filter-and-update (cursors buffer) #'(lambda (c) (flexichain::weak-pointer-value c)) #'(lambda (wpc) (cond ((<= (cursor-pos wpc) start)) ((< start (cursor-pos wpc) end) (setf (cursor-pos wpc) start)) (t (decf (cursor-pos wpc) n))))))) (defmethod insert-buffer-object :after ((buffer persistent-buffer) offset object) (adjust-cursors-on-insert buffer offset)) (defmethod insert-buffer-sequence :after ((buffer persistent-buffer) offset sequence) (adjust-cursors-on-insert buffer offset (length sequence))) (defmethod delete-buffer-range :after ((buffer persistent-buffer) offset n) (adjust-cursors-on-delete buffer offset n)) (defmethod make-buffer-mark ((buffer persistent-buffer) &optional (offset 0) (stick-to :left)) (make-instance (ecase stick-to (:left 'persistent-left-sticky-mark) (:right 'persistent-right-sticky-mark)) :offset offset :buffer buffer)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/Persistent/persistent-undo.lisp0000640000175000017500000000460610524227664024070 0ustar pdmpdm;;; -*- mode: lisp -*- ;;; ;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic@yahoo.com) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Part of the Undo protocol that works with persistent buffers (in-package :drei-undo) (defclass p-undo-mixin () ((tree :initform (make-instance 'standard-undo-tree) :reader undo-tree) (undo-accumulate :initform '() :accessor undo-accumulate) (performing-undo :initform nil :accessor performing-undo))) (defclass p-undo-record (climacs-undo-record) ((contents :initarg :contents))) (defun save-p-undo-record (buffer) (unless (performing-undo buffer) (push (make-instance 'p-undo-record :buffer buffer :contents (slot-value buffer 'drei-buffer::contents)) (undo-accumulate buffer)))) (defmethod insert-buffer-object :before ((buffer p-undo-mixin) offset object) (declare (ignore offset object)) (save-p-undo-record buffer)) (defmethod insert-buffer-sequence :before ((buffer p-undo-mixin) offset seq) (declare (ignore offset seq)) (save-p-undo-record buffer)) (defmethod delete-buffer-range :before ((buffer p-undo-mixin) offset n) (declare (ignore offset n)) (save-p-undo-record buffer)) (defmethod (setf buffer-object) :before (object (buffer p-undo-mixin) offset) (declare (ignore object offset)) (save-p-undo-record buffer)) (defmethod flip-undo-record ((record p-undo-record)) (with-slots (buffer contents) record (setf (slot-value buffer 'drei-buffer::contents) contents) (drei-buffer::filter-and-update (drei-buffer::cursors buffer) #'(lambda (c) (flexichain::weak-pointer-value c buffer)) #'(lambda (wpc) (setf (cursor-pos wpc) (max 0 (min (cursor-pos wpc) (1- (size buffer)))))))))cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/Persistent/binseq.lisp0000640000175000017500000001541310524227664022204 0ustar pdmpdm;;; -*- mode: lisp -*- ;;; ;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic@yahoo.com) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Adaptation of binary sequences by Robert Will (real-world-phenomena.org) (in-package :binseq) (defun binseq-p (s) ; NOTE: should use a 3-vector instead of the 3-list... (or (eq s 'empty) (and (consp s) (or (eq (car s) 'leaf) (and (eq (car s) 'node) (integerp (cadr s)) (consp (cddr s)) (binseq-p (caddr s)) (binseq-p (cdddr s))))))) (defun list-binseq (l) (flet ((%split (l n) ; TODO: use side-effects to avoid consing (loop for b on l and i from 0 if (< i n) collect (car b) into a else do (return (values a b)) finally (return (values l nil))))) (cond ((null l) 'empty) ((null (cdr l)) `(leaf . ,(car l))) (t (let ((len (length l))) (multiple-value-bind (a b) (%split l (floor len 2)) `(node . (,len . (,(list-binseq a) . ,(list-binseq b)))))))))) (defun binseq-list (s) (labels ((%to-list (s l) (cond ((eq s 'empty) l) ((eq (car s) 'leaf) (cons (cdr s) l)) (t (%to-list (caddr s) (%to-list (cdddr s) l)))))) (%to-list s nil))) (defun vector-binseq (v &optional (start 0) (end (length v))) (cond ((= start end) 'empty) ((= (- end start) 1) `(leaf . ,(aref v start))) (t (let* ((len (- end start)) (mid (+ start (floor len 2)))) `(node . (,len . (,(vector-binseq v start mid) . ,(vector-binseq v mid end)))))))) (defun binseq-vector (s) (let ((v (make-array (binseq-length s)))) (labels ((%set-v (s o) (cond ((eq s 'empty)) ((eq (car s) 'leaf) (setf (aref v o) (cdr s))) (t (let ((a (caddr s)) (b (cdddr s))) (%set-v a o) (%set-v b (+ o (binseq-length a)))))))) (%set-v s 0) v))) (defun binseq-empty (s) (eq s 'empty)) (defun binseq-length (s) (cond ((eq s 'empty) 0) ((eq (car s) 'leaf) 1) (t (cadr s)))) (defun binseq-cons (e s) (binseq-append `(leaf . ,e) s)) (defun binseq-snoc (e s) (binseq-append s `(leaf . ,e))) (defparameter *imbalance-bound* 3) ; must be >= 3 (defun binseq-append (a b) (labels ((%not-much-longer (a b) (<= (binseq-length a) (* *imbalance-bound* (binseq-length b)))) (%much-shorter (a b) (not (%not-much-longer b a))) (%similar-in-length (a b) (and (%not-much-longer a b) (%not-much-longer b a))) (%cond-single (la lb lc) (and (<= lb (* *imbalance-bound* lc)) (<= (+ lb lc) (* *imbalance-bound* la)))) (%cond-double (la lb lc) (<= (+ la lb) (* (+ 1 *imbalance-bound*) lc))) (%cons (a b) (let ((len (+ (binseq-length a) (binseq-length b)))) (assert (>= len 2)) `(node . (,len . (,a . ,b))))) (%rotate-right (s1 s2) (cond ((and (consp s1) (eq (car s1) 'node)) (let* ((a (caddr s1)) (b (cdddr s1)) (la (binseq-length a)) (lb (binseq-length b)) (ls2 (binseq-length s2))) (cond ((%cond-single la lb ls2) (%cons a (%cons b s2))) ((%cond-double la lb ls2) (let ((s11 (caddr b)) (s12 (cdddr b))) (%cons (%cons a s11) (%cons s12 s2)))) (t (%append a (%append b s2)))))) (t (%append a (%append b s2))))) (%rotate-left (s1 s2) (cond ((and (consp s2) (eq (car s2) 'node)) (let* ((a (cdddr s2)) (b (caddr s2)) (la (binseq-length a)) (lb (binseq-length b)) (ls1 (binseq-length s1))) (cond ((%cond-single la lb ls1) (%cons (%cons s1 b) a)) ((%cond-double la lb ls1) (let ((s21 (cdddr b)) (s22 (caddr b))) (%cons (%cons s1 s22) (%cons s21 a)))) (t (%append (%append s1 b) a))))) (t (%append (%append s1 b) a)))) (%append (a b) (cond ((%similar-in-length a b) (%cons a b)) ((%much-shorter a b) (%rotate-left a b)) (t (%rotate-right a b))))) (cond ((eq a 'empty) b) ((eq b 'empty) a) (t (%append a b))))) (defun binseq-front (s i) (cond ((<= i 0) 'empty) ((<= (binseq-length s) i) s) ((<= i (binseq-length (caddr s))) (binseq-front (caddr s) i)) (t (binseq-append (caddr s) (binseq-front (cdddr s) (- i (binseq-length (caddr s)))))))) (defun binseq-back (s i) (cond ((<= i 0) 'empty) ((<= (binseq-length s) i) s) ((<= i (binseq-length (cdddr s))) (binseq-back (cdddr s) i)) (t (binseq-append (binseq-back (caddr s) (- i (binseq-length (cdddr s)))) (cdddr s))))) (defun %has-index (s i) (and (<= 0 i) (< i (binseq-length s)))) (defun %has-gap (s i) (and (<= 0 i) (<= i (binseq-length s)))) (defun binseq-get (s i) (assert (%has-index s i) nil "Index out of bounds: ~S, ~S" s i) (cdr (binseq-back (binseq-front s (1+ i)) 1))) (defun binseq-set (s i e) (assert (%has-index s i) nil "Index out of bounds: ~S, ~S" s i) (binseq-append (binseq-front s i) (binseq-cons e (binseq-back s (- (binseq-length s) i 1))))) (defun binseq-sub (s i n) (assert (and (>= n 0) (<= (+ i n) (binseq-length s))) nil "Invalid subsequence bounds: ~S, ~S, ~S" s i n) (binseq-back (binseq-front s (+ i n)) n)) (defun binseq-insert (s i e) (assert (%has-gap s i) nil "Index out of bounds: ~S, ~S, ~S" s i e) (binseq-append (binseq-front s i) (binseq-cons e (binseq-back s (- (binseq-length s) i))))) (defun binseq-insert* (s i s2) (assert (%has-gap s i) nil "Index out of bounds: ~S, ~S, ~S" s i s2) (if (eq s2 'empty) s (binseq-append (binseq-front s i) (binseq-append s2 (binseq-back s (- (binseq-length s) i)))))) (defun binseq-remove (s i) (assert (%has-index s i) nil "Index out of bounds: ~S, ~S" s i) (binseq-append (binseq-front s i) (binseq-back s (- (binseq-length s) i 1)))) (defun binseq-remove* (s i n) (assert (%has-index s i) nil "Start index out of bounds: ~S, ~S, ~S" s i n) (assert (and (>= n 0) (<= (+ i n) (binseq-length s))) nil "Count out of range: ~S, ~S, ~S" s i n) (if (zerop n) s (binseq-append (binseq-front s i) (binseq-back s (- (binseq-length s) i n)))))cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/core-commands.lisp0000644000175000017500000007145311345155772021326 0ustar pdmpdm;;; -*- Mode: Lisp; Package: DREI-COMMANDS -*- ;;; (c) copyright 2004-2005 by ;;; Robert Strandh (strandh@labri.fr) ;;; (c) copyright 2004-2005 by ;;; Elliott Johnson (ejohnson@fasl.info) ;;; (c) copyright 2005 by ;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr) ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) ;;; (c) copyright 2006 by ;;; Taylor R. Campbell (campbell@mumble.net) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Commands that provide access to core DREI features, but are not ;;; strictly necessary. (in-package :drei-commands) (define-command (com-overwrite-mode :name t :command-table editing-table) () "Toggle overwrite mode for the current mode. When overwrite is on, an object entered on the keyboard will replace the object after the point. When overwrite is off (the default), objects are inserted at point. In both cases point is positioned after the new object." (with-slots (overwrite-mode) (current-view) (setf overwrite-mode (not overwrite-mode)))) (set-key 'com-overwrite-mode 'editing-table '((:insert))) (defun set-fill-column (column) (if (> column 1) (setf (auto-fill-column (current-view)) column) (progn (beep) (display-message "Set Fill Column requires an explicit argument.")))) (define-command (com-set-fill-column :name t :command-table fill-table) ((column 'integer :prompt "Column Number:")) "Set the fill column to the specified value. You must supply a numeric argument. The fill column is the column beyond which automatic line-wrapping will occur. The default fill column is 70." (set-fill-column column)) (set-key `(com-set-fill-column ,*numeric-argument-marker*) 'fill-table '((#\x :control) (#\f))) (define-command (com-zap-to-object :name t :command-table deletion-table) () "Prompt for an object and kill to the next occurence of that object after point. Characters can be entered in #\ format." (require-minibuffer) (let* ((item (handler-case (accept 't :prompt "Zap to Object") (error () (progn (beep) (display-message "Not a valid object") (return-from com-zap-to-object nil))))) (item-mark (clone-mark (point))) (current-offset (offset (point)))) (search-forward item-mark (vector item)) (delete-range (point) (- (offset item-mark) current-offset)))) (define-command (com-zap-to-character :name t :command-table deletion-table) () "Prompt for a character and kill to the next occurence of that character after point. FIXME: Accepts a string (that is, zero or more characters) terminated by a #\NEWLINE. If a zero length string signals an error. If a string of length >1, uses the first character of the string." (require-minibuffer) (let* ((item-string (handler-case (accept 'string :prompt "Zap to Character") ; Figure out how to get #\d and d. (or 'string 'character)? (error () (progn (beep) (display-message "Not a valid string. ") (return-from com-zap-to-character nil))))) (item (subseq item-string 0 1)) (item-mark (clone-mark (point))) (current-offset (offset (point)))) (if (> (length item-string) 1) (display-message "Using just the first character")) (search-forward item-mark item) (delete-range (point) (- (offset item-mark) current-offset)))) (set-key 'com-zap-to-character 'deletion-table '((#\z :meta))) (define-command (com-open-line :name t :command-table editing-table) ((numarg 'integer :prompt "How many lines?" :default 1)) "Insert a #\Newline and leave point before it. With a numeric argument greater than 1, insert that many #\Newlines." (open-line (point) numarg)) (set-key `(com-open-line ,*numeric-argument-marker*) 'editing-table '((#\o :control))) (defmacro define-mark-unit-command (unit command-table &key move-point noun plural) "Define a COM-MARK- for `unit' command and put it in `command-table'." (labels ((concat (&rest strings) (apply #'concatenate 'STRING (mapcar #'string strings))) (symbol (&rest strings) (intern (apply #'concat strings)))) (let ((forward (symbol "FORWARD-" unit)) (backward (symbol "BACKWARD-" unit)) (noun (or noun (string-downcase unit))) (plural (or plural (concat (string-downcase unit) "s")))) `(define-command (,(symbol "COM-MARK-" unit) :name t :command-table ,command-table) ((count 'integer :prompt ,(concat "Number of " plural) :default 1)) ,(if (not (null move-point)) (concat "Place point and mark around the current " noun ". Put point at the beginning of the current " noun ", and mark at the end. With a positive numeric argument, put mark that many " plural " forward. With a negative numeric argument, put point at the end of the current " noun " and mark that many " plural " backward. Successive invocations extend the selection.") (concat "Place mark at the next " noun " end. With a positive numeric argument, place mark at the end of that many " plural " forward. With a negative numeric argument, place mark at the beginning of that many " plural " backward. Successive invocations extend the selection.")) (unless (eq (command-name *previous-command*) 'com-mark-word) (setf (offset (mark)) (offset (point))) ,(when (not (null move-point)) `(if (plusp count) (,backward (point) (current-syntax)) (,forward (point) (current-syntax))))) (,forward (mark) (current-syntax) count))))) (define-mark-unit-command word marking-table) (define-mark-unit-command expression marking-table) (define-mark-unit-command paragraph marking-table :move-point t) (define-mark-unit-command definition marking-table :move-point t) (set-key `(com-mark-word ,*numeric-argument-marker*) 'marking-table '((#\@ :meta))) (set-key `(com-mark-paragraph ,*numeric-argument-marker*) 'marking-table '((#\h :meta))) (set-key 'com-mark-definition 'marking-table '((#\h :control :meta))) (define-command (com-upcase-region :name t :command-table case-table) () "Convert the region to upper case." (upcase-region (mark) (point))) (define-command (com-downcase-region :name t :command-table case-table) () "Convert the region to lower case." (downcase-region (mark) (point))) (define-command (com-capitalize-region :name t :command-table case-table) () "Capitalize each word in the region." (capitalize-region (mark) (point))) (define-command (com-upcase-word :name t :command-table case-table) () "Convert the characters from point until the next word end to upper case. Leave point at the word end." (upcase-word (point) (current-syntax))) (set-key 'com-upcase-word 'case-table '((#\u :meta))) (define-command (com-downcase-word :name t :command-table case-table) () "Convert the characters from point until the next word end to lower case. Leave point at the word end." (downcase-word (point) (current-syntax))) (set-key 'com-downcase-word 'case-table '((#\l :meta))) (define-command (com-capitalize-word :name t :command-table case-table) () "Capitalize the next word. If point is in a word, convert the next character to upper case and the remaining letters in the word to lower case. If point is before the start of a word, convert the first character of that word to upper case and the rest of the letters to lower case. Leave point at the word end." (capitalize-word (point) (current-syntax))) (set-key 'com-capitalize-word 'case-table '((#\c :meta))) (define-command (com-tabify-region :name t :command-table editing-table) () "Replace runs of spaces with tabs in region where possible. Uses TAB-SPACE-COUNT of the STREAM-DEFAULT-VIEW of the pane." (tabify-region (mark) (point) (tab-space-count (current-view)))) (define-command (com-untabify-region :name t :command-table editing-table) () "Replace tabs with equivalent runs of spaces in the region. Uses TAB-SPACE-COUNT of the STREAM-DEFAULT-VIEW of the pane." (untabify-region (mark) (point) (tab-space-count (current-view)))) (define-command (com-set-tab-stops :name t :command-table editing-table) ((tab-stops '(sequence (integer 0)) :prompt "List of tab stops")) "Accept a list of tab positions (in columns) for the view." (setf (drei::tab-stop-columns (current-view)) tab-stops)) (define-command (com-indent-line :name t :command-table indent-table) () (indent-current-line (current-view) (point))) (set-key 'com-indent-line 'indent-table '((#\Tab))) (set-key 'com-indent-line 'indent-table '((#\i :control))) (define-command (com-newline-and-indent :name t :command-table indent-table) () "Inserts a newline and indents the new line." (insert-object (point) #\Newline) (indent-current-line (current-view) (point))) (set-key 'com-newline-and-indent 'indent-table '((#\j :control))) (define-command (com-indent-region :name t :command-table indent-table) () "Indent every line of the current region as specified by the syntax for the buffer." (indent-region (current-view) (point) (mark))) (define-command (com-delete-indentation :name t :command-table indent-table) () "Join current line to previous non-blank line. Leaves a single space between the last non-whitespace object of the previous line and the first non-whitespace object of the current line, and point after that space. If there is no previous non-blank line, deletes all whitespace at the beginning of the buffer at leaves point there." (delete-indentation (current-syntax) (point))) (set-key 'com-delete-indentation 'indent-table '((#\^ :meta))) (define-command (com-auto-fill-mode :name t :command-table fill-table) () (let ((view (current-view))) (setf (auto-fill-mode view) (not (auto-fill-mode view))))) (define-command (com-fill-paragraph :name t :command-table fill-table) () (let ((begin-mark (clone-mark (point))) (end-mark (clone-mark (point)))) (unless (eql (object-before begin-mark) #\Newline) (backward-paragraph begin-mark (current-syntax))) (unless (eql (object-after end-mark) #\Newline) (forward-paragraph end-mark (current-syntax))) (do-buffer-region (object offset (current-buffer) (offset begin-mark) (offset end-mark)) (when (eql object #\Newline) (setf object #\Space))) (let ((point-backup (clone-mark (point)))) (setf (offset (point)) (offset end-mark)) (possibly-fill-line) (setf (offset (point)) (offset point-backup))))) (set-key 'com-fill-paragraph 'fill-table '((#\q :meta))) (define-command (com-beginning-of-buffer :name t :command-table movement-table) () "Move point to the beginning of the buffer." (beginning-of-buffer (point))) (set-key 'com-beginning-of-buffer 'movement-table '((#\< :meta))) (set-key 'com-beginning-of-buffer 'movement-table '((:home :control))) (define-command (com-page-down :name t :command-table view-table) () (page-down (editor-pane (drei-instance)) (current-view))) (set-key 'com-page-down 'view-table '((#\v :control))) (set-key 'com-page-down 'view-table '((:next))) (define-command (com-page-up :name t :command-table view-table) () (page-up (editor-pane (drei-instance)) (current-view))) (set-key 'com-page-up 'view-table '((#\v :meta))) (set-key 'com-page-up 'view-table '((:prior))) (define-command (com-end-of-buffer :name t :command-table movement-table) () "Move point to the end of the buffer." (end-of-buffer (point))) (set-key 'com-end-of-buffer 'movement-table '((#\> :meta))) (set-key 'com-end-of-buffer 'movement-table '((:end :control))) (define-command (com-mark-whole-buffer :name t :command-table marking-table) () "Place point at the beginning and mark at the end of the buffer." (beginning-of-buffer (point)) (end-of-buffer (mark))) (set-key 'com-mark-whole-buffer 'marking-table '((#\x :control) (#\h))) (define-command (com-back-to-indentation :name t :command-table movement-table) () "Move point to the first non-whitespace object on the current line. If there is no non-whitespace object, leaves point at the end of the line." (back-to-indentation (point) (current-syntax))) (set-key 'com-back-to-indentation 'movement-table '((#\m :meta))) (define-command (com-delete-horizontal-space :name t :command-table deletion-table) ((backward-only-p 'boolean :prompt "Delete backwards only?" :default nil)) "Delete whitespace around point. With a numeric argument, only delete whitespace before point." (delete-horizontal-space (point) (current-syntax) backward-only-p)) (set-key `(com-delete-horizontal-space ,*numeric-argument-marker*) 'deletion-table '((#\\ :meta))) (define-command (com-just-one-space :name t :command-table deletion-table) ((count 'integer :prompt "Number of spaces" :default 1)) "Delete whitespace around point, leaving a single space. With a positive numeric argument, leave that many spaces. FIXME: should distinguish between types of whitespace." (just-n-spaces (point) count)) (set-key `(com-just-one-space ,*numeric-argument-marker*) 'deletion-table '((#\Space :meta))) (define-command (com-goto-position :name t :command-table movement-table) ((position 'integer :prompt "Goto Position")) "Prompts for an integer, and sets the offset of point to that integer." (goto-position (point) position)) (define-command (com-goto-line :name t :command-table movement-table) ((line-number 'integer :prompt "Goto Line")) "Prompts for a line number, and sets point to the beginning of that line. The first line of the buffer is 1. Giving a number <1 leaves point at the beginning of the buffer. Giving a line number larger than the number of the last line in the buffer leaves point at the beginning of the last line of the buffer." (goto-line (point) line-number)) (define-command (com-set-mark :name t :command-table marking-table) () "Set mark to the current position of point." (setf (offset (mark)) (offset (point)))) (set-key 'com-set-mark 'marking-table '((#\Space :control))) (define-command (com-exchange-point-and-mark :name t :command-table marking-table) () "Exchange the positions of point and mark." (psetf (offset (mark)) (offset (point)) (offset (point)) (offset (mark)))) (set-key 'com-exchange-point-and-mark 'marking-table '((#\x :control) (#\x :control))) (define-command (com-sort-lines :name t :command-table editing-table) ((sort-ascending 'boolean :prompt "Sort in ascending order" :default nil)) "Sort the lines in the region delimited by current point and mark. The lines will be lexicographically sorted, ignoring all non-character objects in the lines. When the command is run, it will ask whether to sort in ascending or descending order." ;; I think the fastest thing is to extract all the lines to an list ;; of lines, sort the list, and put the lines back in. The ;; cons-memory overhead is probably smaller than writing an in-place ;; sort algorithm (though the latter definitely wins on hack value). (let ((lines (extract-lines-in-region (point) (mark)))) (dolist (line (sort lines (if sort-ascending #'string<= #'string>=) :key #'(lambda (line) (coerce (remove-if-not #'character line) 'string)))) (insert-sequence (point) line) (insert-object (point) #\Newline)) (backward-delete-object (point)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Kill-ring ;; Copies an element from a kill-ring to a buffer at the given offset (define-command (com-yank :name t :command-table editing-table) () "Insert the objects most recently added to the kill ring at point." (handler-case (insert-sequence (point) (kill-ring-yank *kill-ring*)) (empty-kill-ring () (display-message "Kill ring is empty")))) (set-key 'com-yank 'editing-table '((#\y :control))) ;; Destructively cut a given buffer region into the kill-ring (define-command (com-kill-region :name t :command-table editing-table) () "Kill the objects between point and mark. That is, push them onto the kill ring, and delete them from the buffer." (kill-region (mark) (point))) (set-key 'com-kill-region 'editing-table '((#\w :control))) ;; Non destructively copies buffer region to the kill ring (define-command (com-copy-region :name t :command-table marking-table) () "Copy the objects between point and mark to the kill ring." (kill-ring-standard-push *kill-ring* (region-to-sequence (point) (mark)))) (set-key 'com-copy-region 'marking-table '((#\w :meta))) (define-command (com-rotate-yank :name t :command-table editing-table) () "Replace the immediately previously yanked objects with others. Must be given immediately following a Yank or Rotate Yank command. The replacement objects are those before the previously yanked objects in the kill ring." (handler-case (let ((last-yank (kill-ring-yank *kill-ring*))) (if (eq (command-name *previous-command*) 'com-rotate-yank) (progn (delete-range (point) (* -1 (length last-yank))) (rotate-yank-position *kill-ring*))) (insert-sequence (point) (kill-ring-yank *kill-ring*))) (empty-kill-ring () (display-message "Kill ring is empty")))) (set-key 'com-rotate-yank 'editing-table '((#\y :meta))) (define-command (com-resize-kill-ring :name t :command-table editing-table) ((size 'integer :prompt "New kill ring size" :default 5)) "Prompt for a new size for the kill ring. The default is 5. A number less than 5 will be replaced by 5." (setf (kill-ring-max-size *kill-ring*) size)) (define-command (com-append-next-kill :name t :command-table editing-table) () "Set the kill ring to append the next kill to the previous one." (setf (append-next-p *kill-ring*) t)) (set-key 'com-append-next-kill 'editing-table '((#\w :control :meta))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Undo/redo (define-command (com-undo :name t :command-table editing-table) () (handler-case (undo (undo-tree (current-buffer))) (no-more-undo () (beep) (display-message "No more undo")))) (set-key 'com-undo 'editing-table '((#\_ :control))) (set-key 'com-undo 'editing-table '((#\x :control) (#\u))) (define-command (com-redo :name t :command-table editing-table) () (handler-case (redo (undo-tree (current-buffer))) (no-more-undo () (beep) (display-message "No more redo")))) (set-key 'com-redo 'editing-table '((#\_ :meta))) (set-key 'com-redo 'editing-table '((#\x :control) (#\r :control))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Dynamic abbrevs (define-command (com-dabbrev-expand :name t :command-table editing-table) () "Expand word before point dynamically. Search from point (first backward to the beginning of the buffer, then forward) for words for which the word before point is a prefix, inserting each in turn at point as an expansion." (with-accessors ((original-prefix original-prefix) (prefix-start-offset prefix-start-offset) (dabbrev-expansion-mark dabbrev-expansion-mark)) (current-view) (flet ((move () (cond ((beginning-of-buffer-p dabbrev-expansion-mark) (setf (offset dabbrev-expansion-mark) (offset (point))) (forward-word dabbrev-expansion-mark (current-syntax))) ((mark< dabbrev-expansion-mark (point)) (backward-object dabbrev-expansion-mark)) (t (forward-object dabbrev-expansion-mark))))) (unless (or (beginning-of-buffer-p (point)) (not (constituentp (object-before (point))))) (unless (and (eq (command-name *previous-command*) 'com-dabbrev-expand) (not (null prefix-start-offset))) (setf dabbrev-expansion-mark (clone-mark (point))) (backward-word dabbrev-expansion-mark (current-syntax)) (setf prefix-start-offset (offset dabbrev-expansion-mark)) (setf original-prefix (region-to-sequence prefix-start-offset (point))) (move)) (loop until (or (end-of-buffer-p dabbrev-expansion-mark) (and (or (beginning-of-buffer-p dabbrev-expansion-mark) (not (constituentp (object-before dabbrev-expansion-mark)))) (looking-at dabbrev-expansion-mark original-prefix))) do (move)) (if (end-of-buffer-p dabbrev-expansion-mark) (progn (delete-region prefix-start-offset (point)) (insert-sequence (point) original-prefix) (setf prefix-start-offset nil)) (progn (delete-region prefix-start-offset (point)) (insert-sequence (point) (let ((offset (offset dabbrev-expansion-mark))) (prog2 (forward-word dabbrev-expansion-mark (current-syntax)) (region-to-sequence offset dabbrev-expansion-mark) (setf (offset dabbrev-expansion-mark) offset)))) (move))))))) (set-key 'com-dabbrev-expand 'editing-table '((#\/ :meta))) (define-command (com-mark-page :name t :command-table marking-table) ((count 'integer :prompt "Move how many pages" :default 1) (numargp 'boolean :prompt "Move to another page?" :default nil)) "Place point and mark around the current page. With a numeric argument, move point that many pages forward (backward if negative) before marking the surrounding page. When no page delimeters are found, leave point at the beginning and mark at the end of the buffer. A page is delimited by the sequence #\Newline #\Page." (cond ((and numargp (/= 0 count)) (if (plusp count) (forward-page (point) (current-syntax) count) (backward-page (point) (current-syntax) (1+ count)))) (t (backward-page (point) (current-syntax) count))) (setf (offset (mark)) (offset (point))) (forward-page (mark) (current-syntax) 1)) (set-key `(com-mark-page ,*numeric-argument-marker* ,*numeric-argument-marker*) 'marking-table '((#\x :control) (#\p :control))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Commenting ;;; figure out how to make commands without key bindings accept numeric arguments. (define-command (com-comment-region :name t :command-table comment-table) () (comment-region (current-syntax) (point) (mark))) ;; (defparameter *insert-pair-alist* ;; '((#\( #\)) (#\[ #\]) (#\{ #\}) (#\< #\>) (#\" #\") (#\' #\') (#\` #\'))) (defun insert-parentheses (mark syntax count) (insert-pair mark syntax count #\( #\))) (define-command (com-insert-parentheses :name t :command-table editing-table) ((count 'integer :prompt "Number of expressions" :default 1) (wrap-p 'boolean :prompt "Wrap expressions?" :default nil)) "Insert a pair of parentheses, leaving point in between. With a numeric argument, enclose that many expressions forward (backward if negative)." (unless wrap-p (setf count 0)) (insert-parentheses (point) (current-syntax) count)) (set-key `(com-insert-parentheses ,*numeric-argument-marker* ,*numeric-argument-marker*) 'editing-table '((#\( :meta))) (define-command (com-visible-region :name t :command-table marking-table) () "Toggle the visibility of the region in the current pane." (setf (region-visible-p (current-view)) (not (region-visible-p (current-view))))) (define-command (com-move-past-close-and-reindent :name t :command-table editing-table) () "Move past the next `)' and reindent" (move-past-close-and-reindent (current-view) (point))) (set-key `(com-move-past-close-and-reindent) 'editing-table '((#\) :meta))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Rectangle editing (define-command (com-kill-rectangle :name t :command-table deletion-table) () "Kill the rectangle bounded by current point and mark. The rectangle will be put in a rectangle kill buffer, from which it can later be yanked with Yank Rectangle. This kill buffer is completely disjunct from the standard kill ring and can only hold a single rectangle at a time." (setf *killed-rectangle* (map-rectangle-lines (current-view) #'extract-and-delete-rectangle-line (point) (mark)))) (set-key 'com-kill-rectangle 'deletion-table '((#\x :control) (#\r) (#\k))) (define-command (com-delete-rectangle :name t :command-table deletion-table) () "Delete the rectangle bounded by current point and mark. The rectangle will be deleted and NOT put in the kill buffer." (map-rectangle-lines (current-view) #'extract-and-delete-rectangle-line (point) (mark))) (set-key 'com-delete-rectangle 'deletion-table '((#\x :control) (#\r) (#\d))) (define-command (com-yank-rectangle :name t :command-table editing-table) () "Insert the rectangle from the rectangle kill buffer at mark. The rectangle kill buffer will not be emptied, so it is possible to yank the same rectangle several times." (insert-rectangle-at-mark (current-view) (point) *killed-rectangle*)) (set-key 'com-yank-rectangle 'editing-table '((#\x :control) (#\r) (#\y))) (define-command (com-clear-rectangle :name t :command-table deletion-table) () "Clear the rectangle bounded by current point and mark by filling it with spaces." (map-rectangle-lines (current-view) #'clear-rectangle-line (point) (mark))) (set-key 'com-clear-rectangle 'editing-table '((#\x :control) (#\r) (#\c))) (define-command (com-open-rectangle :name t :command-table editing-table) () "Open the rectangle bounded by current point and mark. The rectangle will not be deleted, but instead pushed to the right, with the area previously inhabited by it filled with spaces." (map-rectangle-lines (current-view) #'open-rectangle-line (point) (mark))) (set-key 'com-open-rectangle 'editing-table '((#\x :control) (#\r) (#\o))) (define-command (com-string-rectangle :name t :command-table editing-table) ((string 'string :prompt "String rectangle")) "Replace each line of the rectangle bounded by current point of mark with `string'. The length of the string need not be equal to the width of the rectangle." (map-rectangle-lines (current-view) #'(lambda (mark startcol endcol) (replace-rectangle-line mark startcol endcol string)) (point) (mark))) (set-key 'com-string-rectangle 'editing-table '((#\x :control) (#\r) (#\t))) (define-command (com-string-insert-rectangle :name t :command-table editing-table) ((string 'string :prompt "String rectangle")) "Insert `string' in each line of the rectangle bounded by current point of mark. Text in the rectangle will be shifted right." (map-rectangle-lines (current-view) #'(lambda (mark startcol endcol) (insert-in-rectangle-line mark startcol endcol string)) (point) (mark))) (define-command (com-delete-whitespace-rectangle :name t :command-table editing-table) () (map-rectangle-lines (current-view) #'delete-rectangle-line-whitespace (point) (mark)))cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/Tests/0000750000175000017500000000000011347763412016767 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/Tests/kill-ring-tests.lisp0000640000175000017500000001154610705412616022712 0ustar pdmpdm;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; ;;; The test cases in this files test the functions of the ;;; DREI-KILL-RING package implementing the kill ring functionality of ;;; Drei. (in-package :drei-tests) (def-suite kill-ring-tests :description "The test suite for DREI-KILL-RING related tests." :in drei-tests) (in-suite kill-ring-tests) (test kill-ring-sizing (let ((random-size (max 5 (random 20)))) (let ((instance (make-instance 'kill-ring :max-size random-size))) (is (= (kill-ring-max-size instance) random-size))) (let ((instance (make-instance 'kill-ring :max-size random-size))) (setf (kill-ring-max-size instance) (* random-size 2)) (is (= (kill-ring-max-size instance) (* random-size 2)))) (let ((instance (make-instance 'kill-ring :max-size random-size))) (is (/= (kill-ring-max-size instance) (kill-ring-length instance)))))) (test kill-ring-standard-push (let* ((random-size (max 3 (random 20))) (instance (make-instance 'kill-ring :max-size random-size))) (kill-ring-standard-push instance #(#\A)) (kill-ring-standard-push instance #(#\B)) (kill-ring-standard-push instance #(#\C)) (is (= (kill-ring-length instance) 3))) (let* ((random-size (1+ (random 20))) (instance (make-instance 'kill-ring :max-size random-size))) (signals type-error (kill-ring-standard-push instance nil))) (let* ((instance (make-instance 'kill-ring :max-size 3))) (kill-ring-standard-push instance #(#\A)) (kill-ring-standard-push instance #(#\B)) (kill-ring-standard-push instance #(#\C)) (kill-ring-standard-push instance #(#\D)) (kill-ring-standard-push instance #(#\E)) (is (equal (coerce (kill-ring-yank instance) 'string) "E")) (rotate-yank-position instance) (is (equal (coerce (kill-ring-yank instance) 'string) "D")) (rotate-yank-position instance) (is (equal (coerce (kill-ring-yank instance) 'string) "C")))) (test kill-ring-concatenating-push (let* ((instance (make-instance 'kill-ring :max-size 3))) (kill-ring-standard-push instance #(#\A)) (kill-ring-concatenating-push instance #(#\B)) (is (equal (coerce (kill-ring-yank instance) 'string) "AB"))) (let* ((instance (make-instance 'kill-ring :max-size 5))) (kill-ring-standard-push instance #(#\B)) (kill-ring-standard-push instance #(#\Space)) (kill-ring-standard-push instance #(#\A)) (rotate-yank-position instance 2) (kill-ring-concatenating-push instance #(#\B #\C)) (is (equal (coerce (kill-ring-yank instance) 'string) "ABC")))) (test kill-ring-reverse-concatenating-push (let* ((instance (make-instance 'kill-ring :max-size 3))) (kill-ring-standard-push instance #(#\A)) (kill-ring-reverse-concatenating-push instance #(#\B)) (is (equal (coerce (kill-ring-yank instance) 'string) "BA"))) (let* ((instance (make-instance 'kill-ring :max-size 5))) (kill-ring-standard-push instance #(#\B)) (kill-ring-standard-push instance #(#\Space)) (kill-ring-standard-push instance #(#\A)) (rotate-yank-position instance 2) (kill-ring-reverse-concatenating-push instance #(#\B #\C)) (is (equal (coerce (kill-ring-yank instance) 'string) "BCA")))) (test kill-ring-yank (let* ((instance (make-instance 'kill-ring :max-size 5))) (kill-ring-standard-push instance #(#\A)) (is (equal (coerce (kill-ring-yank instance) 'string) "A"))) (let* ((instance (make-instance 'kill-ring :max-size 5))) (kill-ring-standard-push instance #(#\A)) (is (equal (coerce (kill-ring-yank instance) 'string) "A")) (is (equal (coerce (kill-ring-yank instance) 'string) "A")) (is (eq (kill-ring-yank instance) (kill-ring-yank instance)))) (let* ((instance (make-instance 'kill-ring :max-size 5))) (signals empty-kill-ring (kill-ring-yank instance)))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/Tests/lisp-syntax-swine-tests.lisp0000640000175000017500000004762610741375213024451 0ustar pdmpdm;;; -*- Mode: Lisp; Package: DREI-TESTS -*- ;;; (c) copyright 2006-2007 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (cl:in-package :drei-tests) (in-suite lisp-syntax-tests) (test arglist-keyword-p "Test that the Lisp syntax module can properly recognize lambda list keywords." (mapcar #'(lambda (symbol) (is-true (drei-lisp-syntax::lambda-list-keyword-p symbol))) lambda-list-keywords) (is-false (drei-lisp-syntax::lambda-list-keyword-p '&keyword))) ;; This is to make FiveAM give useful output when tests fail. (defmacro testing-find-affected-parameters (&body body) `(macrolet ((test-find-affected-parameters (lambda-list arg-indices expected-result) `(flet ((affected-parameters (lambda-list arg-indices) (mapcar #'(lambda (parameter) (typecase parameter (drei-lisp-syntax::named-parameter (drei-lisp-syntax::name parameter)) (drei-lisp-syntax::keyword-parameter (drei-lisp-syntax::keyword-name parameter)))) (drei-lisp-syntax::find-affected-parameters (drei-lisp-syntax::parse-lambda-list (drei-lisp-syntax::cleanup-arglist lambda-list)) arg-indices)))) (is (equal ,expected-result (affected-parameters ,lambda-list ,arg-indices)))))) ,@body)) (test find-affected-parameters-1 "Test the `find-affected-parameters' function for ordinary lambda lists." (testing-find-affected-parameters (test-find-affected-parameters '() '((0)) '()) (test-find-affected-parameters '(a) '((0)) '(a)) (test-find-affected-parameters '(a) '((1)) '()) (test-find-affected-parameters '(a b) '((1)) '(b)) (test-find-affected-parameters '(&optional) '((0)) '()) (test-find-affected-parameters '(&optional a) '((0)) '(a)) (test-find-affected-parameters '(&optional a) '((1)) '()) (test-find-affected-parameters '(&optional a b) '((1)) '(b)) (test-find-affected-parameters '(a &optional b) '((0)) '(a)) (test-find-affected-parameters '(a &optional b) '((1)) '(b)) (test-find-affected-parameters '(&rest a) '((0)) '(a)) (test-find-affected-parameters '(&rest a) '((1)) '(a)) (test-find-affected-parameters '(&key a) '((0)) '()) (test-find-affected-parameters '(&key a) '((1 :a)) '(:a)) (test-find-affected-parameters '(&key a b) '((1 :b)) '(:b)) (test-find-affected-parameters '(&key a b) '((1 :c)) '()) (test-find-affected-parameters '(a b &rest args &key c d) '((3 :d)) '(args :d)))) (test find-affected-parameters-2 "Test the `find-affected-parameters' function for macro lambda lists." (testing-find-affected-parameters (test-find-affected-parameters '((a)) '((0)) '()) (test-find-affected-parameters '((a)) '((0) (0)) '(a)) (test-find-affected-parameters '((a)) '((0) (1)) '()) (test-find-affected-parameters '((a b)) '((0) (1)) '(b)) (test-find-affected-parameters '(a (b)) '((1)) '()) (test-find-affected-parameters '(a (b)) '((1) (0)) '(b)) (test-find-affected-parameters '(a (b)) '((1) (1)) '()) (test-find-affected-parameters '(a (b c)) '((1) (1)) '(c)) (test-find-affected-parameters '((&optional a)) '((0) (0)) '(a)) (test-find-affected-parameters '((&rest a)) '((0) (0)) '(a)) (test-find-affected-parameters '(&key a) '((1 :a)) '(:a)) (test-find-affected-parameters '(&key ((:a (a)))) '((1 :a)) '(:a)) (test-find-affected-parameters '((a b &rest args &key c d)) '((0) (3 :d)) '(args :d)) (test-find-affected-parameters '(((a b &rest args &key c d))) '((0) (0) (3 :d)) '(args :d)) (test-find-affected-parameters '(&optional ((a))) '((0) (0)) '(a)) (test-find-affected-parameters '(&optional ((&optional a))) '((0) (0)) '(a)) (test-find-affected-parameters '(&key ((:a (a)))) '((1 :a) (0)) '(:a a)) (test-find-affected-parameters '(&key ((:a (&key b)))) '((1 :a) (1 :b)) '(:a :b)))) (test find-argument-indices-for-operand "Test the `find-argument-indices-for-operand' function." (macrolet ((test-argument-indices-for-operand (contents operand-index expected-result) `(macrolet ((argument-indices (contents operand-index) `(testing-lisp-syntax (,contents :package :drei-tests) (drei-lisp-syntax::find-argument-indices-for-operand (current-syntax) (drei-lisp-syntax::form-around (current-syntax) ,operand-index) (drei-lisp-syntax::form-around (current-syntax) 0))))) (is (equal ',expected-result (argument-indices ,contents ,operand-index)))))) (test-argument-indices-for-operand "(f)" 1 nil) (test-argument-indices-for-operand "(f 1)" 4 ((0))) (test-argument-indices-for-operand "(f 1 2)" 6 ((1 1))) (test-argument-indices-for-operand "(f 1 2)" 6 ((1 1))) (test-argument-indices-for-operand "(f (1))" 5 ((0) (0))) (test-argument-indices-for-operand "(f ((1)))" 6 ((0) (0) (0))) (test-argument-indices-for-operand "(f (s foo :keyword 'boolean) foo bar baz)" 19 ((0) (3 :keyword))) (test-argument-indices-for-operand "(f (s foo :keyword 'boolean) foo bar baz)" 35 ((2 foo))))) (test find-operand-info "Test the `find-operand-info' function." (macrolet ((test-find-operand-info (string offset correct-path) `(macrolet ((path-of (string offset) `(testing-lisp-syntax (,string :package :drei-tests) (drei-lisp-syntax::find-operand-info (current-syntax) ,offset (drei-lisp-syntax::form-around (current-syntax) 0))))) (is (equal ',correct-path (path-of ,string ,offset)))))) (test-find-operand-info "(list )" 5 nil) (test-find-operand-info "(list )" 6 ((0))) (test-find-operand-info "(list " 6 ((0))) (test-find-operand-info "(list )" 10 ((0))) (test-find-operand-info "(list 1)" 7 ((0))) (test-find-operand-info "(list 1" 7 ((0))) (test-find-operand-info "(list 1 )" 8 ((1 1))) (test-find-operand-info "(list 1 2)" 8 ((1 1))) (test-find-operand-info "(list 1 2" 8 ((1 1))) (test-find-operand-info "(lisp-syntax-m1 (s foo :element-type 'boolean) foo bar baz)" 16 ((0))) (test-find-operand-info "(lisp-syntax-m1 (s foo :element-type 'boolean) foo bar baz)" 17 ((0) (0))) (test-find-operand-info "(lisp-syntax-m1 (s foo :element-type 'boolean) foo bar baz)" 19 ((0) (1 s))) (test-find-operand-info "(lisp-syntax-m1 (s foo :element-type 'boolean) foo bar baz)" 51 ((2 foo))))) ;; This is to make FiveAM give useful output when tests fail. (defmacro testing-indices-match-arglist (&body body) `(macrolet ((test-indices-match-arglist (lambda-list arg-indices expected-result) `(flet ((indices-match-raw-arglist (lambda-list arg-indices) (drei-lisp-syntax::indices-match-arglist (drei-lisp-syntax::parse-lambda-list (drei-lisp-syntax::cleanup-arglist lambda-list)) arg-indices))) (is (equal ,expected-result (indices-match-raw-arglist ',lambda-list ',arg-indices)))))) ,@body)) (test indices-match-arglist-1 "Test the `indices-match-arglist' function for ordinary lambda lists." (testing-indices-match-arglist (test-indices-match-arglist (a) ((0)) t) (test-indices-match-arglist (a) ((1)) nil) (test-indices-match-arglist (a b) ((0)) t) (test-indices-match-arglist (a b) ((1)) t) (test-indices-match-arglist (a b) ((2)) nil) (test-indices-match-arglist (&optional a) ((0)) t) (test-indices-match-arglist (&optional a) ((1)) nil) (test-indices-match-arglist (&optional a b) ((0)) t) (test-indices-match-arglist (&optional a b) ((1)) t) (test-indices-match-arglist (&optional a b) ((2)) nil) (test-indices-match-arglist (&key a) ((0)) t) (test-indices-match-arglist (&key a) ((1)) t) (test-indices-match-arglist (&key a b) ((0)) t) (test-indices-match-arglist (&key a b) ((1)) t) (test-indices-match-arglist (&key a b) ((2)) t) (test-indices-match-arglist (&rest args) ((0)) t) (test-indices-match-arglist (&rest args) ((1)) t) (test-indices-match-arglist (&rest args) ((2)) t))) (test indices-match-arglist-2 "Test the `indices-match-arglist' function for macro lambda lists." (testing-indices-match-arglist (test-indices-match-arglist (&body args) ((0)) t) (test-indices-match-arglist (&body args) ((1)) t) (test-indices-match-arglist (&body args) ((2)) t) (test-indices-match-arglist ((a)) ((0) (0)) t) (test-indices-match-arglist ((a)) ((0) (1)) nil) (test-indices-match-arglist ((a b)) ((0) (0)) t) (test-indices-match-arglist ((a b)) ((0) (1)) t) (test-indices-match-arglist ((a b)) ((0) (2)) nil) (test-indices-match-arglist ((&optional a)) ((0) (0)) t) (test-indices-match-arglist ((&key a)) ((0)) t) (test-indices-match-arglist ((&key a)) ((0) (0)) t) (test-indices-match-arglist ((&key a)) ((0) (1 :a)) t) (test-indices-match-arglist ((&rest args)) ((0) (0)) t) (test-indices-match-arglist ((&rest args)) ((0) (1)) t) (test-indices-match-arglist ((&rest args)) ((0) (2)) t))) (swine-test find-direct-operator "Test the `find-direct-operator' function." (macrolet ((test-find-direct-operator (string offset desired-operator) `(macrolet ((direct-operator-of (string offset) `(testing-lisp-syntax (,string :package :drei-tests) (first (form-to-object (current-syntax) (drei-lisp-syntax::find-direct-operator (current-syntax) (drei-lisp-syntax::form-around (current-syntax) ,offset))))))) (is (eq ,desired-operator (direct-operator-of ,string ,offset)))))) (test-find-direct-operator "(list 1)" 7 'list) (test-find-direct-operator "(list 1 2 3)" 11 'list) (test-find-direct-operator "(drei-tests::lisp-syntax-m1 (s \"foo\" :element-type 'boolean) foo bar baz)" 30 'drei-tests::lisp-syntax-m1) (test-find-direct-operator "(drei-tests::lisp-syntax-m1 (s \"foo\" :element-type 'boolean) foo bar baz)" 31 'drei-tests::lisp-syntax-m1) (test-find-direct-operator "(drei-tests::lisp-syntax-m1 (s \"foo\" :element-type 'boolean) foo bar baz)" 71 'drei-tests::lisp-syntax-m1))) (swine-test find-applicable-form "Test the `find-applicable-form' function." (macrolet ((test-find-applicable-form (string offset desired-operator) `(macrolet ((applicable-operator-of (string offset) `(testing-lisp-syntax (,string :package :drei-tests) (first (form-to-object (current-syntax) (drei-lisp-syntax::find-applicable-form (current-syntax) (drei-lisp-syntax::form-around (current-syntax) ,offset))))))) (is (eq ,desired-operator (applicable-operator-of ,string ,offset))))) (test-no-find-applicable-form (string offset) `(macrolet ((applicable-form-of (string offset) `(testing-lisp-syntax (,string :package :drei-tests) (drei-lisp-syntax::find-applicable-form (current-syntax) (drei-lisp-syntax::form-around (current-syntax) ,offset))))) (is-false (applicable-form-of ,string ,offset))))) (test-find-applicable-form "(list 1)" 6 'list) (test-find-applicable-form "(list 1" 6 'list) (test-no-find-applicable-form "(list (1))" 7) (test-no-find-applicable-form "(list (1" 7) (test-find-applicable-form "(lisp-syntax-m2 :a ())" 19 'lisp-syntax-m2))) (test relevant-keywords "Test the `relevant-keywords' function." (macrolet ((test-relevant-keywords (lambda-list arg-indices desired-result) `(macrolet ((relevant-keywords-at (lambda-list arg-indices) `(drei-lisp-syntax::relevant-keywords (drei-lisp-syntax::parse-lambda-list ',lambda-list) ',arg-indices))) (is (equal ',desired-result (relevant-keywords-at ,lambda-list ,arg-indices)))))) (test-relevant-keywords () ((0)) nil) (test-relevant-keywords (a) ((0)) nil) (test-relevant-keywords (a) ((1)) nil) (test-relevant-keywords (&key a b c) ((0)) (:a :b :c)) (test-relevant-keywords (a &key b c) ((1)) (:b :c)) (test-relevant-keywords (a &key b c) ((0)) nil) (test-relevant-keywords ((&key a b) c) ((0) (0)) (:a :b)) (test-relevant-keywords ((&key a b) c) ((1)) nil) (test-relevant-keywords (&key ((:a (&key b))) c) ((0 :a) (0)) (:b)) (test-relevant-keywords (&key ((:a (&key b))) c) ((1)) (:a :c)))) (swine-test possible-completions "Test the `possible-completions' function." (testing-lisp-syntax ("") (flet ((find-possible-completions (string &optional operator operands indices) (drei-lisp-syntax::possible-completions (current-syntax) operator string #.(find-package :common-lisp) operands indices))) (is (equal '("lisp-implementation-type" "lisp-implementation-version" "list" "list*" "list-all-packages" "list-length" "listen" "listp") (find-possible-completions "lis"))) (is (equal '("cl:lisp-implementation-type" "cl:lisp-implementation-version" "cl:list" "cl:list*" "cl:list-all-packages" "cl:list-length" "cl:listen" "cl:listp") (find-possible-completions "cl:lis"))) (is (equal '("multiple-value-bind") (find-possible-completions "m-v-b"))) (is-false (find-possible-completions "mvb")) (is (equal (find-possible-completions "m-v-c") '("multiple-value-call"))) (is (equal '("multiple-value-bind") (find-possible-completions "multiple-value-bind"))) (let ((all-external-symbols-in-cl-and-all-package-names (union (loop for sym being the external-symbols in :common-lisp collecting (string sym)) (mapcar #'(lambda (string) (format nil "~A:" string)) (nconc (mapcar #'package-name (list-all-packages)) (reduce #'append (mapcar #'package-nicknames (list-all-packages)))))))) (is-false (set-difference (find-possible-completions "") all-external-symbols-in-cl-and-all-package-names :test #'equal)))))) (swine-test with-code-insight "Test the `with-code-insight' macro." (testing-lisp-syntax ("(list ") (drei-lisp-syntax::with-code-insight 6 (current-syntax) (:operator operator :form form :this-operand-indices indices :operands operands) (is (eq 'list operator)) (is-true (and (drei-lisp-syntax::form-list-p form) (drei-lisp-syntax::form-incomplete-p form))) (is (equal '((0)) indices)) (is-true (null operands)))) (testing-lisp-syntax ("(list 1 )") (drei-lisp-syntax::with-code-insight 8 (current-syntax) (:operator operator :form form :this-operand-indices indices :operands operands) (is (eq 'list operator)) (is-true (and (drei-lisp-syntax::form-list-p form) (drei-lisp-syntax::form-complete-p form))) (is (equal '((1 1)) indices)) (is (equal '(1) operands)))) (testing-lisp-syntax ("(with-output-to-string (stream string) (list stream))") (drei-lisp-syntax::with-code-insight 23 (current-syntax) (:operator operator :form form :this-operand-indices indices :operands operands) (is (eq 'with-output-to-string operator)) (is-true (and (drei-lisp-syntax::form-list-p form) (drei-lisp-syntax::form-complete-p form))) (is (equal '((0)) indices)) (is (equal '((stream string) (list stream)) operands))))) (swine-test make-instance-form-traits "Test the form traits for the `make-instance' function" (testing-lisp-syntax ("") (flet ((find-possible-completions (string &optional operator operands indices) (drei-lisp-syntax::possible-completions (current-syntax) operator string #.(find-package :common-lisp) operands indices))) (is (equal '("clim:clim-stream-pane") (find-possible-completions "clim:c-s-" 'make-instance '('#:c-s-) '((0))))) (is (equal '("lisp-implementation-type" "lisp-implementation-version" "list" "list*" "list-all-packages" "list-length" "listen" "listp") (find-possible-completions "lis" 'make-instance '(#:lis) '((0))))) (is-false (find-possible-completions "cl:nonono" 'make-instance '('#:nonono) '((0))))) (let ((lambda-list (drei-lisp-syntax::arglist-for-form (current-syntax) 'make-instance '('lisp-syntax-c1)))) (flet ((takes-keyword-arg (keyword) (member keyword (drei-lisp-syntax::keyword-parameters lambda-list) :key #'drei-lisp-syntax::keyword-name))) (is-true (takes-keyword-arg :foo)) (is-true (takes-keyword-arg 'bar)))))) (swine-test find-class-form-traits "Test the form traits for the `find-class' function" (testing-lisp-syntax ("") (flet ((find-possible-completions (string &optional operator operands indices) (drei-lisp-syntax::possible-completions (current-syntax) operator string #.(find-package :common-lisp) operands indices))) (is (equal '("clim:clim-stream-pane") (find-possible-completions "clim:c-s-" 'find-class '('#:c-s-) '((0))))) (is (equal '("lisp-implementation-type" "lisp-implementation-version" "list" "list*" "list-all-packages" "list-length" "listen" "listp") (find-possible-completions "lis" 'find-class '(#:lis) '((0))))) (is-false (find-possible-completions "cl:nonono" 'find-class '('#:nonono) '((0))))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/Tests/lisp-syntax-tests.lisp0000644000175000017500000022722411345155772023333 0ustar pdmpdm;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2006-2007 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (cl:in-package :drei-tests) (def-suite lisp-syntax-tests :description "The test suite for tests related to the Lisp syntax module. The parser is not explicitly tested. Instead, it is hoped that any defects will be caught by other test cases, all of which depend on correct parsing. Also, redisplay is not tested, because no-one has any idea how to do it." :in drei-tests) (in-suite lisp-syntax-tests) (defvar *run-self-compilation-test* nil "If true, running the Lisp syntax module test suite will involve an extreme stress test wherein the Lisp parser will be used to read in the Drei source code, recompile Drei based on the parser result and re-run the test suite (except for this self-compilation test, of course).") (defmacro testing-lisp-syntax ((buffer-contents &rest options) &body body) (assert (evenp (length options))) (with-gensyms (buffer view drei) `(with-buffer (,buffer :initial-contents ,buffer-contents) (with-view (,view :buffer ,buffer :syntax 'lisp-syntax) ,@(loop for (option value) on options by #'cddr collecting `(eval-option (syntax ,view) ,option ,value)) (let ((,drei (make-instance 'test-drei :view ,view))) (with-bound-drei-special-variables (,drei :minibuffer nil) (labels ((get-form () (update-parse (current-syntax)) (first (drei-lisp-syntax::children (slot-value (current-syntax) 'drei-lisp-syntax::stack-top)))) (get-object (&rest args) (apply #'form-to-object (current-syntax) (get-form) args))) (update-parse (current-syntax)) ,@body))))))) (defmacro swine-test (name &body body) `(test ,name ,(when (stringp (first body)) (first body)) (if (eq (drei-lisp-syntax::default-image) t) (skip "No useful image link found") (progn ,@body)))) (defmacro testing-symbol ((sym-sym &rest args) &body body) `(let ((,sym-sym (get-object ,@args))) ,@body (unless (or (null (symbol-package sym)) (eq (symbol-package sym) (find-package :clim)) (eq (symbol-package sym) (find-package :common-lisp)) (eq (symbol-package sym) (find-package :keyword))) (unintern ,sym-sym (symbol-package sym))))) (defmacro testing-lisp-syntax-symbol ((buffer-contents sym-sym &rest args) &body body) `(testing-lisp-syntax (,buffer-contents) (flet ((get-object (&rest args) (apply #'form-to-object (current-syntax) (first (drei-lisp-syntax::children (slot-value (current-syntax) 'drei-lisp-syntax::stack-top))) args))) (testing-symbol (,sym-sym ,@args) ,@body)))) (test lisp-syntax-test-base "Test the Base syntax attribute for Lisp syntax." (testing-lisp-syntax ("") (is (= *read-base* (drei-lisp-syntax::base (current-syntax))))) (testing-lisp-syntax ("" :base "2") (is (= 2 (drei-lisp-syntax::base (current-syntax))))) (testing-lisp-syntax ("" :base "36") (is (= 36 (drei-lisp-syntax::base (current-syntax))))) (testing-lisp-syntax ("" :base "1") ; Should be ignored. (is (= *read-base* (drei-lisp-syntax::base (current-syntax))))) (testing-lisp-syntax ("" :base "37") ; Should be ignored. (is (= *read-base* (drei-lisp-syntax::base (current-syntax)))))) (test lisp-syntax-test-package "Test the Package syntax attribute for Lisp syntax." (testing-lisp-syntax ("") (is (eq nil (drei-lisp-syntax::option-specified-package (current-syntax))))) (testing-lisp-syntax ("" :package "COMMON-LISP") (is (eq (find-package :cl) (drei-lisp-syntax::option-specified-package (current-syntax))))) (testing-lisp-syntax ("" :package "CL") (is (eq (find-package :cl) (drei-lisp-syntax::option-specified-package (current-syntax))))) (testing-lisp-syntax ("" :package "common-lisp") (is (string= "common-lisp" (drei-lisp-syntax::option-specified-package (current-syntax)))))) (test lisp-syntax-test-attributes "Test that the syntax attributes of Lisp syntax are returned properly." (testing-lisp-syntax ("") (is-true (assoc :package (current-attributes-for-syntax (current-syntax)))) (is-true (assoc :base (current-attributes-for-syntax (current-syntax)))))) (test lisp-syntax-package-at-mark "Test that Lisp syntax' handling of (in-package) forms is correct." (testing-lisp-syntax ("(in-package :cl-user) ") (is (eq *package* (drei-lisp-syntax::package-at-mark (current-syntax) 10)))) (testing-lisp-syntax ("(in-package :cl-user) " :package "DREI-LISP-SYNTAX") (is (eq (find-package :drei-lisp-syntax) (drei-lisp-syntax::package-at-mark (current-syntax) 10)))) (testing-lisp-syntax ("(in-package :cl-user) ") (is (eq (find-package :cl-user) (drei-lisp-syntax::package-at-mark (current-syntax) 23)))) (testing-lisp-syntax ("(in-package \"CL-USER\") ") (is (eq (find-package :cl-user) (drei-lisp-syntax::package-at-mark (current-syntax) 23)))) (testing-lisp-syntax ("(in-package \"cl-user\") ") (is (eq *package* (drei-lisp-syntax::package-at-mark (current-syntax) 23)))) (testing-lisp-syntax ("(in-package :cl-user)(in-package :clim) ") (is (eq (find-package :clim) (drei-lisp-syntax::package-at-mark (current-syntax) 43)))) (testing-lisp-syntax ("(in-package :cl-user)(in-package :iDoNotExist) ") (is (eq (find-package :cl-user) (drei-lisp-syntax::package-at-mark (current-syntax) 43))))) (test lisp-syntax-provided-package-name-at-mark "Test that Lisp syntax' handling of (in-package) forms is correct, even counting packages that cannot be found." (testing-lisp-syntax ("(in-package :cl-user) ") (is (string= "CLIM-USER" (drei-lisp-syntax::provided-package-name-at-mark (current-syntax) 10)))) (testing-lisp-syntax ("(in-package :cl-user) " :package "DREI-LISP-SYNTAX") (is (string= "DREI-LISP-SYNTAX" (drei-lisp-syntax::provided-package-name-at-mark (current-syntax) 10)))) (testing-lisp-syntax ("(in-package :cl-user) ") (is (string= "CL-USER" (drei-lisp-syntax::provided-package-name-at-mark (current-syntax) 23)))) (testing-lisp-syntax ("(in-package \"CL-USER\") ") (is (string= "CL-USER" (drei-lisp-syntax::provided-package-name-at-mark (current-syntax) 23)))) (testing-lisp-syntax ("(in-package \"cl-user\") ") (is (string= "cl-user" (drei-lisp-syntax::provided-package-name-at-mark (current-syntax) 23)))) (testing-lisp-syntax ("(in-package :cl-user)(in-package :clim) ") (is (string= "CLIM" (drei-lisp-syntax::provided-package-name-at-mark (current-syntax) 43)))) (testing-lisp-syntax ("(in-package :cl-user)(in-package :iDoNotExist) ") (is (string= "IDONOTEXIST" (drei-lisp-syntax::provided-package-name-at-mark (current-syntax) 48))))) (test lisp-syntax-need-to-update-package-list-p "Test that Lisp syntax can properly handle it when (in-package) forms change." (testing-lisp-syntax ("(in-package :cl-user) ") (is (eq (find-package :cl-user) (drei-lisp-syntax::package-at-mark (current-syntax) 23))) (delete-buffer-range (current-buffer) 0 (size (current-buffer))) (insert-buffer-sequence (current-buffer) 0 "(in-package :cl-userr) ") (is (eq *package* (drei-lisp-syntax::package-at-mark (current-syntax) 24))) (insert-buffer-sequence (current-buffer) 24 "(in-package :drei-lisp-syntax) ") (is (eq (find-package :drei-lisp-syntax) (drei-lisp-syntax::package-at-mark (current-syntax) 54))) (delete-buffer-range (current-buffer) 0 23) (insert-buffer-sequence (current-buffer) 0 "(in-package :clim-user)") (is (eq (find-package :clim-user) (drei-lisp-syntax::package-at-mark (current-syntax) 26))))) (test form-to-object-1 "Test that we can parse and recognize T in Lisp syntax." (testing-lisp-syntax ("T") (is (eq t (get-object)))) (testing-lisp-syntax ("t") (is (eq t (get-object))))) (test form-to-object-2 "Test that casing is properly done for NIL." (testing-lisp-syntax ("nil") (is (eq nil (get-object)))) (testing-lisp-syntax ("NIL") (is (eq nil (get-object)))) (testing-lisp-syntax ("NIl") (is (eq nil (get-object)))) (testing-lisp-syntax ("NIl") (is-false (eq nil (get-object :case :preserve))))) (test form-to-object-3 "Test case-conversion for tokens." (testing-lisp-syntax ("iDoNotExist") (testing-symbol (sym :case :upcase) (is-false (symbol-package sym)) (is (string= "IDONOTEXIST" (symbol-name sym)))) (testing-symbol (sym :case :preserve) (is-false (symbol-package sym)) (is (string= "iDoNotExist" (symbol-name sym)))) (testing-symbol (sym :case :downcase) (is-false (symbol-package sym)) (is (string= "idonotexist" (symbol-name sym)))) (testing-symbol (sym :read t :case :upcase) (is-true (symbol-package sym)) (is (string= "IDONOTEXIST" (symbol-name sym)))) (testing-symbol (sym :read t :case :preserve) (is-true (symbol-package sym)) (is (string= "iDoNotExist" (symbol-name sym)))) (testing-symbol (sym :read t :case :downcase) (is-true (symbol-package sym)) (is (string= "idonotexist" (symbol-name sym)))) (testing-symbol (sym :case :invert) (is-false (symbol-package sym)) (is (string= "iDoNotExist" (symbol-name sym))))) (testing-lisp-syntax-symbol ("IDONOTEXIST" sym :case :invert) (is-false (symbol-package sym)) (is (string= "idonotexist" (symbol-name sym)))) (testing-lisp-syntax-symbol ("idonotexist" sym :case :invert) (is-false (symbol-package sym)) (is (string= "IDONOTEXIST" (symbol-name sym))))) (test form-to-object-4 "Test case-conversion for uninterned tokens." (testing-lisp-syntax ("#:iDoNotExist") (testing-symbol (sym :case :upcase) (is-false (symbol-package sym)) (is (string= "IDONOTEXIST" (symbol-name sym)))) (testing-symbol (sym :case :preserve) (is-false (symbol-package sym)) (is (string= "iDoNotExist" (symbol-name sym)))) (testing-symbol (sym :case :downcase) (is-false (symbol-package sym)) (is (string= "idonotexist" (symbol-name sym)))) (testing-symbol (sym :case :invert) (is-false (symbol-package sym)) (is (string= "iDoNotExist" (symbol-name sym))))) (testing-lisp-syntax ("#:IDONOTEXIST") (let ((sym (get-object :case :invert))) (is-false (symbol-package sym)) (is (string= "idonotexist" (symbol-name sym))))) (testing-lisp-syntax ("#:idonotexist") (let ((sym (get-object :case :invert))) (is-false (symbol-package sym)) (is (string= "IDONOTEXIST" (symbol-name sym)))))) (test form-to-object-5 "Test handling of escaped symbols." (testing-lisp-syntax-symbol ("|123|" sym :read t) (is (string= "123" (symbol-name sym)))) (testing-lisp-syntax-symbol ("|LIST|" sym :read t :case :downcase) (is (string= "LIST" (symbol-name sym)))) (testing-lisp-syntax-symbol ("| |" sym :read t) (is (string= " " (symbol-name sym)))) (testing-lisp-syntax-symbol ("|foo|bar|abbabz|" sym :read t) (is (string= "fooBARabbabz" (symbol-name sym)))) (testing-lisp-syntax-symbol ("||" sym :read t) (is (string= "" (symbol-name sym)))) (testing-lisp-syntax-symbol ("||||" sym :read t) (is (string= "" (symbol-name sym))))) (test form-to-object-6 "Test keyword symbols." (testing-lisp-syntax-symbol (":foo" sym :read t) (is (string= "FOO" (symbol-name sym))) (is (eq (find-package :keyword) (symbol-package sym))))) (test form-to-object-7 "Test that numbers are recognized and handled properly by the Lisp syntax." (testing-lisp-syntax ("123") (is (= 123 (get-object)))) (testing-lisp-syntax ("-123") (is (= -123 (get-object)))) (testing-lisp-syntax (".123") (is (= .123 (get-object)))) (testing-lisp-syntax ("-.123") (is (= -.123 (get-object)))) (testing-lisp-syntax ("1.234") (is (= 1.234 (get-object)))) (testing-lisp-syntax ("-1.234") (is (= -1.234 (get-object)))) (testing-lisp-syntax ("1e7") (is (= 1e7 (get-object)))) (testing-lisp-syntax ("1E7") (is (= 1e7 (get-object)))) (testing-lisp-syntax ("1.123E7") (is (= 1.123e7 (get-object)))) (testing-lisp-syntax ("-1.123E7") (is (= -1.123e7 (get-object)))) (testing-lisp-syntax (".123E7") (is (= .123e7 (get-object)))) (testing-lisp-syntax ("-.123E7") (is (= -.123e7 (get-object)))) (testing-lisp-syntax ("1.34e-7") (is (= 1.34e-7 (get-object))))) (test form-to-object-8 "Test that the standard reader macros for numbers are recognized and handled." (testing-lisp-syntax ("#b0000") (is (= 0 (get-object)))) (testing-lisp-syntax ("#b10") (is (= 2 (get-object)))) (testing-lisp-syntax ("#b-10") (is (= -2 (get-object)))) (testing-lisp-syntax ("#x00") (is (= 0 (get-object)))) (testing-lisp-syntax ("#xFE") (is (= 254 (get-object)))) (testing-lisp-syntax ("#x-FE") (is (= -254 (get-object)))) (testing-lisp-syntax ("#o00") (is (= 0 (get-object)))) (testing-lisp-syntax ("#o71") (is (= 57 (get-object)))) (testing-lisp-syntax ("#o-71") (is (= -57 (get-object))))) (test form-to-object-9 "Test handling of the literal character reader macro." (testing-lisp-syntax ("#\\a") (is (char= (get-object) #\a))) (testing-lisp-syntax ("#\\Null") (is (char= (get-object) #\Null))) (testing-lisp-syntax ("#\\NULL") (is (char= (get-object) #\Null))) (testing-lisp-syntax ("#\\ ") (is (char= (get-object) #\Space)))) (test form-to-object-10 "Test handling of list syntax." (testing-lisp-syntax ("(t t t)") (is (equal (get-object) '(t t t)))) (testing-lisp-syntax ("()") (is (eq (get-object) nil))) (testing-lisp-syntax ("(#\\ t)") (is (equal (get-object) '(#\Space t)))) (testing-lisp-syntax ("(NIL nil Nil)") (destructuring-bind (a b c) (get-object :case :preserve) (is (string= (symbol-name a) "NIL")) (is (string= (symbol-name b) "nil")) (is (string= (symbol-name c) "Nil"))))) (test form-to-object-11 "Test handling of the vector reader-macro syntax." (testing-lisp-syntax ("#(t t t)") (is (equalp (get-object) #(t t t)))) (testing-lisp-syntax ("#()") (is (equalp (get-object) #()))) (testing-lisp-syntax ("#(#\\ t)") (is (equalp (get-object) #(#\Space t)))) (testing-lisp-syntax ("#(NIL nil Nil)") (destructuring-bind (a b c) (loop for x across (get-object :case :preserve) collecting x) (is (string= (symbol-name a) "NIL")) (is (string= (symbol-name b) "nil")) (is (string= (symbol-name c) "Nil")))) (testing-lisp-syntax ("#(a b c c c c)") (is (equalp (get-object) #6(a b c c c c)))) (testing-lisp-syntax ("#6(a b c c c c)") (is (equalp (get-object) #6(a b c c c c)))) (testing-lisp-syntax ("#6(a b c)") (is (equalp (get-object) #6(a b c c c c)))) (testing-lisp-syntax ("#6(a b c c)") (is (equalp (get-object) #6(a b c c c c))))) (test form-to-object-12 "Test handling of dotted-pair forms." (testing-lisp-syntax ("(t . t)") (is (equal (get-object) '(t . t)))) (testing-lisp-syntax ("(t.t)") (is (string= (first (get-object)) "T.T"))) (testing-lisp-syntax ("(t . nil)") (is (equal (get-object) '(t)))) (testing-lisp-syntax ("(t t . t)") (is (equal (get-object) '(t t . t)))) (testing-lisp-syntax ("(#\\ . t)") (is (equal (get-object) '(#\Space . t)))) (testing-lisp-syntax ("(t t . 't)") (is (equal (get-object) '(t t quote t)))) (testing-lisp-syntax ("(NIL nil . Nil)") (destructuring-bind (a b . c) (get-object :case :preserve) (is (string= (symbol-name a) "NIL")) (is (string= (symbol-name b) "nil")) (is (string= (symbol-name c) "Nil"))))) (test form-to-object-13 "Test handling of incomplete list forms." (testing-lisp-syntax ("(t ") (finishes (get-object)) (signals form-conversion-error (get-object :read t)) (finishes (get-object :read t :no-error t)))) (test form-to-object-14 "Test backquote syntax handling for lists." (testing-lisp-syntax ("`(list ,(+ 2 2))") (is (equal (eval (get-object)) '(list 4)))) (testing-lisp-syntax ("``(list ,,(+ 2 2))") (is (equal (eval (eval (get-object))) '(list 4)))) (testing-lisp-syntax ("(let ((a '(1 2 3))) `(list ,@a))") (is (equal (eval (get-object :read t)) '(list 1 2 3)))) (testing-lisp-syntax ("(let ((a '(1 2 3))) `(let ((b 42)) `(list (,,@a) ,b))))") (is (equal (eval (eval (get-object :read t))) '(list (1 2 3) 42)))) (testing-lisp-syntax ("(let ((a '(1 2 3))) `(list ,a `',(+ 2 2)))") (is (equal (second (eval (get-object :read t))) '(1 2 3)))) (testing-lisp-syntax ("(let ((a 'list)) `',a)") (is (equal (eval (eval (get-object :read t))) 'list))) (testing-lisp-syntax ("(let ((a '(1 2 3))) `',`',a)") (is (equal (eval (get-object :read t)) '''(1 2 3)))) (testing-lisp-syntax ("(let ((a '(1 2 3))) ``(list ,@',a))") (is (equal (eval (eval (eval (get-object :read t)))) '(1 2 3)))) (testing-lisp-syntax ("(let ((a '(4 5 6))) `(list 1 2 3 ,.a))") (is (equal (eval (eval (get-object :read t))) '(1 2 3 4 5 6)))) (testing-lisp-syntax ("(let ((a '('(4 5 6) '(7 8 9)))) ```(list 1 2 3 ,.,@',a))") (is (equal (eval (eval (eval (eval (get-object :read t))))) '(1 2 3 4 5 6 7 8 9)))) (testing-lisp-syntax ("`(car . cdr)") (is (equal (eval (get-object :read t)) '(car . cdr))))) (test form-to-object-15 "Test backquote syntax handling for arrays." (testing-lisp-syntax ("`#(1 ,(+ 2 2) 6)") (is (equalp (eval (get-object :read t)) #(1 4 6)))) (testing-lisp-syntax ("(let ((a '(2 3 4 5))) `#(1 ,@a 6))") (is (equalp (eval (get-object :read t)) #(1 2 3 4 5 6)))) (testing-lisp-syntax ("`#(list ,(+ 2 2))") (is (equalp (eval (get-object)) #(list 4)))) (testing-lisp-syntax ("``(list #(,,(+ 2 2)))") (is (equalp (eval (eval (get-object))) '(list #(4))))) (testing-lisp-syntax ("(let ((a '(1 2 3))) `(let ((b 42)) `#(list #(,,@a) ,b))))") (is (equalp (eval (eval (get-object :read t))) #(list #(1 2 3) 42)))) (testing-lisp-syntax ("(let ((a #(1 2 3))) `(list #(,a) `#',(+ 2 2)))") (is (equalp (second (eval (get-object :read t))) #(#(1 2 3))))) (testing-lisp-syntax ("(let ((a 'list)) `#(,a))") (is (equalp (eval (eval (get-object :read t))) #(list)))) (testing-lisp-syntax ("(let ((a '(1 2 3))) `#(,`#(,a)))") (is (equalp (eval (get-object :read t)) #(#((1 2 3)))))) (testing-lisp-syntax ("(let ((a '(1 2 3))) ``#(,@',a))") (is (equalp (eval (eval (eval (get-object :read t)))) #(1 2 3)))) (testing-lisp-syntax ("(let ((a '(4 5 6))) `#(1 2 3 ,.a))") (is (equalp (eval (eval (get-object :read t))) #(1 2 3 4 5 6)))) (testing-lisp-syntax ("(let ((a '('(4 5 6) '(7 8 9)))) ```#(1 2 3 ,.,@',a))") (is (equalp (eval (eval (eval (eval (get-object :read t))))) #(1 2 3 4 5 6 7 8 9))))) (test form-to-object-16 "Test read-time conditional handling." (testing-lisp-syntax ("#+mcclim t") (is (eq (get-object) (or #+mcclim t)))) (testing-lisp-syntax ("#-mcclim t") (is (eq (get-object) (or #-mcclim t)))) (testing-lisp-syntax ("(#+mcclim t)") (is (equal (get-object) '(#+mcclim t)))) (testing-lisp-syntax ("(#-mcclim t)") (is (equal (get-object) '(#-mcclim t))))) (test form-to-object-17 "Test the reader syntax for labels (including circular references)." (testing-lisp-syntax ("(#1=list #1#)") (is (equal (get-object) '(list list)))) (testing-lisp-syntax ("#1=(list . #1#)") (finishes (loop for x in (get-object) for y in '#1=(list . #1#) for i from 0 upto 100 unless (eq y x) do (fail "~A is not eq to ~A" x y)))) (testing-lisp-syntax ("(#1=list (#1# 1 2 3))") (let ((form (drei-lisp-syntax::form-before (current-syntax) 14))) (is (eq 'list (form-to-object (current-syntax) form))))) (testing-lisp-syntax ("(#1=list #1=cons)") (signals form-conversion-error (get-object)))) (test form-to-object-18 "Test the reader syntax for multidimensional arrays." (testing-lisp-syntax ("#2A((0 1 5) (foo 2 (hot dog)))") (is (equalp (get-object) #2A((0 1 5) (foo 2 (hot dog)))))) (testing-lisp-syntax ("#2A((0 1) (foo 2 (hot dog)))") (signals form-conversion-error (get-object))) (testing-lisp-syntax ("#1A((0 1 5) (foo 2 (hot dog)))") (is (equalp (get-object) #1A((0 1 5) (foo 2 (hot dog)))))) (testing-lisp-syntax ("#0Anil") (is (equalp (get-object) #0Anil))) (testing-lisp-syntax ("#0A#2A((0 1 5) (foo 2 (hot dog)))") (is (equalp (get-object) #0A#2A((0 1 5) (foo 2 (hot dog))))))) (test form-to-object-19 "Test the handling of the quote reader macro." (testing-lisp-syntax ("'list") (is (eq 'quote (first (get-object)))) (is (eq 'list (second (get-object))))) (testing-lisp-syntax ("''list") (is (eq 'quote (first (get-object)))) (is (eq 'quote (caadr (get-object)))) (is (eq 'list (cadadr (get-object))))) (testing-lisp-syntax ("'#:list") (is (eq 'quote (first (get-object)))) (is (string= "LIST" (symbol-name (second (get-object))))) (is-false (symbol-package (second (get-object))))) (testing-lisp-syntax ("'#p\"foobar\"") (is (eq 'quote (first (get-object)))) (is (equalp #p"foobar" (second (get-object))))) (testing-lisp-syntax ("'#.(+ 2 2)") (is (eq 'quote (first (get-object)))) (is (= 4 (second (get-object :read t)))))) (defmacro testing-form-selectors ((buffer-contents &rest syntax-options) &body body) `(testing-lisp-syntax (,buffer-contents ,@syntax-options) (macrolet ((test-selector (selector-fn offset expected-result &optional (test 'eql)) `(is (,test ,expected-result (form-to-object (current-syntax) (,selector-fn (current-syntax) ,offset))))) (test-selector-null (selector-fn offset) `(is-false (,selector-fn (current-syntax) ,offset)))) ,@body))) (test form-before "Test the `form-before' form selector of Lisp syntax." (testing-form-selectors ("(list #|foo|# foo #|bar|# bar baz ; baz indeed ) ") (test-selector-null drei-lisp-syntax::form-before 0) (test-selector-null drei-lisp-syntax::form-before 4) (test-selector drei-lisp-syntax::form-before 5 'list)) (testing-form-selectors ("'(list #|foo|# foo #|bar|# bar baz ; baz indeed ) ") (test-selector-null drei-lisp-syntax::form-before 0) (test-selector-null drei-lisp-syntax::form-before 5) (test-selector drei-lisp-syntax::form-before 6 'list)) (testing-form-selectors ("#(list #|foo|# foo #|bar|# bar baz ; baz indeed ) ") (test-selector-null drei-lisp-syntax::form-before 0) (test-selector-null drei-lisp-syntax::form-before 5) (test-selector drei-lisp-syntax::form-before 6 'list)) (testing-form-selectors ("(list #|foo|# list #|bar|# find list ; baz indeed ") (test-selector drei-lisp-syntax::form-before 53 'list) (test-selector drei-lisp-syntax::form-before 43 'list) (test-selector drei-lisp-syntax::form-before 33 'find)) (testing-form-selectors ("'(list #|foo|# list #|bar|# find list ; baz indeed ") (test-selector drei-lisp-syntax::form-before 54 'list) (test-selector drei-lisp-syntax::form-before 44 'list) (test-selector drei-lisp-syntax::form-before 34 'find)) (testing-form-selectors ("#(list #|foo|# list #|bar|# find list ; baz indeed ") (test-selector drei-lisp-syntax::form-before 54 'list) (test-selector drei-lisp-syntax::form-before 44 'list) (test-selector drei-lisp-syntax::form-before 34 'find))) (test form-after "Test the `form-after' form selector of Lisp syntax." (testing-form-selectors ("(list #|foo|# foo #|bar|# bar baz ; baz indeed ) ") (test-selector-null drei-lisp-syntax::form-after (size (current-buffer))) (test-selector-null drei-lisp-syntax::form-after (- (size (current-buffer)) 4)) (test-selector drei-lisp-syntax::form-after 7 'foo))) (test form-around "Test the `form-around' form selector of Lisp syntax." (testing-form-selectors ("(list #|foo|# foo #|bar|# bar baz ; baz indeed ) ") (test-selector-null drei-lisp-syntax::form-around (size (current-buffer))) (test-selector drei-lisp-syntax::form-around (- (size (current-buffer)) 4) '(list foo bar baz) equal) (test-selector drei-lisp-syntax::form-around 3 'list))) (test expression-at-mark "Test the `expression-at-mark' function of Lisp syntax." (testing-form-selectors ("(list #|foo|# foo #|bar|# bar baz ; baz indeed ) " :syntax "DREI-TESTS") (test-selector drei-lisp-syntax::expression-at-mark 15 'foo) (test-selector drei-lisp-syntax::expression-at-mark 10 'foo) (test-selector drei-lisp-syntax::expression-at-mark (1- (size (current-buffer))) '(list foo bar baz) equal))) (test definition-at-mark "Test the `definition-at-mark' function of Lisp syntax." (testing-form-selectors ("(defun foo (&rest x y z) (append x y z))") (let ((expected-result '(defun foo (&rest x y z) (append x y z)))) (test-selector drei-lisp-syntax::definition-at-mark 0 expected-result equal) (test-selector drei-lisp-syntax::definition-at-mark 10 expected-result equal) (test-selector drei-lisp-syntax::definition-at-mark (1- (size (current-buffer))) expected-result equal)))) (test symbol-at-mark "Test the `symbol-at-mark' function of Lisp syntax." (testing-form-selectors ("'(''list 'progn #p\"foobar\" '''''''''identity) ") (test-selector drei-lisp-syntax::symbol-at-mark 5 'list) (test-selector drei-lisp-syntax::symbol-at-mark 15 'progn) (test-selector-null drei-lisp-syntax::symbol-at-mark 25))) (test this-form "Test the `this-form' function of Lisp syntax." (testing-form-selectors ("( list 1 (identity 4 5 6) 2 3)") (test-selector drei-lisp-syntax::this-form 0 '(list 1 (identity 4 5 6) 2 3) equal) (test-selector drei-lisp-syntax::this-form 1 '(list 1 (identity 4 5 6) 2 3) equal) (test-selector drei-lisp-syntax::this-form 4 'list) (test-selector drei-lisp-syntax::this-form 7 'list) (test-selector drei-lisp-syntax::this-form 8 'list))) (defmacro testing-lisp-predicate ((predicate) &body body) `(macrolet ((trues (&rest strings) `(progn ,@(mapcar #'(lambda (string) `(is-true ,(list ',predicate `(get-form-from-string ,string)))) strings))) (falses (&rest strings) `(progn ,@(mapcar #'(lambda (string) `(is-false ,(list ',predicate `(get-form-from-string ,string)))) strings)))) (flet ((get-form-from-string (string) (testing-lisp-syntax (string) (get-form)))) (progn ,@body)))) (test formp "Test the predicate for determining whether a syntax object is a form in the Lisp sense." (testing-lisp-predicate (drei-lisp-syntax::formp) (trues "(1 2 3)") (falses "#| foo |#"))) (test form-list-p "Test whether a syntax object represents a list." (testing-lisp-predicate (drei-lisp-syntax::form-list-p) (trues "(1 2 3)" "(1 2 3" ) (falses "42"))) (test form-incomplete-p "Test whether a syntax object represents an incomplete piece of syntax." (testing-lisp-predicate (drei-lisp-syntax::form-incomplete-p) (trues "(1 2 3" "#p\"foo") (falses "T" "42"))) (test form-complete-p "Test whether a syntax object represents a complete piece of syntax." (testing-lisp-predicate (drei-lisp-syntax::form-complete-p) (trues "T" "42") (falses "(1 2 3" "#p\"foo"))) (test form-token-p "Test whether a syntax object represents a token in the Lisp sense (CLHS 2.3)." (testing-lisp-predicate (drei-lisp-syntax::form-token-p) (falses "(1 2 3)" "#p\"foo\"") (trues "T" "42" "foobar" "|Foobar|" "#:foobar" "|Foobar|" ":foobar"))) (test form-string-p "Test whether a syntax object represents a string." (testing-lisp-predicate (drei-lisp-syntax::form-string-p) (trues "\"foobar\"" "\"foobar") (falses "foobar"))) (test form-quoted-p "Test whether a syntax object represents a quoted form." (testing-lisp-predicate (drei-lisp-syntax::form-quoted-p) (trues "'list" "'(foo bar baz)" "'#p\"foobar\"" "'`'''#:hello" "`',t" "'(1 2 3") (falses "42" "53" "(1 2 3" "foobar" "(quote hello)"))) (test form-comma-p "Test whether a syntax object represents a comma (,) form." (testing-lisp-predicate (drei-lisp-syntax::form-comma-p) (trues ",foo") (falses "'foo" "`',foo" ",.foobar" ",@foobaz"))) (test form-comma-at-p "Test whether a syntax object represents a comma-at (,@) form." (testing-lisp-predicate (drei-lisp-syntax::form-comma-at-p) (trues ",@foobaz") (falses "'foo" "`',foo" ",.foobar" ",foo"))) (test form-comma-dot-p "Test whether a syntax object represents a comma-dot (,.) form." (testing-lisp-predicate (drei-lisp-syntax::form-comma-dot-p) (trues ",.foobar") (falses "'foo" "`',foo" ",@foobaz" ",foo"))) (test comment-p "Test whether a syntax object represents a comment." (testing-lisp-predicate (drei-lisp-syntax::comment-p) (trues ";foo" ";" "#|foobar|#" "#||#" "#||||#" "#|") (falses "#:|foo|#"))) (test form-at-top-level-p "Test the function that determines whether a form is a top-level form." (testing-lisp-syntax ("(defun foo (&rest x y z) (append x y z))") (is-false (drei-lisp-syntax::form-at-top-level-p (drei-lisp-syntax::form-around (current-syntax) 10))) (is-true (drei-lisp-syntax::form-at-top-level-p (drei-lisp-syntax::form-around (current-syntax) 0))) (is-false (drei-lisp-syntax::form-at-top-level-p (drei-lisp-syntax::form-around (current-syntax) 30))))) (test replace-symbol-at-mark "Test the function for replacing symbols at the position of a mark." (testing-lisp-syntax ("(defun foo (&rest x y z) (append x y z))") (let ((mark (clone-mark (point)))) (setf (offset mark) 8) (performing-drei-operations ((current-window) :redisplay nil) (drei-lisp-syntax::replace-symbol-at-mark (current-syntax) mark "list")) (is (= 11 (offset mark))) (is (eq 'list (second (get-object)))) (setf (offset mark) 0) (performing-drei-operations ((current-window) :redisplay nil) (drei-lisp-syntax::replace-symbol-at-mark (current-syntax) mark "quote")) (is (= 5 (offset mark))) (is (eq 'quote (get-object))))) ;; And now for a real-world test case (completion)... (testing-lisp-syntax ("(w-o-t-s (s \"foo\" :e-t 'character ") (let ((mark (clone-mark (point)))) (setf (offset mark) 8) (performing-drei-operations ((current-window) :redisplay nil) (drei-lisp-syntax::replace-symbol-at-mark (current-syntax) mark "with-output-to-string")) (is (= 22 (offset mark))) (buffer-is "(with-output-to-string (s \"foo\" :e-t 'character ") (setf (offset mark) 36) (performing-drei-operations ((current-window) :redisplay nil) (drei-lisp-syntax::replace-symbol-at-mark (current-syntax) mark ":element-type")) (buffer-is "(with-output-to-string (s \"foo\" :element-type 'character ") (is (= 45 (offset mark)))))) (motion-fun-one-test (expression lisp-syntax) (51 0 (11 28 7) "(defun list (&rest elements) (append elements nil))") (nil nil (5 18 2) "#+nil (list 1 2 3)") (nil nil (0 2 nil) "#+nil (list 1 2 3)") (nil nil (6 7 3) " (nil) ")) (motion-fun-one-test (list lisp-syntax) (64 4 (22 41 11) "foo (defun (barbaz) list (&rest elements) (append elements nil))")) (motion-fun-one-test (down lisp-syntax) (1 53 (15 16 13) "(defun list () (&rest elements) (append elements nil))") (2 54 (16 17 14) "'(defun list () (&rest elements) (append elements nil))") (3 55 (17 18 15) "#'(defun list () (&rest elements) (append elements nil))")) (motion-fun-one-test (up lisp-syntax) (nil nil (13 14 12) "(defun list () (&rest elements) (append elements nil))") (nil nil (17 19 12) "(defun list (x y z) (list x y z))" ) (nil nil (21 24 0) "(defun list (x y z) )")) (motion-fun-one-test (definition lisp-syntax) (51 52 (35 51 0) "(defun list (&rest elements) (append elements nil)) (defun second (list) (cadr list))")) (test in-string-p "Test the `in-string-p' function of Lisp syntax." (testing-lisp-syntax (" \"foobar!\" ") (is-false (in-string-p (current-syntax) 0)) (is-false (in-string-p (current-syntax) 1)) (is-true (in-string-p (current-syntax) 2)) (is-true (in-string-p (current-syntax) 6)) (is-true (in-string-p (current-syntax) 9)) (is-false (in-string-p (current-syntax) 10)))) (test in-comment-p "Test the `in-comment-p' function of Lisp syntax." (testing-lisp-syntax (" ; I'm a comment ;; I'm another comment #| I'm a - BLOCK - comment |#") (is-false (in-comment-p (current-syntax) 0)) (is-false (in-comment-p (current-syntax) 1)) (is-true (in-comment-p (current-syntax) 2)) (is-true (in-comment-p (current-syntax) 16)) (is-false (in-comment-p (current-syntax) 17)) (is-true (in-comment-p (current-syntax) 18)) (is-false (in-comment-p (current-syntax) 40)) (is-false (in-comment-p (current-syntax) 41)) (is-true (in-comment-p (current-syntax) 50)) (is-true (in-comment-p (current-syntax) 60)) (is-false (in-comment-p (current-syntax) 68)) (is-false (in-comment-p (current-syntax) 69)))) (test in-character-p "Test the `in-character-p' function of Lisp syntax." (testing-lisp-syntax ("#\\C #\\( #\\# #\\ hello") (is-false (in-character-p (current-syntax) 0)) (is-false (in-character-p (current-syntax) 1)) (is-true (in-character-p (current-syntax) 2)) (is-false (in-character-p (current-syntax) 4)) (is-false (in-character-p (current-syntax) 5)) (is-true (in-character-p (current-syntax) 6)) (is-true (in-character-p (current-syntax) 10)) (is-true (in-character-p (current-syntax) 14)) (is-false (in-character-p (current-syntax) 16)))) (test location-at-beginning-of-form-list "Test the `location-at-beginning-of-form' function for lists." (testing-lisp-syntax ("(a b c (d e f) g") (is-false (location-at-beginning-of-form (current-syntax) 0)) (is-true (location-at-beginning-of-form (current-syntax) 1)) (is-false (location-at-beginning-of-form (current-syntax) 2)) (is-false (location-at-beginning-of-form (current-syntax) 7)) (is-true (location-at-beginning-of-form (current-syntax) 8)))) (test location-at-end-of-form-list "Test the `location-at-end-of-form' function for lists." (testing-lisp-syntax ("(a b c (d e f) g)") (is-false (location-at-end-of-form (current-syntax) 0)) (is-false (location-at-end-of-form (current-syntax) 1)) (is-false (location-at-end-of-form (current-syntax) 12)) (is-true (location-at-end-of-form (current-syntax) 13)) (is-false (location-at-end-of-form (current-syntax) 14)) (is-true (location-at-end-of-form (current-syntax) 16)))) (test location-at-beginning-of-form-string "Test the `location-at-beginning-of-form' function for strings." (testing-lisp-syntax ("\"a b c \"d e f\" g") (is-false (location-at-beginning-of-form (current-syntax) 0)) (is-true (location-at-beginning-of-form (current-syntax) 1)) (is-false (location-at-beginning-of-form (current-syntax) 2)) (is-false (location-at-beginning-of-form (current-syntax) 7)) (is-false (location-at-beginning-of-form (current-syntax) 8)) (is-true (location-at-beginning-of-form (current-syntax) 14)) (is-false (location-at-beginning-of-form (current-syntax) 15)))) (test location-at-end-of-form-string "Test the `location-at-end-of-form' function for strings." (testing-lisp-syntax ("\"a b c \"d e f\" g)\"") (is-false (location-at-end-of-form (current-syntax) 0)) (is-false (location-at-end-of-form (current-syntax) 1)) (is-false (location-at-end-of-form (current-syntax) 6)) (is-true (location-at-end-of-form (current-syntax) 7)) (is-false (location-at-end-of-form (current-syntax) 8)) (is-false (location-at-end-of-form (current-syntax) 16)) (is-true (location-at-end-of-form (current-syntax) 17)) (is-false (location-at-end-of-form (current-syntax) 18)))) (test location-at-beginning-of-form-simple-vector "Test the `location-at-beginning-of-form' function for simple vectors." (testing-lisp-syntax ("#(a b c #(d e f) g") (is-false (location-at-beginning-of-form (current-syntax) 0)) (is-false (location-at-beginning-of-form (current-syntax) 1)) (is-true (location-at-beginning-of-form (current-syntax) 2)) (is-false (location-at-beginning-of-form (current-syntax) 3)) (is-false (location-at-beginning-of-form (current-syntax) 9)) (is-true (location-at-beginning-of-form (current-syntax) 10)))) (test location-at-end-of-form-simple-vector "Test the `location-at-end-of-form' function for simple-vectors." (testing-lisp-syntax ("#(a b c #(d e f) g)") (is-false (location-at-end-of-form (current-syntax) 0)) (is-false (location-at-end-of-form (current-syntax) 1)) (is-false (location-at-end-of-form (current-syntax) 2)) (is-false (location-at-end-of-form (current-syntax) 14)) (is-true (location-at-end-of-form (current-syntax) 15)) (is-false (location-at-end-of-form (current-syntax) 16)) (is-true (location-at-end-of-form (current-syntax) 18)))) ;; For some tests, we need various functions, classes and ;; macros. Define them here and pray we don't clobber anything ;; important. (defun lisp-syntax-f1 ()) (defun lisp-syntax-f2 (l) (declare (ignore l))) (defun lisp-syntax-f3 (a b c &optional (l 1)) (declare (ignore a b c l))) (defmacro lisp-syntax-m1 ((var &optional string &key (element-type ''character)) &body forms-decls) ; with-output-to-string (declare (ignore var string element-type forms-decls))) (defmacro lisp-syntax-m2 (&key ((:a (a b c &key d)))) (declare (ignore a b c d))) (defclass lisp-syntax-c1 () ((foo :initarg :foo) (bar :initarg bar))) (defclass lisp-syntax-c2 (lisp-syntax-c1) ((baz :initarg :foo))) (test parse-lambda-list-1 "Test that `parse-lambda-list' can correctly parse ordinary and macro lambda lists with no parameters." (let ((oll (parse-lambda-list '())) (mll (parse-lambda-list '() 'macro-lambda-list))) (is-true (typep oll 'ordinary-lambda-list)) (is-true (null (required-parameters oll))) (is-true (null (optional-parameters oll))) (is-true (null (keyword-parameters oll))) (is-true (null (rest-parameter oll))) (is-true (typep mll 'macro-lambda-list)) (is-true (null (required-parameters mll))) (is-true (null (optional-parameters mll))) (is-true (null (keyword-parameters mll))) (is-true (null (rest-parameter mll))) (is-true (null (body-parameter mll))))) (test parse-lambda-list-2 "Test that `parse-lambda-list' can correctly parse ordinary and macro lambda lists with only required parameters." (let ((oll1 (parse-lambda-list '(list))) (oll2 (parse-lambda-list '(list find))) (mll1 (parse-lambda-list '(list) 'macro-lambda-list)) (mll2 (parse-lambda-list '(list find) 'macro-lambda-list))) (is-true (typep oll1 'ordinary-lambda-list)) (is (= 1 (length (required-parameters oll1)))) (is (string= 'list (name (first (required-parameters oll1))))) (is (= 0 (min-arg-index (first (required-parameters oll1))))) (is-true (null (optional-parameters oll1))) (is-true (null (keyword-parameters oll1))) (is-true (null (rest-parameter oll1))) (is-true (typep oll2 'ordinary-lambda-list)) (is (= 2 (length (required-parameters oll2)))) (is (string= 'list (name (first (required-parameters oll2))))) (is (= 0 (min-arg-index (first (required-parameters oll2))))) (is (string= 'find (name (second (required-parameters oll2))))) (is (= 1 (min-arg-index (second (required-parameters oll2))))) (is-true (null (optional-parameters oll2))) (is-true (null (keyword-parameters oll2))) (is-true (null (rest-parameter oll2))) (is-true (typep mll1 'macro-lambda-list)) (is (= 1 (length (required-parameters mll1)))) (is (string= (name (first (required-parameters mll1))) 'list)) (is (= 0 (min-arg-index (first (required-parameters mll1))))) (is-true (null (optional-parameters mll1))) (is-true (null (keyword-parameters mll1))) (is-true (null (rest-parameter mll1))) (is-true (null (body-parameter mll1))) (is-true (typep mll2 'macro-lambda-list)) (is (= 2 (length (required-parameters mll2)))) (is (string= (name (first (required-parameters mll2))) 'list)) (is (= 0 (min-arg-index (first (required-parameters mll2))))) (is (string= (name (second (required-parameters mll2))) 'find)) (is (= 1 (min-arg-index (second (required-parameters mll2))))) (is-true (null (optional-parameters mll2))) (is-true (null (keyword-parameters mll2))) (is-true (null (rest-parameter mll2))) (is-true (null (body-parameter mll2))))) (test parse-lambda-list-2a "Test that `parse-lambda-list' can correctly parse various destructuring required parameters for macro lambda lists." (let ((mll1 (parse-lambda-list '((list)))) (mll2 (parse-lambda-list '((list find))))) (is-true (typep mll1 'macro-lambda-list)) (is (= (min-arg-index (first (required-parameters mll1))))) (is (= 1 (length (required-parameters (inner-lambda-list (first (required-parameters mll1))))))) (is (string= 'list (name (first (required-parameters (inner-lambda-list (first (required-parameters mll1)))))))) (let ((mll2-parameter (first (required-parameters mll2)))) (is-true (typep (inner-lambda-list mll2-parameter) 'destructuring-lambda-list)) (is (= 2 (length (required-parameters (inner-lambda-list mll2-parameter))))) (is (string= 'list (name (first (required-parameters (inner-lambda-list mll2-parameter)))))) (is (= 0 (min-arg-index (first (required-parameters (inner-lambda-list mll2-parameter)))))) (is (string= 'find (name (second (required-parameters (inner-lambda-list mll2-parameter)))))) (is (= 1 (min-arg-index (second (required-parameters (inner-lambda-list mll2-parameter)))))) (is-true (null (optional-parameters (inner-lambda-list mll2-parameter)))) (is-true (null (keyword-parameters (inner-lambda-list mll2-parameter)))) (is-true (null (rest-parameter (inner-lambda-list mll2-parameter))))))) (test parse-lambda-list-3 "Test that `parse-lambda-list' can correctly parse optional parameters in ordinary and macro lambda lists." (let ((oll1 (parse-lambda-list '(&optional (list 2)))) (oll2 (parse-lambda-list '(&optional (list nil) find))) (oll3 (parse-lambda-list '(reduce &optional list (find 2)))) (mll1 (parse-lambda-list '(&optional (list 2)) 'macro-lambda-list)) (mll2 (parse-lambda-list '(&optional (list nil) find) 'macro-lambda-list)) (mll3 (parse-lambda-list '(reduce &optional list (find 2)) 'macro-lambda-list))) (is-true (typep oll1 'ordinary-lambda-list)) (is (= 0 (length (required-parameters oll1)))) (is (= 1 (length (optional-parameters oll1)))) (is (= 0 (length (keyword-parameters oll1)))) (is-true (null (rest-parameter oll1))) (is (= 0 (min-arg-index (first (optional-parameters oll1))))) (is (string= 'list (name (first (optional-parameters oll1))))) (is (= 2 (init-form (first (optional-parameters oll1))))) (is-true (typep oll2 'ordinary-lambda-list)) (is (= 0 (length (required-parameters oll2)))) (is (= 2 (length (optional-parameters oll2)))) (is (= 0 (length (keyword-parameters oll2)))) (is-true (null (rest-parameter oll2))) (is (= 0 (min-arg-index (first (optional-parameters oll2))))) (is (string= 'list (name (first (optional-parameters oll2))))) (is-true (null (init-form (first (optional-parameters oll2))))) (is (= 1 (min-arg-index (second (optional-parameters oll2))))) (is (string= 'find (name (second (optional-parameters oll2))))) (is-true (null (init-form (second (optional-parameters oll2))))) (is-true (typep oll3 'ordinary-lambda-list)) (is (= 1 (length (required-parameters oll3)))) (is (= 2 (length (optional-parameters oll3)))) (is (= 0 (length (keyword-parameters oll3)))) (is-true (null (rest-parameter oll3))) (is (= 1 (min-arg-index (first (optional-parameters oll3))))) (is (string= 'list (name (first (optional-parameters oll3))))) (is-true (null (init-form (first (optional-parameters oll3))))) (is (= 2 (min-arg-index (second (optional-parameters oll3))))) (is (string= 'find (name (second (optional-parameters oll3))))) (is (= 2 (init-form (second (optional-parameters oll3))))) (is-true (typep mll1 'macro-lambda-list)) (is (= 0 (length (required-parameters mll1)))) (is (= 1 (length (optional-parameters mll1)))) (is (= 0 (length (keyword-parameters mll1)))) (is-true (null (rest-parameter mll1))) (is (= 0 (min-arg-index (first (optional-parameters mll1))))) (is (string= 'list (name (first (optional-parameters mll1))))) (is (= 2 (init-form (first (optional-parameters mll1))))) (is-true (typep mll2 'macro-lambda-list)) (is (= 0 (length (required-parameters mll2)))) (is (= 2 (length (optional-parameters mll2)))) (is (= 0 (length (keyword-parameters mll2)))) (is-true (null (rest-parameter mll2))) (is (= 0 (min-arg-index (first (optional-parameters mll2))))) (is (string= 'list (name (first (optional-parameters mll2))))) (is-true (null (init-form (first (optional-parameters mll2))))) (is (= 1 (min-arg-index (second (optional-parameters mll2))))) (is (string= 'find (name (second (optional-parameters mll2))))) (is-true (null (init-form (second (optional-parameters mll2))))) (is-true (typep mll3 'macro-lambda-list)) (is (= 1 (length (required-parameters mll3)))) (is (= 2 (length (optional-parameters mll3)))) (is (= 0 (length (keyword-parameters mll3)))) (is-true (null (rest-parameter mll3))) (is (= 1 (min-arg-index (first (optional-parameters mll3))))) (is (string= 'list (name (first (optional-parameters mll3))))) (is-true (null (init-form (first (optional-parameters mll3))))) (is (= 2 (min-arg-index (second (optional-parameters mll3))))) (is (string= 'find (name (second (optional-parameters mll3))))) (is (= 2 (init-form (second (optional-parameters mll3))))))) (test parse-lambda-list-3a "Test that `parse-lambda-list' can correctly parse destructuring optional parameters in macro lambda lists." (let ((mll1 (parse-lambda-list '(&optional ((list))))) (mll2 (parse-lambda-list '(&optional ((list) '(2))))) (mll3 (parse-lambda-list '(&optional ((list find))))) (mll4 (parse-lambda-list '(&optional ((list find) '(2 3)))))) (is-true (typep mll1 'macro-lambda-list)) (is-true (typep (first (optional-parameters mll1)) 'destructuring-optional-parameter)) (is (= 0 (min-arg-index (first (optional-parameters mll1))))) (is (= 0 (min-arg-index (first (required-parameters (inner-lambda-list (first (optional-parameters mll1)))))))) (is-true (typep mll2 'macro-lambda-list)) (is-true (typep (first (optional-parameters mll2)) 'destructuring-optional-parameter)) (is (= 0 (min-arg-index (first (optional-parameters mll2))))) (is (= 0 (min-arg-index (first (required-parameters (inner-lambda-list (first (optional-parameters mll2)))))))) (is (equal ''(2) (init-form (first (optional-parameters mll2))))) (is-true (typep mll3 'macro-lambda-list)) (is-true (typep (first (optional-parameters mll3)) 'destructuring-optional-parameter)) (is (= 0 (min-arg-index (first (optional-parameters mll3))))) (is (= 0 (min-arg-index (first (required-parameters (inner-lambda-list (first (optional-parameters mll3)))))))) (is (= 1 (min-arg-index (second (required-parameters (inner-lambda-list (first (optional-parameters mll3)))))))) (is-true (typep mll4 'macro-lambda-list)) (is-true (typep (first (optional-parameters mll4)) 'destructuring-optional-parameter)) (is (= 0 (min-arg-index (first (optional-parameters mll4))))) (is (= 0 (min-arg-index (first (required-parameters (inner-lambda-list (first (optional-parameters mll4)))))))) (is (= 1 (min-arg-index (second (required-parameters (inner-lambda-list (first (optional-parameters mll4)))))))) (is (equal ''(2 3) (init-form (first (optional-parameters mll4))))))) (test parse-lambda-list-4 "Test that `parse-lambda-list' can correctly parse keyword parameters in ordinary and macro lambda lists." (let ((oll1 (parse-lambda-list '(&key (list 2)))) (oll2 (parse-lambda-list '(&key (list nil) find))) (oll3 (parse-lambda-list '(reduce &key list (find 2)))) (oll4 (parse-lambda-list '(&key ((:fooarg list) 2)))) (mll1 (parse-lambda-list '(&key (list 2)) 'macro-lambda-list)) (mll2 (parse-lambda-list '(&key (list nil) find) 'macro-lambda-list)) (mll3 (parse-lambda-list '(reduce &key list (find 2)) 'macro-lambda-list)) (mll4 (parse-lambda-list '(&key ((:fooarg list) 2)) 'macro-lambda-list))) (is-true (typep oll1 'ordinary-lambda-list)) (is (= 0 (length (required-parameters oll1)))) (is (= 0 (length (optional-parameters oll1)))) (is (= 1 (length (keyword-parameters oll1)))) (is-true (null (rest-parameter oll1))) (is (= 0 (min-arg-index (first (keyword-parameters oll1))))) (is (string= :list (keyword-name (first (keyword-parameters oll1))))) (is (= 2 (init-form (first (keyword-parameters oll1))))) (is-true (typep oll2 'ordinary-lambda-list)) (is (= 0 (length (required-parameters oll2)))) (is (= 0 (length (optional-parameters oll2)))) (is (= 2 (length (keyword-parameters oll2)))) (is-true (null (rest-parameter oll2))) (is (= 0 (min-arg-index (first (keyword-parameters oll2))))) (is (string= :list (keyword-name (first (keyword-parameters oll2))))) (is-true (null (init-form (first (keyword-parameters oll2))))) (is (= 0 (min-arg-index (second (keyword-parameters oll2))))) (is (string= :find (keyword-name (second (keyword-parameters oll2))))) (is-true (null (init-form (second (keyword-parameters oll2))))) (is-true (typep oll3 'ordinary-lambda-list)) (is (= 1 (length (required-parameters oll3)))) (is (= 0 (length (optional-parameters oll3)))) (is (= 2 (length (keyword-parameters oll3)))) (is-true (null (rest-parameter oll3))) (is (= 1 (min-arg-index (first (keyword-parameters oll3))))) (is (string= :list (keyword-name (first (keyword-parameters oll3))))) (is-true (null (init-form (first (keyword-parameters oll3))))) (is (= 1 (min-arg-index (second (keyword-parameters oll3))))) (is (string= :find (keyword-name (second (keyword-parameters oll3))))) (is (= 2 (init-form (second (keyword-parameters oll3))))) (is-true (typep oll4 'ordinary-lambda-list)) (is (= 0 (length (required-parameters oll4)))) (is (= 0 (length (optional-parameters oll4)))) (is (= 1 (length (keyword-parameters oll4)))) (is-true (null (rest-parameter oll4))) (is (= 0 (min-arg-index (first (keyword-parameters oll4))))) (is (string= :fooarg (keyword-name (first (keyword-parameters oll4))))) (is (= 2 (init-form (first (keyword-parameters oll4))))) (is-true (typep mll1 'macro-lambda-list)) (is (= 0 (length (required-parameters mll1)))) (is (= 0 (length (optional-parameters mll1)))) (is (= 1 (length (keyword-parameters mll1)))) (is-true (null (rest-parameter mll1))) (is (= 0 (min-arg-index (first (keyword-parameters mll1))))) (is (string= :list (keyword-name (first (keyword-parameters mll1))))) (is (= 2 (init-form (first (keyword-parameters mll1))))) (is-true (typep mll2 'macro-lambda-list)) (is (= 0 (length (required-parameters mll2)))) (is (= 0 (length (optional-parameters mll2)))) (is (= 2 (length (keyword-parameters mll2)))) (is-true (null (rest-parameter mll2))) (is (= 0 (min-arg-index (first (keyword-parameters mll2))))) (is (string= :list (keyword-name (first (keyword-parameters mll2))))) (is-true (null (init-form (first (keyword-parameters mll2))))) (is (= 0 (min-arg-index (second (keyword-parameters mll2))))) (is (string= :find (keyword-name (second (keyword-parameters mll2))))) (is-true (null (init-form (second (keyword-parameters mll2))))) (is-true (typep mll3 'macro-lambda-list)) (is (= 1 (length (required-parameters mll3)))) (is (= 0 (length (optional-parameters mll3)))) (is (= 2 (length (keyword-parameters mll3)))) (is-true (null (rest-parameter mll3))) (is (= 1 (min-arg-index (first (keyword-parameters mll3))))) (is (string= :list (keyword-name (first (keyword-parameters mll3))))) (is-true (null (init-form (first (keyword-parameters mll3))))) (is (= 1 (min-arg-index (second (keyword-parameters mll3))))) (is (string= :find (keyword-name (second (keyword-parameters mll3))))) (is (= 2 (init-form (second (keyword-parameters mll3))))) (is-true (typep mll4 'macro-lambda-list)) (is (= 0 (length (required-parameters mll4)))) (is (= 0 (length (optional-parameters mll4)))) (is (= 1 (length (keyword-parameters mll4)))) (is-true (null (rest-parameter mll4))) (is (= 0 (min-arg-index (first (keyword-parameters mll4))))) (is (string= :fooarg (keyword-name (first (keyword-parameters mll4))))) (is (= 2 (init-form (first (keyword-parameters mll4))))))) (test parse-lambda-list-4a "Test that `parse-lambda-list' can correctly parse destructuring keyword parameters in macro lambda lists." (let ((mll1 (parse-lambda-list '(&key ((:list (list)))))) (mll2 (parse-lambda-list '(&key ((:list (list)) '(2))))) (mll3 (parse-lambda-list '(&key ((:list (list find)))))) (mll4 (parse-lambda-list '(&key ((:list (list find)) '(2 3)))))) (is-true (typep mll1 'macro-lambda-list)) (is-true (typep (first (keyword-parameters mll1)) 'destructuring-keyword-parameter)) (is (= 0 (min-arg-index (first (keyword-parameters mll1))))) (is (= 0 (min-arg-index (first (required-parameters (inner-lambda-list (first (keyword-parameters mll1)))))))) (is (equal :list (keyword-name (first (keyword-parameters mll1))))) (is-true (null (init-form (first (keyword-parameters mll1))))) (is-true (typep mll2 'macro-lambda-list)) (is-true (typep (first (keyword-parameters mll2)) 'destructuring-keyword-parameter)) (is (= 0 (min-arg-index (first (keyword-parameters mll2))))) (is (= 0 (min-arg-index (first (required-parameters (inner-lambda-list (first (keyword-parameters mll2)))))))) (is (equal :list (keyword-name (first (keyword-parameters mll2))))) (is (equal ''(2) (init-form (first (keyword-parameters mll2))))) (is-true (typep mll3 'macro-lambda-list)) (is-true (typep (first (keyword-parameters mll3)) 'destructuring-keyword-parameter)) (is (= 0 (min-arg-index (first (keyword-parameters mll3))))) (is (= 0 (min-arg-index (first (required-parameters (inner-lambda-list (first (keyword-parameters mll3)))))))) (is (= 1 (min-arg-index (second (required-parameters (inner-lambda-list (first (keyword-parameters mll3)))))))) (is (equal :list (keyword-name (first (keyword-parameters mll3))))) (is-true (null (init-form (first (keyword-parameters mll3))))) (is-true (typep mll4 'macro-lambda-list)) (is-true (typep (first (keyword-parameters mll4)) 'destructuring-keyword-parameter)) (is (= 0 (min-arg-index (first (keyword-parameters mll4))))) (is (= 0 (min-arg-index (first (required-parameters (inner-lambda-list (first (keyword-parameters mll4)))))))) (is (= 1 (min-arg-index (second (required-parameters (inner-lambda-list (first (keyword-parameters mll4)))))))) (is (equal :list (keyword-name (first (keyword-parameters mll4))))) (is (equal ''(2 3) (init-form (first (keyword-parameters mll4))))))) (defmacro make-parameter-maker (parameter-type) (let ((fname (intern (format nil "MAKE-~A-PARAMETERS" parameter-type) #.*package*)) (makename (find-symbol (format nil "MAKE-~A-PARAMETER" parameter-type) :drei-lisp-syntax))) `(defun ,fname (parameters) (mapcar #'(lambda (p) (,makename p 0)) parameters)))) (make-parameter-maker required) (make-parameter-maker &optional) (make-parameter-maker &key) (test make-lambda-list-1 "Test that the `make-lambda-list' function works correctly for lambda lists with only required parameters." (let* ((lambda-list-1 (make-lambda-list :required-parameters (make-required-parameters '(a b c))))) (is (equal 0 (min-arg-index (first (required-parameters lambda-list-1))))) (is (equal 1 (min-arg-index (second (required-parameters lambda-list-1))))) (is (equal 2 (min-arg-index (third (required-parameters lambda-list-1))))) (is-true (typep lambda-list-1 'ordinary-lambda-list)))) (test make-lambda-list-2 "Test that the `make-lambda-list' function works correctly for lambda lists with required parameters that have optional parameters added." (let* ((lambda-list-1 (make-lambda-list :required-parameters (make-required-parameters '(a b c)))) (lambda-list-2 (make-lambda-list :optional-parameters (make-&optional-parameters '(a b c)))) (lambda-list-3 (make-lambda-list :defaults lambda-list-1 :optional-parameters (make-&optional-parameters '(d e f))))) (is (equal 0 (min-arg-index (first (required-parameters lambda-list-1))))) (is (equal 1 (min-arg-index (second (required-parameters lambda-list-1))))) (is (equal 2 (min-arg-index (third (required-parameters lambda-list-1))))) (is-true (typep lambda-list-1 'ordinary-lambda-list)) (is (equal 0 (min-arg-index (first (optional-parameters lambda-list-2))))) (is (equal 1 (min-arg-index (second (optional-parameters lambda-list-2))))) (is (equal 2 (min-arg-index (third (optional-parameters lambda-list-2))))) (is-true (typep lambda-list-2 'ordinary-lambda-list)) (is (equal 3 (min-arg-index (first (optional-parameters lambda-list-3))))) (is (equal 4 (min-arg-index (second (optional-parameters lambda-list-3))))) (is (equal 5 (min-arg-index (third (optional-parameters lambda-list-3))))) (is-true (typep lambda-list-3 'ordinary-lambda-list)))) (test make-lambda-list-3 "Test that the `make-lambda-list' function works correctly for lambda lists with or without required or optional parameters that have keyword parameters added." (let* ((lambda-list-1 (make-lambda-list :required-parameters (make-required-parameters '(a b c)))) (lambda-list-2 (make-lambda-list :defaults lambda-list-1 :optional-parameters (make-&optional-parameters '(d e f)))) (lambda-list-3 (make-lambda-list :defaults lambda-list-2 :required-parameters nil :keyword-parameters (make-&key-parameters '(d e f)))) (lambda-list-4 (make-lambda-list :defaults lambda-list-1 :keyword-parameters (make-&key-parameters '(d e f)))) (lambda-list-5 (make-lambda-list :keyword-parameters (make-&key-parameters '(a b c))))) (is (equal 0 (min-arg-index (first (keyword-parameters lambda-list-5))))) (is (equal 0 (min-arg-index (second (keyword-parameters lambda-list-5))))) (is (equal 0 (min-arg-index (third (keyword-parameters lambda-list-5))))) (is-true (typep lambda-list-5 'ordinary-lambda-list)) (is (equal 0 (min-arg-index (first (optional-parameters lambda-list-3))))) (is (equal 1 (min-arg-index (second (optional-parameters lambda-list-3))))) (is (equal 2 (min-arg-index (third (optional-parameters lambda-list-3))))) (is (equal 3 (min-arg-index (first (keyword-parameters lambda-list-3))))) (is (equal 3 (min-arg-index (second (keyword-parameters lambda-list-3))))) (is (equal 3 (min-arg-index (third (keyword-parameters lambda-list-3))))) (is-true (typep lambda-list-3 'ordinary-lambda-list)) (is (equal 0 (min-arg-index (first (required-parameters lambda-list-4))))) (is (equal 1 (min-arg-index (second (required-parameters lambda-list-4))))) (is (equal 2 (min-arg-index (third (required-parameters lambda-list-4))))) (is (equal 3 (min-arg-index (first (keyword-parameters lambda-list-4))))) (is (equal 3 (min-arg-index (second (keyword-parameters lambda-list-4))))) (is (equal 3 (min-arg-index (third (keyword-parameters lambda-list-4))))) (is-true (typep lambda-list-4 'ordinary-lambda-list)))) (test make-lambda-list-4 "Test that the `make-lambda-list' function works correctly for lambda lists with or without required, optional or keyword parameters that have a rest parameter added. Also tests that the lambda lists are of the proper type." (let* ((lambda-list-1 (make-lambda-list)) (lambda-list-2 (make-lambda-list :required-parameters (make-required-parameters '(a b c)))) (lambda-list-3 (make-lambda-list :required-parameters (make-required-parameters '(a b c)) :optional-parameters (make-&optional-parameters '(d e f)))) (lambda-list-4 (make-lambda-list :optional-parameters (make-&optional-parameters '(a b c)))) (lambda-list-5 (make-lambda-list :required-parameters (make-required-parameters '(a b c)) :optional-parameters (make-&optional-parameters '(d e f)) :keyword-parameters (make-&key-parameters '(g h i)))) (lambda-list-6 (make-lambda-list :required-parameters (make-required-parameters '(a b c)) :keyword-parameters (make-&key-parameters '(d e f)))) (lambda-list-7 (make-lambda-list :keyword-parameters (make-&key-parameters '(a b c))))) (flet ((&restify-lambda-list (lambda-list) (make-lambda-list :defaults lambda-list :rest-parameter (make-&rest-parameter 'a 0)))) (is (= 0 (min-arg-index (rest-parameter (&restify-lambda-list lambda-list-1))))) (is-true (typep lambda-list-1 'ordinary-lambda-list)) (is (= 3 (min-arg-index (rest-parameter (&restify-lambda-list lambda-list-2))))) (is-true (typep lambda-list-2 'ordinary-lambda-list)) (is (= 6 (min-arg-index (rest-parameter (&restify-lambda-list lambda-list-3))))) (is-true (typep lambda-list-3 'ordinary-lambda-list)) (is (= 3 (min-arg-index (rest-parameter (&restify-lambda-list lambda-list-4))))) (is-true (typep lambda-list-4 'ordinary-lambda-list)) (is (= 6 (min-arg-index (rest-parameter (&restify-lambda-list lambda-list-5))))) (is-true (typep lambda-list-5 'ordinary-lambda-list)) (is (= 3 (min-arg-index (rest-parameter (&restify-lambda-list lambda-list-6))))) (is-true (typep lambda-list-6 'ordinary-lambda-list)) (is (= 0 (min-arg-index (rest-parameter (&restify-lambda-list lambda-list-7))))) (is-true (typep lambda-list-7 'ordinary-lambda-list))))) (test make-lambda-list-5 "Test that the `make-lambda-list' function correctly creates macro lambda lists when destructuring (or body) parameters are used for lambda list construction." (let* ((lambda-list-1 (parse-lambda-list nil 'macro-lambda-list)) (lambda-list-2 (make-lambda-list :required-parameters (make-required-parameters '(a (b) c)))) (lambda-list-3 (make-lambda-list :defaults (make-lambda-list :required-parameters (make-required-parameters '(a b c))) :optional-parameters (make-&optional-parameters '(((d)) e f)))) (lambda-list-4 (make-lambda-list :optional-parameters (make-&optional-parameters '(((d)) b c)))) (lambda-list-5 (make-lambda-list :defaults (make-lambda-list :required-parameters (make-required-parameters '(a b c)) :optional-parameters (make-&optional-parameters '(d e f))) :keyword-parameters (make-&key-parameters '(((:g (g))) h i)))) (lambda-list-6 (make-lambda-list :defaults (make-lambda-list :required-parameters (make-required-parameters '(a b c))) :keyword-parameters (make-&key-parameters '(((:d (d))) e f)))) (lambda-list-7 (make-lambda-list :keyword-parameters (make-&key-parameters '(((:a (a))) b c))))) (is-true (typep lambda-list-1 'macro-lambda-list)) (is-true (typep lambda-list-2 'macro-lambda-list)) (is-true (typep lambda-list-3 'macro-lambda-list)) (is-true (typep lambda-list-4 'macro-lambda-list)) (is-true (typep lambda-list-5 'macro-lambda-list)) (is-true (typep lambda-list-6 'macro-lambda-list)) (is-true (typep lambda-list-7 'macro-lambda-list)))) (defmacro arglist-test (name &body body) `(swine-test ,name (flet ((arglist-of (symbol) (drei-lisp-syntax::lambda-list-as-list (drei-lisp-syntax::arglist-for-form (current-syntax) symbol)))) ,@body))) (arglist-test arglist-for-form-1 "Test that we can extract basic information about the arglists of functions and macros." (testing-lisp-syntax ("") (is (equal '() (arglist-of 'lisp-syntax-f1))) (is (equal '(l) (arglist-of 'lisp-syntax-f2))) (is (equal '(a b c &optional (l 1)) (arglist-of 'lisp-syntax-f3))) (is (equal '((var &optional string &key (:element-type ''character)) &body forms-decls) (arglist-of 'lisp-syntax-m1))))) (arglist-test arglist-for-form-2 "Test that we can extract basic information about the arglists of lambda expressions." (testing-lisp-syntax ("") (is (equal '() (arglist-of '(lambda ())))) (is (equal '(l) (arglist-of '(lambda (l))))) (is (equal '(a b c &optional (l 1)) (arglist-of '(lambda (a b c &optional (l 1)))))))) ;; Testing indentation consists of providing a string containing ;; properly indented code. When the test is run, all leading ;; whitespace will be removed from each line, and the entire buffer ;; will subsequently be reindented and compared with the original ;; string. Fast and easy. (defmacro indentation-test (name &body body) `(swine-test ,name (macrolet ((test-indentation (string) `(testing-lisp-syntax (,string) (let ((start (clone-mark (point))) (end (clone-mark (point)))) (beginning-of-buffer start) (end-of-buffer end) (do-buffer-region-lines (line start end) (delete-indentation (current-syntax) line)) (indent-region (current-view) start end) (buffer-is ,string))))) (macrolet ((test-indentations (&rest strings) `(progn ,@(loop for string in strings collecting (macroexpand `(test-indentation ,string)))))) ,@body)))) (indentation-test indent-form-1 "Test indentation of relatively simple and complete list forms." (test-indentations " (defun list (&rest elements) (append elements nil))" " (list 1 2 3)" " (list 1 2 3)" " (list ;foo! 1 2 3)" " (list 1 2 3)" " (list 1 2 3 )" " ((list 1 2 3))")) (indentation-test indent-form-2 "Test the indentation of simple vector forms." (test-indentations " #(1 2 3)" " #(1 2 3)" " #(1 2 3 )")) (indentation-test indent-form-3 "Test the indentation of quoted forms." (test-indentations " '()" " '( a)" " '(list 1 2 3)" " '(list ;foo! 1 2 3)" " '(list 1 2 3)" " '(list 1 2 3 )" " '(f l)")) (indentation-test indent-form-4 "Test the indentation of backquoted forms." (test-indentations " `()" " `( ,a)" " `(list 1 2 3)" " `(list ;foo! 1 2 3)" " `(list 1 2 3)" " `(list 1 2 3 )" " `(f ,l)" ;; Okay, I'm bored, just slap an evil (pseudo) macro definition in ;; and test it... " (defmacro testing-lisp-predicate ((predicate) &body body) `((trues (&rest strings) `(progn ,@(mapcar #'(lambda (string) `(f ,(list ',predicate `(get-form-from-string ,string)))) strings))) (falses (&rest strings) `(progn ,@(mapcar #'(lambda (string) `(l ,(list ',predicate `(get-form-from-string ,string)))) strings)))) (progn ,@body))")) (indentation-test indent-form-5 "Test the indentation of string forms." (test-indentations " \" \" " " \"foobar! Foo Foo\" ")) (indentation-test indent-form-progn "Test the indentation rules for the `progn' special form." (test-indentations " (progn a b c)" " (progn a b c)" " (progn a b c)" " (progn a b c)" " (progn a b c)" " (progn a b (list 1 2 3))" " ( progn)")) (indentation-test indent-form-prog1 "Test the indentation rules for the `prog1' special form." (test-indentations " (prog1 a b c)" " (prog1 a b c)" " (prog1 a)")) (indentation-test indent-form-prog2 "Test the indentation rules for the `prog2' special form." (test-indentations " (prog2 a b c)" " (prog2 a b c)" " (prog2 a )")) (indentation-test indent-form-let "Test the indentation rules for the `let' special form." (test-indentations " (let ((a b) (c d)) contents)" " (let ((a b) (c d)) contents2)" " (let ((a b) (c d)) contents contents2)" " (let ((a b) (c d)) contents contents2)" " (let ((a (foo bar baz))) contents2) ")) (indentation-test indent-form-let* "Test the indentation rules for the `let*' special form." (test-indentations " (let* ((a b) (c d)) contents)" " (let* ((a b) (c d)) contents2)" " (let* ((a b) (c d)) contents contents2)" " (let* ((a b) (c d)) contents contents2)" " (let* ((a (foo bar baz))) contents2) ")) (indentation-test indent-form-multiple-value-bind "Test the indentation rules for the `multiple-value-bind' special form." (test-indentations "(multiple-value-bind (a b) (foo bar) contents)" " (multiple-value-bind (a b) (foo bar) contents contents2)" " (multiple-value-bind (a b) (foo bar) contents)" " (multiple-value-bind (a b) (foo bar) contents contents2)" " (multiple-value-bind (a b) (foo bar) contents)" " (multiple-value-bind (a b) (foo bar) contents contents2)" " (multiple-value-bind (a b) (foo bar) contents contents2) " " ( multiple-value-bind) ")) (test lisp-syntax-comment-region "Test the implementation of the `comment-region' function for Lisp syntax." (testing-lisp-syntax ("foo bar baz ") (let ((begin (beginning-of-buffer (clone-mark (point)))) (end (end-of-buffer (clone-mark (point))))) (comment-region (current-syntax) begin end) (buffer-is ";;; foo bar ;;; ;;; baz "))) (testing-lisp-syntax ("") (let ((begin (beginning-of-buffer (clone-mark (point)))) (end (end-of-buffer (clone-mark (point))))) (comment-region (current-syntax) begin end) (buffer-is "")))) (defgeneric find-pathnames (module) (:documentation "Get a list of the pathnames of the files making up an ASDF module/system/component.")) (defmethod find-pathnames ((module asdf:module)) (mapcan #'find-pathnames (asdf:module-components module))) (defmethod find-pathnames ((module asdf:source-file)) (list (asdf:component-pathname module))) ;; Thank you Mr. Insane 3000! (defun slurp-file (pathname) (with-open-file (strm pathname) (let ((string (make-string (file-length strm)))) (read-sequence string strm) string))) (defparameter *running-self-compilation-test* nil "This variable is set to true while running the self-compilation test.") (test self-compilation-test ;; The big one. Prepare for pain and suffering. TODO: Recompile more ;; stuff. Once McCLIM has a test suite worthy of the name, recompile ;; that as well. (if *run-self-compilation-test* (let ((pathnames (find-pathnames (asdf:find-system :drei-mcclim)))) ;; Just start from one end and go through. (format t "Re-evaluating Drei code using the Lisp syntax parser~%") (dolist (pathname pathnames) (testing-lisp-syntax ((slurp-file pathname)) ;; Rebind because the `(current-syntax)' variable will be ;; clobbered during the test. (let ((syntax (current-syntax))) (mapcar #'(lambda (form) (when (drei-lisp-syntax::formp form) (eval (form-to-object syntax form :read t)))) (drei-lisp-syntax::children (slot-value syntax 'drei-lisp-syntax::stack-top)))))) ;; If we're really lucky, the Lisp system will now run Drei ;; interpreted, making this test close to a whole-night event. ;; Also, as fun as infinite recursion would be... disable this ;; test before running the suite. (let ((*run-self-compilation-test* nil) (*running-self-compilation-test* t)) (format *test-dribble* "~%Re-running Drei test suite with newly evaluated Drei definitions~%") (is-true (results-status (let ((fiveam:*test-dribble* (make-broadcast-stream))) (fiveam:run 'drei-tests)))))) (unless *running-self-compilation-test* (skip "Sensibly skipping self-compilation test. Set DREI-TESTS:*RUN-SELF-COMPILATION-TEST* to true if you don't want to skip it")))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/Tests/buffer-streams-tests.lisp0000640000175000017500000002536210741375213023751 0ustar pdmpdm;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (cl:in-package :drei-tests) (def-suite buffer-streams-tests :description "The test suite for buffer-streams related tests." :in drei-tests) (in-suite buffer-streams-tests) (defun whole-buffer-stream (buffer) (let ((mark1 (clone-mark (make-buffer-mark buffer))) (mark2 (clone-mark (make-buffer-mark buffer)))) (beginning-of-buffer mark1) (end-of-buffer mark2) (make-buffer-stream :buffer buffer :start-mark mark1 :end-mark mark2))) (defun delimited-buffer-stream (buffer start-offset end-offset) (let ((mark1 (clone-mark (make-buffer-mark buffer))) (mark2 (clone-mark (make-buffer-mark buffer)))) (setf (offset mark1) start-offset) (setf (offset mark2) end-offset) (make-buffer-stream :buffer buffer :start-mark mark1 :end-mark mark2))) (test stream-creation (with-drei-environment (:initial-contents "foo bar baz") (let ((stream (make-buffer-stream :buffer (current-buffer) :start-mark (clone-mark (point) :right) :end-mark (clone-mark (point) :left)))) (is (typep (start-mark stream) 'left-sticky-mark)) (is (typep (end-mark stream) 'right-sticky-mark))))) (test stream-read-char (with-drei-environment (:initial-contents "foo bar baz") (let ((stream (whole-buffer-stream (current-buffer)))) (is (char= (read-char stream) #\f)) (is (char= (read-char stream) #\o)) (is (char= (read-char stream) #\o)) (is (char= (read-char stream) #\Space)) (is (char= (read-char stream) #\b)) (is (char= (read-char stream) #\a)) (is (char= (read-char stream) #\r)) (is (char= (read-char stream) #\Space)) (is (char= (read-char stream) #\b)) (is (char= (read-char stream) #\a)) (is (char= (read-char stream) #\z)) (signals end-of-file (read-char stream)) (is (eq (read-char stream nil :eof) :eof))) (let ((stream (delimited-buffer-stream (current-buffer) 4 7))) (is (char= (read-char stream) #\b)) (is (char= (read-char stream) #\a)) (is (char= (read-char stream) #\r)) (signals end-of-file (read-char stream)) (is (eq (read-char stream nil :eof) :eof))))) (test stream-unread-char (with-drei-environment (:initial-contents "foo bar baz") (let ((stream (whole-buffer-stream (current-buffer)))) (is (char= (read-char stream) #\f)) (unread-char #\f stream) (is (char= (read-char stream) #\f))) (let ((stream (delimited-buffer-stream (current-buffer) 4 7))) (is (char= (read-char stream) #\b)) (unread-char #\b stream) (is (char= (read-char stream) #\b)) (is (char= (read-char stream) #\a)) (is (char= (read-char stream) #\r)) (signals end-of-file (read-char stream)) (is (eq (read-char stream nil :eof) :eof)) (unread-char #\r stream) (is (char= (read-char stream) #\r)) (signals end-of-file (read-char stream)) (is (eq (read-char stream nil :eof) :eof))))) ;; Effectively the same as `read-char' for us. (test stream-read-char-no-hang (with-drei-environment (:initial-contents "foo bar baz") (let ((stream (whole-buffer-stream (current-buffer)))) (is (char= (read-char-no-hang stream) #\f)) (is (char= (read-char-no-hang stream) #\o)) (is (char= (read-char-no-hang stream) #\o)) (is (char= (read-char-no-hang stream) #\Space)) (is (char= (read-char-no-hang stream) #\b)) (is (char= (read-char-no-hang stream) #\a)) (is (char= (read-char-no-hang stream) #\r)) (is (char= (read-char-no-hang stream) #\Space)) (is (char= (read-char-no-hang stream) #\b)) (is (char= (read-char-no-hang stream) #\a)) (is (char= (read-char-no-hang stream) #\z)) (signals end-of-file (read-char-no-hang stream)) (is (eq (read-char-no-hang stream nil :eof) :eof))) (let ((stream (delimited-buffer-stream (current-buffer) 4 7))) (is (char= (read-char-no-hang stream) #\b)) (is (char= (read-char-no-hang stream) #\a)) (is (char= (read-char-no-hang stream) #\r)) (signals end-of-file (read-char-no-hang stream)) (is (eq (read-char-no-hang stream nil :eof) :eof))))) (test stream-peek-char (with-drei-environment (:initial-contents "foo bar baz") (let ((stream (whole-buffer-stream (current-buffer)))) (is (char= (peek-char nil stream) #\f)) (read-char stream) (is (char= (peek-char nil stream) #\o)) (read-char stream) (is (char= (peek-char nil stream) #\o)) (read-char stream)) (let ((stream (delimited-buffer-stream (current-buffer) 3 6))) (is (char= (peek-char nil stream) #\Space))) (let ((stream (delimited-buffer-stream (current-buffer) 3 6))) (is (char= (peek-char t stream) #\b))) (let ((stream (delimited-buffer-stream (current-buffer) 3 7))) (is (char= (peek-char #\r stream) #\r))) (let ((stream (delimited-buffer-stream (current-buffer) 0 0))) (signals end-of-file (peek-char t stream)) (is (eq (peek-char t stream nil :eof) :eof))))) (test stream-listen (with-drei-environment (:initial-contents "foo bar baz") (let ((stream (whole-buffer-stream (current-buffer)))) (is-true (stream-listen stream)) (dotimes (i 11) (finishes (read-char stream))) (is-false (stream-listen stream)) (unread-char #\z stream) (is-true (stream-listen stream))) (let ((stream (delimited-buffer-stream (current-buffer) 3 6))) (is-true (stream-listen stream)) (dotimes (i 3) (finishes (read-char stream))) (is-false (stream-listen stream)) (unread-char #\r stream) (is-true (stream-listen stream))) (let ((stream (delimited-buffer-stream (current-buffer) 0 0))) (is-false (stream-listen stream))))) (test stream-read-line (with-drei-environment (:initial-contents "line 1 line 2 line 3") (let ((stream (whole-buffer-stream (current-buffer)))) (is (string= (read-line stream) "line 1")) (is (string= (read-line stream) "line 2")) (is (char= (read-char stream) #\l)) (is (string= (read-line stream) "ine 3")) (signals end-of-file (read-line stream)) (is (eq (read-line stream nil :eof) :eof))))) (test stream-write-char (with-drei-environment (:initial-contents "piece of text") (let ((stream (whole-buffer-stream (current-buffer)))) (is (char= (write-char #\a stream) #\a)) (buffer-is "apiece of text") (is (char= (read-char stream) #\p)) (is (string= (read-line stream) "iece of text")) (signals end-of-file (read-char stream)) (is (char= (write-char #\a stream) #\a)) (buffer-is "apiece of texta") (signals end-of-file (read-char stream))))) (test stream-line-column (with-drei-environment (:initial-contents "abcde") (let ((stream (whole-buffer-stream (current-buffer)))) (is (= (stream-line-column stream) 0)) (is (char= (read-char stream) #\a)) (is (= (stream-line-column stream) 1)) (is (char= (read-char stream) #\b)) (is (= (stream-line-column stream) 2)) (is (char= (read-char stream) #\c)) (is (= (stream-line-column stream) 3)) (is (char= (read-char stream) #\d)) (is (= (stream-line-column stream) 4)) (is (char= (write-char #\a stream) #\a)) (is (= (stream-line-column stream) 5)) (is (char= (read-char stream) #\e)) (signals end-of-file (read-char stream)) (is (= (stream-line-column stream) 6))))) (test stream-start-line-p (with-drei-environment (:initial-contents "foobar") (let ((stream (whole-buffer-stream (current-buffer)))) (is-true (stream-start-line-p stream)) (is (char= (read-char stream) #\f)) (is-false (stream-start-line-p stream)) (unread-char #\f stream) (is-true (stream-start-line-p stream))) (let ((stream (delimited-buffer-stream (current-buffer) 3 6))) (is-true (stream-start-line-p stream)) (is (char= (read-char stream) #\b)) (is-false (stream-start-line-p stream)) (unread-char #\b stream) (is-true (stream-start-line-p stream))))) (test stream-write-string (with-drei-environment (:initial-contents "contents") (let ((stream (whole-buffer-stream (current-buffer)))) (write-string "foobar" stream) (buffer-is "foobarcontents") (is-false (stream-start-line-p stream)) (write-string #.(format nil "~%") stream) (buffer-is #.(format nil "foobar~%contents")) (is-true (stream-start-line-p stream)) (is (char= (read-char stream) #\c))))) (test stream-terpri (with-drei-environment (:initial-contents "contents") (let ((stream (whole-buffer-stream (current-buffer)))) (is-true (stream-start-line-p stream)) (is (char= (read-char stream) #\c)) (is-false (stream-start-line-p stream)) (terpri stream) (is-true (stream-start-line-p stream)) (terpri stream) (is-true (stream-start-line-p stream)) (buffer-is #.(format nil "c~%~%ontents"))))) (test stream-fresh-line (with-drei-environment (:initial-contents "contents") (let ((stream (whole-buffer-stream (current-buffer)))) (is-true (stream-start-line-p stream)) (is (char= (read-char stream) #\c)) (is-false (stream-start-line-p stream)) (fresh-line stream) (is-true (stream-start-line-p stream)) (fresh-line stream) (is-true (stream-start-line-p stream)) (buffer-is #.(format nil "c~%ontents"))))) (test stream-advance-to-column (with-drei-environment (:initial-contents "") (let ((stream (whole-buffer-stream (current-buffer)))) (write-string "foobar" stream) (stream-advance-to-column stream 3) (buffer-is "foobar") (fresh-line stream) (stream-advance-to-column stream 3) (buffer-is #.(format nil "foobar~% "))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/Tests/buffer-tests.lisp0000644000175000017500000007575011345155772022316 0ustar pdmpdm;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; ;;; The test cases in this files test the functions of the buffer ;;; protocol and the implementations provided by Drei. The test cases ;;; are divided into two FiceAM suites - one for functionality ;;; regression testing and one for performance testing. (cl:in-package :drei-tests) (def-suite buffer-tests :description "The test suite for buffer-protocol related tests." :in drei-tests) (in-suite buffer-tests) (buffer-test buffer-make-instance "Test that the various types of buffers can be created, and that they are initialized properly." (let* ((buffer (make-instance %%buffer))) (signals motion-after-end (make-instance %%left-sticky-mark :buffer buffer :offset 1)) (handler-case (progn (make-instance %%right-sticky-mark :buffer buffer :offset 1) (fail)) (motion-after-end (c) (is (= (drei-buffer::condition-offset c) 1)))))) (buffer-test clone-mark "Test that marks really are cloned." (let* ((buffer (make-instance %%buffer)) (low (make-buffer-mark buffer)) (high (make-buffer-mark buffer)) (low2 (clone-mark low)) (high2 (clone-mark high)) (low3 (clone-mark high :left)) (high3 (clone-mark low :right))) ;; They must be of the same class... (is (class-of low) (class-of low2)) (is (class-of low2) (class-of low3)) (is (class-of high) (class-of high2)) (is (class-of high2) (class-of high3)) ;; And have the same offset. (is (= (offset low) (offset low2) (offset low3))) (is (= (offset high) (offset high2) (offset high3) 0)))) ;;; NOTE: the current implementation uses vectors wherever sequences ;;; are expected (and strings are vectors of characters) (buffer-test insert-buffer-object "Test that insertion of buffer objects happen in the right order, and that the buffer is updated appropriately." (let ((buffer (make-instance %%buffer))) (insert-buffer-object buffer 0 #\a) ;; The buffer should have increased in size to accomodate the ;; object. (is (= (size buffer) 1)) ;; The contents should be what we put in there. (is (string= (buffer-substring buffer 0 1) "a")) (insert-buffer-object buffer 0 #\b) (insert-buffer-object buffer 0 #\a) (is (= (size buffer) 3)) (is (equal (buffer-substring buffer 0 3) "aba")) ;; We should be able to insert an object in the middle of the ;; buffer. (insert-buffer-object buffer 2 #\b) (is (equal (buffer-contents buffer) "abba")) ;; Attempting to insert an object after buffer end should cause an ;; error. (handler-case (progn (insert-buffer-object buffer 5 #\a) (fail "Failed to signal during insertion of object after buffer end")) (offset-after-end (c) (is (= (condition-offset c) 5)))) ;; Attempting to insert an object before buffer start should cause ;; an error. (handler-case (progn (insert-buffer-object buffer -1 #\a) (fail "Failed to signal during insertion of object before buffer start")) (offset-before-beginning (c) (= (condition-offset c) -1))))) (buffer-test insert-buffer-sequence "Test that we are able to insert sequences, and that the buffer size and contents are updated appropriately." (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (is (= (size buffer) 7)) (is (string= (buffer-substring buffer 0 7) "climacs")) (insert-buffer-sequence buffer 0 "climacs") ;; Inserting a sequence in the middle should work. (insert-buffer-sequence buffer 3 "ClimacS") (is (= (size buffer) 21)) (is (string= (buffer-substring buffer 0 14) "cliClimacSmacs")) (insert-buffer-sequence buffer 0 "climacs") (insert-buffer-sequence buffer 0 "ClimacS") (is (= (size buffer) 35)) (is (string= (buffer-substring buffer 0 14) "ClimacSclimacs")) (handler-case (progn (insert-buffer-sequence buffer 37 "climacs") (fail "Failed to signal during insertion of sequence after buffer end")) (offset-after-end (c) (= (condition-offset c) 37))) (handler-case (progn (insert-buffer-sequence buffer -1 "climacs") (fail "Failed to signal during insertion of sequence before buffer start")) (offset-before-beginning (c) (is (= (condition-offset c) -1)))))) (buffer-test delete-buffer-range "Test whether deletion of multiple objects in the buffer works." (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (delete-buffer-range buffer 0 7) (is (= 0 (size buffer))) (insert-buffer-sequence buffer 0 "climacs") (delete-buffer-range buffer 0 3) (is (= 4 (size buffer))) (is (string= "macs" (buffer-substring buffer 0 4))) (insert-buffer-sequence buffer 0 "climacs") (delete-buffer-range buffer 3 4) (is (= 7 (size buffer))) (is (string= "cli" (buffer-substring buffer 0 3))) ;; Deleting 0 characters should work (and leave the buffer ;; untouched.) (insert-buffer-sequence buffer 0 "climacs") (delete-buffer-range buffer 3 0) (is (= 14 (size buffer))) (is (string= "climacs" (buffer-substring buffer 0 7))) (handler-case (progn (delete-buffer-range buffer -1 0) (fail "Failed to signal during deletion of range with negative offset")) (offset-before-beginning (c) (is (= -1 (condition-offset c))))) (handler-case (progn (delete-buffer-range buffer 12 3) (fail "Failed to signal during deletion of range that exceeded buffer end.")) (offset-after-end (c) (is (= 15 (condition-offset c))))))) (buffer-test insert-object (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((m (make-buffer-mark buffer 3 :left))) (insert-object m #\X) (is (= 8 (size buffer))) (is (= 3 (offset m))) (is (string= "cliXmacs" (buffer-substring buffer 0 8)))) (let ((m (make-buffer-mark buffer 2 :right))) (insert-object m #\X) (is (= 9 (size buffer))) (is (= 3 (offset m))) (is (string= "clXiXmacs" (buffer-substring buffer 0 9)))))) (buffer-test insert-sequence (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((m (make-buffer-mark buffer 3 :left)) (m2 (make-buffer-mark buffer 5 :left))) (insert-sequence m "ClimacS") (is (= (size buffer) 14)) (is (eq (buffer m) (buffer m2))) (is (= (offset m) 3)) (is (= (offset m2) 12)) (is (string= (buffer-substring buffer 0 14) "cliClimacSmacs")))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((m (make-buffer-mark buffer 3 :right)) (m2 (make-buffer-mark buffer 5 :right))) (insert-sequence m "ClimacS") (is (= (size buffer) 14)) (is (eq (buffer m) (buffer m2))) (is (= (offset m) 10)) (is (= (offset m2) 12)) (is (string= (buffer-substring buffer 0 14) "cliClimacSmacs"))))) (buffer-test delete-range (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((m (make-buffer-mark buffer 3 :left)) (m2 (make-buffer-mark buffer 5 :left))) (delete-range m 2) (is (= (size buffer) 5)) (is (eq (buffer m) (buffer m2))) (is (= (offset m) 3)) (is (= (offset m2) 3)) (is (string= (buffer-substring buffer 0 5) "clics")))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((m (make-buffer-mark buffer 3 :right)) (m2 (make-buffer-mark buffer 5 :right))) (delete-range m -2) (is (= (size buffer) 5)) (is (eq (buffer m) (buffer m2))) (is (= (offset m) 1)) (is (= (offset m2) 3)) (is (string= (buffer-substring buffer 0 5) "cmacs"))))) (buffer-test delete-region (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((m (make-buffer-mark buffer 3 :left)) (m2 (make-buffer-mark buffer 5 :left))) (delete-region m m2) (is (= 5 (size buffer))) (is (eq (buffer m) (buffer m2))) (is (= 3 (offset m))) (is (= 3 (offset m2))) (is (string= (buffer-substring buffer 0 5) "clics")))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((m (make-buffer-mark buffer 3 :right)) (m2 (make-buffer-mark buffer 5 :right))) (delete-region m m2) (is (= 5 (size buffer))) (is (eq (buffer m) (buffer m2))) (is (= 3 (offset m))) (is (= 3 (offset m2))) (is (string= (buffer-substring buffer 0 5) "clics")))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((m (make-buffer-mark buffer 3 :left)) (m2 (make-buffer-mark buffer 5 :left))) (delete-region m2 m) (is (= 5 (size buffer))) (is (eq (buffer m) (buffer m2))) (is (= 3 (offset m))) (is (= 3 (offset m2))) (is (string= (buffer-substring buffer 0 5) "clics")))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((m (make-buffer-mark buffer 3 :right)) (m2 (make-buffer-mark buffer 5 :right))) (delete-region m2 m) (is (= 5 (size buffer))) (is (eq (buffer m) (buffer m2))) (is (= 3 (offset m))) (is (= 3 (offset m2))) (is (string= (buffer-substring buffer 0 5) "clics")))) (signals error (let ((buffer (make-instance %%buffer)) (buffer2 (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (insert-buffer-sequence buffer2 0 "climacs") (let ((m (make-buffer-mark buffer 3 :right)) (m2 (make-buffer-mark buffer2 5 :right))) (delete-region m2 m)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((m (make-buffer-mark buffer 3 :left)) (m2 (make-buffer-mark buffer 5 :left))) (delete-region m 5) (delete-region 1 m2) (is (= 3 (size buffer))) (is (eq (buffer m) (buffer m2))) (is (= 1 (offset m))) (is (= 1 (offset m2))) (is (string= "ccs" (buffer-substring buffer 0 3)))))) (buffer-test number-of-lines (let ((buffer (make-instance %%buffer))) (is (= (number-of-lines buffer) 0)) (insert-buffer-sequence buffer 0 "climacs climacs ") (is (= (number-of-lines buffer) 2)))) (buffer-test mark-relations (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((m0 (make-buffer-mark buffer 0 :right)) (m1 (make-buffer-mark buffer 3 :left)) (m1a (make-buffer-mark buffer 3 :right)) (m2 (make-buffer-mark buffer 5 :right)) (m2a (make-buffer-mark buffer 5 :left)) (m3 (make-buffer-mark buffer 7 :left))) (is-true (mark< m0 m1)) (not (mark> m0 m1)) (not (mark>= m0 m1)) (is-true (mark< m0 m2)) (not (mark> m0 m2)) (not (mark>= m0 m2)) (is-true (mark< m0 m3)) (not (mark> m0 m3)) (not (mark>= m0 m3)) (is-true (mark< m1 m2)) (not (mark> m1 m2)) (not (mark>= m1 m2)) (is-true (mark< m1 m3)) (not (mark> m1 m3)) (not (mark>= m1 m3)) (is-true (mark< m2 m3)) (not (mark> m2 m3)) (not (mark>= m2 m3)) (is-true (mark<= m1 m1a)) (not (mark> m1 m1a)) (is-true (mark>= m1 m1a)) (not (mark< m1 m1a)) (is-true (mark> m3 m2)) (not (mark< m3 m2)) (not (mark<= m3 m2)) (is-true (mark> m3 m1)) (not (mark< m3 m1)) (not (mark<= m3 m1)) (is-true (mark> m3 m0)) (not (mark< m3 m0)) (not (mark<= m3 m0)) (is-true (mark> m2 m1)) (not (mark< m2 m1)) (not (mark<= m2 m1)) (is-true (mark> m2 m0)) (not (mark< m2 m0)) (not (mark<= m2 m0)) (is-true (mark>= m2 m2a)) (not (mark> m2 m2a)) (is-true (mark>= m2 m2a)) (not (mark< m2 m2a)) (is-true (mark= m1 m1a)) (is-true (mark= m2 m2a)) (is-true (beginning-of-buffer-p m0)) (not (beginning-of-buffer-p m3)) (is-true (end-of-buffer-p m3)) (not (end-of-buffer-p m0)) (is-true (beginning-of-line-p m0)) (not (beginning-of-line-p m3)) (is-true (end-of-line-p m3)) (not (end-of-line-p m0)) (is-true (every #'(lambda (m) (zerop (line-number m))) (list m0 m1 m1a m2 m2a m3)))))) (buffer-test setf-offset (handler-case (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (make-buffer-mark buffer -1 :left) (fail "Failed to signal when setting offset of mark to negative value")) (motion-before-beginning (c) (is (= (condition-offset c) -1)))) (handler-case (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (make-buffer-mark buffer 8 :left) (fail "Failed to signal when setting offset of mark to a value too large for the buffer")) (motion-after-end (c) (is (= (condition-offset c) 8))))) (buffer-test backward-object (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let* ((m1 (make-buffer-mark buffer 4 :left)) (m2 (clone-mark m1))) (backward-object m1 2) (is (string= (region-to-string m1 m2) "im")))) (handler-case (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let* ((m1 (make-buffer-mark buffer 2 :right)) (m2 (clone-mark m1))) (backward-object m1 3) (region-to-sequence m1 m2) (fail "Failed to signal when moving mark to before buffer start."))) (motion-before-beginning (c) (is (= (condition-offset c) -1))))) (buffer-test forward-object (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let* ((m1 (make-buffer-mark buffer 4 :left)) (m2 (clone-mark m1))) (forward-object m1 2) (is (string= (region-to-string m1 m2) "ac")))) (handler-case (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let* ((m1 (make-buffer-mark buffer 0 :right)) (m2 (clone-mark m1))) (setf (offset m1) 6 (offset m2) 6) (forward-object m1 3) (region-to-sequence m1 m2) (fail "Failed to signal when moving mark past end of buffer."))) (motion-after-end (c) (is (= (condition-offset c) 9))))) (buffer-test setf-buffer-object (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (setf (buffer-object buffer 0) #\C) (is (string= (buffer-contents buffer) "Climacs"))) (handler-case (let ((buffer (make-instance %%buffer))) (setf (buffer-object buffer 0) #\a) (fail "Failed to signal when setting buffer object at offset 0")) (offset-after-end (c) (is (= (condition-offset c) 0)))) (handler-case (let ((buffer (make-instance %%buffer))) (setf (buffer-object buffer -1) #\a) (fail "Failed to signal when setting buffer object at negative offset")) (offset-before-beginning (c) (is (= (condition-offset c) -1))))) (buffer-test mark< (signals error (let ((buffer (make-instance %%buffer)) (buffer2 (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (insert-buffer-sequence buffer2 0 "climacs") (let ((m1 (make-buffer-mark buffer)) (m2 (make-buffer-mark buffer2))) (mark< m1 m2))))) (buffer-test mark> (signals error (let ((buffer (make-instance %%buffer)) (buffer2 (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (insert-buffer-sequence buffer2 0 "climacs") (let ((m1 (make-buffer-mark buffer)) (m2 (make-buffer-mark buffer2))) (mark> m1 m2))))) (buffer-test mark<= (signals error (let ((buffer (make-instance %%buffer)) (buffer2 (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (insert-buffer-sequence buffer2 0 "climacs") (let ((m1 (make-buffer-mark buffer)) (m2 (make-buffer-mark buffer2))) (mark<= m1 m2))))) (buffer-test mark>= (signals error (let ((buffer (make-instance %%buffer)) (buffer2 (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (insert-buffer-sequence buffer2 0 "climacs") (let ((m1 (make-buffer-mark buffer)) (m2 (make-buffer-mark buffer2))) (mark>= m1 m2))))) (buffer-test mark= (signals error (let ((buffer (make-instance %%buffer)) (buffer2 (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (insert-buffer-sequence buffer2 0 "climacs") (let ((m1 (make-buffer-mark buffer)) (m2 (make-buffer-mark buffer2))) (mark= m1 m2))))) (buffer-test line-number (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") (let ((m1 (make-buffer-mark buffer 0 :left)) (m2 (make-buffer-mark buffer 0 :right))) (setf (offset m1) 3 (offset m2) 11) (is (= 0 (line-number m1) (1- (line-number m2))))))) (buffer-test buffer-column-number (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 #.(format nil "~A~Aclimacs" #\Tab #\Tab)) (is (char= (buffer-object buffer 2) #\c)) (is (= (buffer-column-number buffer 2) 2)))) (buffer-test buffer-column-number (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 #.(format nil "~%~A~Aclimacs" #\Tab #\Tab)) (is (char= (buffer-object buffer 3) #\c)) (is (= (buffer-column-number buffer 3) 2)))) (buffer-test column-number (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") (let ((m1 (make-buffer-mark buffer 0 :left)) (m2 (make-buffer-mark buffer 0 :right))) (setf (offset m1) 3 (offset m2) 11) (is (= 3 (column-number m1) (column-number m2)))))t) (buffer-test beginning-of-line (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") (let ((m (make-buffer-mark buffer 0 :left))) (setf (offset m) 11) (is-true (not (beginning-of-line-p m))) (beginning-of-line m) (is-true (beginning-of-line-p m))))) (buffer-test end-of-line (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") (let ((m (make-buffer-mark buffer 0 :left))) (setf (offset m) 11) (is-true (not (end-of-line-p m))) (end-of-line m) (is-true (end-of-line-p m)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs ") (let ((m (make-buffer-mark buffer 0 :left))) (setf (offset m) 1) (is-true (not (end-of-line-p m))) (end-of-line m) (is (= (offset m) 7)) (is-true (char= (buffer-object (buffer m) (offset m)) #\Newline))))) (buffer-test beginning-of-buffer (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") (let ((m (make-buffer-mark buffer 0 :left))) (setf (offset m) 11) (is-true (not (beginning-of-buffer-p m))) (beginning-of-buffer m) (is-true (beginning-of-buffer-p m))))) (buffer-test end-of-buffer (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") (let ((m (make-buffer-mark buffer 0 :left))) (setf (offset m) 11) (is-true (not (end-of-buffer-p m))) (end-of-buffer m) (is-true (end-of-buffer-p m))))) (buffer-test buffer-object (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (is (char= (buffer-object buffer 3) #\m))) (handler-case (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (buffer-object buffer -1) (fail "Failed to signal when requesting object with negative offset")) (no-such-offset (c) (is (= (condition-offset c) -1)))) (handler-case (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (buffer-object buffer 7) (fail "Failed to signal when requesting object past end of buffer")) (no-such-offset (c) (is (= (condition-offset c) 7))))) (buffer-test buffer-sequence (handler-case (let ((buffer (make-instance %%buffer))) (buffer-sequence buffer -1 0) (fail "Failed to signal when requesting buffer seuqnce with negative offset")) (no-such-offset (c) (is (= (condition-offset c) -1)))) (handler-case (let ((buffer (make-instance %%buffer))) (buffer-sequence buffer 0 1) (fail "Failed to signal when requesting buffer sequence too big for buffer")) (no-such-offset (c) (= (condition-offset c) 1))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (is (equalp (buffer-sequence buffer 5 3) #())))) (buffer-test object-before (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (is (char= (object-before (make-buffer-mark buffer 7)) #\s))) (handler-case (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (object-before (make-buffer-mark buffer)) (fail "Failed to signal when requesting object before buffer start")) (no-such-offset (c) (= (condition-offset c) -1)))) (buffer-test object-after (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (is (char= (object-after (make-buffer-mark buffer)) #\c))) (handler-case (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (object-after (make-buffer-mark buffer 7)) (fail "Failed to signal when requesting object past buffer end")) (no-such-offset (c) (= (condition-offset c) 7)))) (buffer-test region-to-sequence (let ((seq "climacs") (buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 seq) (let ((seq2 (region-to-string (make-buffer-mark buffer) (make-buffer-mark buffer 7)))) (is-true (not (eq seq seq2))) (is (string= seq2 "climacs")))) (let ((seq "climacs") (buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 seq) (let ((seq2 (region-to-string 0 (make-buffer-mark buffer 7)))) (is-true (not (eq seq seq2))) (is (string= seq2 "climacs")))) (let ((seq "climacs") (buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 seq) (let ((seq2 (region-to-string (make-buffer-mark buffer 7) 0))) (is-true (not (eq seq seq2))) (is (string= seq2 "climacs")))) (let ((seq "climacs") (buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 seq) (let ((seq2 (region-to-string (make-buffer-mark buffer) 7))) (is-true (not (eq seq seq2))) (is (string= seq2 "climacs")))) (let ((seq "climacs") (buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 seq) (let ((seq2 (region-to-string 7 (make-buffer-mark buffer)))) (is-true (not (eq seq seq2))) (is (string= seq2 "climacs")))) (let ((seq "climacs") (buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 seq) (is (string= (region-to-string (make-buffer-mark buffer 7) (make-buffer-mark buffer)) "climacs"))) (signals error (let ((buffer1 (make-instance %%buffer)) (buffer2 (make-instance %%buffer))) (region-to-string (make-buffer-mark buffer1) (make-buffer-mark buffer2))))) ;;;; performance tests (def-suite buffer-performance-tests :description "The test suite for buffer-protocol implementation performance tests.") (in-suite buffer-performance-tests) (buffer-test performance-test-1 (is (= (time (loop with b = (make-instance %%buffer) for i from 0 below 100000 do (insert-buffer-object b 0 #\a) finally (return (size b)))) 100000))) (buffer-test performance-test-1a (is (= (time (let ((b (loop with b = (make-instance %%buffer) for i from 0 below 100000 do (insert-buffer-object b 0 #\a) finally (return b)))) (loop for i from 0 below 100000 do (delete-buffer-range b 0 1) finally (return (size b))))) 0))) (buffer-test performance.test-1b (is (= (time (loop with b = (make-instance %%buffer) for i from 0 below 100000 do (insert-buffer-object b (size b) #\a) finally (return (size b)))) 100000))) (buffer-test performance.test-1ba (is (= (time (let ((b (loop with b = (make-instance %%buffer) for i from 0 below 100000 do (insert-buffer-object b (size b) #\a) finally (return b)))) (loop for i from 0 below 100000 do (delete-buffer-range b 0 1) finally (return (size b))))) 0))) (buffer-test performance.test-1c (is (= (time (loop with b = (make-instance %%buffer) for i from 0 below 100000 do (insert-buffer-object b (floor (size b) 2) #\a) finally (return (size b)))) 100000))) (buffer-test performance.test-1ca (is (= (time (let ((b (loop with b = (make-instance %%buffer) for i from 0 below 100000 do (insert-buffer-object b (floor (size b) 2) #\a) finally (return b)))) (loop for i from 0 below 100000 do (delete-buffer-range b 0 1) finally (return (size b))))) 0))) (buffer-test performance.test-1cb (is (= (time (let ((b (loop with b = (make-instance %%buffer) for i from 0 below 100000 do (insert-buffer-object b (floor (size b) 2) #\a) finally (return b)))) (loop for i from 0 below 100000 do (delete-buffer-range b (floor (size b) 2) 1) finally (return (size b))))) 0))) (buffer-test performance.test-2 (is (= (time (loop with b = (make-instance %%buffer) for i from 0 below 100000 do (insert-buffer-sequence b 0 "a") finally (return (size b)))) 100000))) (buffer-test performance.test-2b (is (= (time (loop with b = (make-instance %%buffer) for i from 0 below 100000 do (insert-buffer-sequence b (size b) "a") finally (return (size b)))) 100000))) (buffer-test performance.test-2c (is (= (time (loop with b = (make-instance %%buffer) for i from 0 below 100000 do (insert-buffer-sequence b (floor (size b) 2) "a") finally (return (size b)))) 100000))) (buffer-test performance.test-3 (is (= (time (loop with b = (make-instance %%buffer) for i from 0 below 100000 do (insert-buffer-sequence b 0 "abcdefghij") finally (return (size b)))) 1000000))) (buffer-test performance.test-3b (is (= (time (loop with b = (make-instance %%buffer) for i from 0 below 100000 do (insert-buffer-sequence b (size b) "abcdefghij") finally (return (size b)))) 1000000))) (buffer-test performance.test-3c (is (= (time (loop with b = (make-instance %%buffer) for i from 0 below 100000 do (insert-buffer-sequence b (floor (size b) 2) "abcdefghij") finally (return (size b)))) 1000000))) (buffer-test performance.test-4 (is-false (time (let ((b (make-instance %%buffer))) (insert-buffer-sequence b 0 (make-array '(100000) :initial-element #\a)) (let ((m (clone-mark (make-buffer-mark b)))) (loop for i from 0 below 1000 for f = t then (not b) do (if f (end-of-line m) (beginning-of-line m)))))))) (buffer-test performance.test-4b (is-false (time (let ((b (make-instance %%buffer))) (insert-buffer-object b 0 #\Newline) (insert-buffer-sequence b 0 (make-array '(100000) :initial-element #\a)) (insert-buffer-object b 0 #\Newline) (let ((m (clone-mark (make-buffer-mark b)))) (loop for i from 0 below 1000 for f = t then (not b) do (if f (end-of-line m) (beginning-of-line m)))))))) (buffer-test performance.test-4c (is-false (time (let ((b (make-instance %%buffer))) (insert-buffer-object b 0 #\Newline) (insert-buffer-sequence b 0 (make-array '(100000) :initial-element #\a)) (insert-buffer-object b 0 #\Newline) (let ((m (clone-mark (make-buffer-mark b)))) (incf (offset m)) (loop for i from 0 below 1000 for f = t then (not b) do (if f (end-of-line m) (beginning-of-line m)))))))) (buffer-test performance.test-4d (is (equal (time (let ((b (make-instance %%buffer))) (insert-buffer-object b 0 #\Newline) (insert-buffer-sequence b 0 (make-array '(100000) :initial-element #\a)) (insert-buffer-object b 0 #\Newline) (let ((m (clone-mark (make-buffer-mark b)))) (setf (offset m) (floor (size b) 2)) (loop for i from 0 below 10 collect (list (line-number m) (column-number m)))))) '((1 50000) (1 50000) (1 50000) (1 50000) (1 50000) (1 50000) (1 50000) (1 50000) (1 50000) (1 50000))))) (buffer-test performance.test-4e (is (= (time (let ((b (make-instance %%buffer))) (insert-buffer-sequence b 0 (make-array '(100000) :initial-element #\Newline)) (let ((m (clone-mark (make-buffer-mark b)))) (loop for i from 0 below 1000 for f = t then (not b) do (if f (forward-line m 0 100000) (previous-line m 0 100000)) finally (return (number-of-lines b)))))) 100000))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/Tests/motion-tests.lisp0000640000175000017500000003556010741375213022332 0ustar pdmpdm;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2005-2007 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (cl:in-package :drei-tests) (def-suite motion-tests :description "The test suite for DREI-MOTION related tests." :in drei-tests) (in-suite motion-tests) (test error-limit-action (with-buffer (buffer) (with-view (view :buffer buffer) (signals motion-limit-error (error-limit-action (point buffer) 0 0 "foo" (syntax view)))))) (test forward-to-word-boundary (with-buffer (buffer :initial-contents " climacs climacs") (with-view (view :buffer buffer) (let ((syntax (syntax view)) (m0l (clone-mark (point buffer) :left)) (m0r (clone-mark (point buffer) :right)) (m1l (clone-mark (point buffer) :left)) (m1r (clone-mark (point buffer) :right)) (m2l (clone-mark (point buffer) :left)) (m2r (clone-mark (point buffer) :right))) (setf (offset m0l) 0 (offset m0r) 0 (offset m1l) 5 (offset m1r) 5 (offset m2l) 17 (offset m2r) 17) (forward-to-word-boundary m0l syntax) (is (= (offset m0l) 2)) (forward-to-word-boundary m0r syntax) (is (= (offset m0r) 2)) (forward-to-word-boundary m1l syntax) (is (= (offset m1l) 5)) (forward-to-word-boundary m1r syntax) (is (= (offset m1r) 5)) (forward-to-word-boundary m2l syntax) (is (= (offset m2l) 17)) (forward-to-word-boundary m2r syntax) (is (= (offset m2r) 17)))))) (test backward-to-word-boundary (with-buffer (buffer :initial-contents "climacs climacs ") (with-view (view :buffer buffer) (let ((syntax (syntax view)) (m0l (make-buffer-mark buffer 17 :left)) (m0r (make-buffer-mark buffer 17 :right)) (m1l (make-buffer-mark buffer 10 :left)) (m1r (make-buffer-mark buffer 10 :right)) (m2l (make-buffer-mark buffer 0 :left)) (m2r (make-buffer-mark buffer 0 :right))) (backward-to-word-boundary m0l syntax) (is (= (offset m0l) 15)) (backward-to-word-boundary m0r syntax) (is (= (offset m0r) 15)) (backward-to-word-boundary m1l syntax) (is (= (offset m1l) 10)) (backward-to-word-boundary m1r syntax) (is (= (offset m1r) 10)) (backward-to-word-boundary m2l syntax) (is (= (offset m2l) 0)) (backward-to-word-boundary m2r syntax) (is (= (offset m2r) 0)))))) (defmacro motion-fun-one-test ((unit &optional (syntax 'drei-fundamental-syntax::fundamental-syntax)) &body test-specs) (let ((forward (intern (format nil "FORWARD-ONE-~S" unit))) (backward (intern (format nil "BACKWARD-ONE-~S" unit)))) `(progn ,@(loop for test in test-specs nconc (list `(test ,(intern (format nil "~A-~A" syntax forward) #.*package*) ,@(loop for test in test-specs collecting (destructuring-bind (forward-begin-offset backward-end-offset (offset goal-forward-offset goal-backward-offset) initial-contents) test (check-type forward-begin-offset (or integer null)) (check-type backward-end-offset (or integer null)) (check-type offset integer) (check-type goal-forward-offset (or integer null)) (check-type goal-backward-offset (or integer null)) `(with-buffer (buffer :initial-contents ,initial-contents) (with-view (view :buffer buffer :syntax ',syntax) (let ((syntax (syntax view)) (m0l (make-buffer-mark buffer 0 :left)) (m0r (make-buffer-mark buffer 0 :right)) (m1l (make-buffer-mark buffer ,offset :left)) (m1r (make-buffer-mark buffer ,offset :right)) (m2l (make-buffer-mark buffer (size buffer) :left)) (m2r (make-buffer-mark buffer (size buffer) :right))) (declare (ignore ,@(unless forward-begin-offset '(m0l)) ,@(unless backward-end-offset '(m0r)) ,@(unless goal-forward-offset '(m0r m1l)))) ,(when forward-begin-offset `(progn (is-true (,forward m0l syntax)) (is (= ,forward-begin-offset (offset m0l))))) ,(when backward-end-offset `(progn (is-true (,forward m0r syntax)) (is (= ,forward-begin-offset (offset m0r))))) ,(unless (null goal-forward-offset) `(progn (is-true (,forward m1l syntax)) (is (= ,goal-forward-offset (offset m1l))))) ,(unless (null goal-forward-offset) `(progn (is-true (,forward m1r syntax)) (is (= ,goal-forward-offset (offset m1r))))) (is-false (,forward m2l syntax)) (is (= (size buffer) (offset m2l))) (is-false (,forward m2r syntax)) (is (= (size buffer) (offset m2r))))))))) `(test ,(intern (format nil "~A-~A" syntax backward) #.*package*) ,@(loop for test in test-specs collecting (destructuring-bind (forward-begin-offset backward-end-offset (offset goal-forward-offset goal-backward-offset) initial-contents) test (declare (ignore forward-begin-offset goal-forward-offset)) `(with-buffer (buffer :initial-contents ,initial-contents) (with-view (view :buffer buffer :syntax ',syntax) (let ((syntax (syntax view)) (m0l (make-buffer-mark buffer 0 :left)) (m0r (make-buffer-mark buffer 0 :right)) (m1l (make-buffer-mark buffer ,offset :left)) (m1r (make-buffer-mark buffer ,offset :right)) (m2l (make-buffer-mark buffer (size buffer) :left)) (m2r (make-buffer-mark buffer (size buffer) :right))) (declare (ignore ,@(unless backward-end-offset '(m2l m2r)) ,@(unless goal-backward-offset '(m1l m1r)))) (is-false (,backward m0l syntax)) (is (= 0 (offset m0l))) (is-false (,backward m0r syntax)) (is (= 0 (offset m0r))) ,(unless (null goal-backward-offset) `(progn (is-true (,backward m1l syntax)) (is (= ,goal-backward-offset (offset m1l))))) ,(unless (null goal-backward-offset) `(progn (is-true (,backward m1r syntax)) (is (= ,goal-backward-offset (offset m1r))))) ,(when backward-end-offset `(progn (is-true (,backward m2l syntax)) (is (= ,backward-end-offset (offset m2l))))) ,(when backward-end-offset `(progn (is-true (,backward m2r syntax)) (is (= ,backward-end-offset (offset m2r)))))))))))))))) (motion-fun-one-test (word) (9 10 (5 9 2) " climacs climacs")) (motion-fun-one-test (line) (17 22 (25 47 8) "Climacs-Climacs! climacsclimacsclimacs... Drei!")) (motion-fun-one-test (page) (19 42 (22 40 21) "This is about Drei! Drei is Cool Stuff. ")) (motion-fun-one-test (paragraph) (21 67 (30 64 23) "Climacs is an editor. It is based on the Drei editor substrate. Run, Climacs, Run! Preferably a bit faster.")) (defmacro motion-fun-test (unit ((forward-begin-offset1 forward-begin-offset2) (backward-end-offset1 backward-end-offset2) (offset unit-count goal-forward-offset goal-backward-offset) initial-contents &key (syntax 'drei-fundamental-syntax:fundamental-syntax))) (check-type forward-begin-offset1 integer) (check-type forward-begin-offset2 integer) (check-type backward-end-offset1 integer) (check-type backward-end-offset2 integer) (check-type offset integer) (check-type goal-forward-offset integer) (check-type goal-backward-offset integer) (let ((forward (intern (format nil "FORWARD-~S" unit) #.*package*)) (backward (intern (format nil "BACKWARD-~S" unit) #.*package*))) `(progn (test ,forward (with-buffer (buffer :initial-contents ,initial-contents) (with-view (view :buffer buffer :syntax ',syntax) (let ((syntax (syntax view)) (m0l (make-buffer-mark buffer 0 :left)) (m0r (make-buffer-mark buffer 0 :right)) (m1l (make-buffer-mark buffer ,offset :left)) (m1r (make-buffer-mark buffer ,offset :right)) (m2l (make-buffer-mark buffer (size buffer) :left)) (m2r (make-buffer-mark buffer (size buffer) :right))) (is-true (,forward m0l syntax 1 nil)) (is (= (offset m0l) ,forward-begin-offset1)) (beginning-of-buffer m0l) (is-true (,forward m0l syntax 2 nil)) (is (= (offset m0l) ,forward-begin-offset2)) (is-true (,forward m0r syntax 1 nil)) (is (= (offset m0r) ,forward-begin-offset1)) (beginning-of-buffer m0r) (is-true (,forward m0r syntax 2 nil)) (is (= (offset m0r) ,forward-begin-offset2)) (is-true (,forward m1l syntax ,unit-count nil)) (is (= (offset m1l) ,goal-forward-offset)) (is-true (,forward m1r syntax ,unit-count nil)) (is (= (offset m1r) ,goal-forward-offset)) (is-false (,forward m2l syntax 1 nil)) (is (= (offset m2l) (size buffer))) (is-false (,forward m2r syntax 2 nil)) (is (= (offset m2r) (size buffer))))))) (test ,backward (with-buffer (buffer :initial-contents ,initial-contents) (with-view (view :buffer buffer :syntax ',syntax) (let ((syntax (syntax view)) (m0l (make-buffer-mark buffer 0 :left)) (m0r (make-buffer-mark buffer 0 :right)) (m1l (make-buffer-mark buffer ,offset :left)) (m1r (make-buffer-mark buffer ,offset :right)) (m2l (make-buffer-mark buffer (size buffer) :left)) (m2r (make-buffer-mark buffer (size buffer) :right))) (is-false (,backward m0l syntax 1 nil)) (is (= (offset m0l) 0)) (is-false (,backward m0r syntax 2 nil)) (is (= (offset m0r) 0)) (is-true (,backward m1l syntax ,unit-count nil)) (is (= (offset m1l) ,goal-backward-offset)) (is-true (,backward m1r syntax ,unit-count nil)) (is (= (offset m1r) ,goal-backward-offset)) (is-true (,backward m2l syntax 1 nil)) (is (= (offset m2l) ,backward-end-offset1)) (end-of-buffer m2l) (is-true (,backward m2l syntax 2 nil)) (is (= (offset m2l) ,backward-end-offset2)) (is-true (,backward m2r syntax 1 nil)) (is (= (offset m2r) ,backward-end-offset1)) (end-of-buffer m2r) (is-true (,backward m2r syntax 2 nil)) (is (= (offset m2r) ,backward-end-offset2))))))))) (motion-fun-test word ((2 7) (21 16) (10 3 15 0) "My word, it's a good word!")) (motion-fun-test line ((21 29) (67 55) (53 2 67 7) "The fun part of this is that column position has to be maintained. How can this lead to anything but joy?")) (motion-fun-test page ((19 21) (159 133) (30 2 157 21) "I am testing pages. By default, the page seperator is a newline followed by a . A single should not cause the page to shift. If it does, it's a bug. Please fix it.")) (motion-fun-test paragraph ((24 70) (248 223) (100 2 246 26) "I am testing paragraphs. Paragraphs are seperated by double newlines. That really just looks like a single blank line, but is must not contain space characters. If this rule is not followed, that is, as always, a bug. And it should be fixed. This is the last paragraph.")) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/Tests/packages.lisp0000640000175000017500000000273610537057760021451 0ustar pdmpdm;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; ASDF system definition for Drei's test suite. We use the excellent ;;; FiveAM test framework. (in-package :common-lisp-user) (defpackage :drei-tests (:use :clim-lisp :it.bese.fiveam :drei-buffer :drei-base :drei-motion :drei-editing :automaton :eqv-hash :drei-core :drei-kill-ring :drei-syntax :drei :esa :esa-utils :clim :drei-lisp-syntax :drei-undo) (:shadowing-import-from :automaton #:run) (:shadowing-import-from :drei-lisp-syntax #:form) (:export #:run-tests #:*run-self-compilation-test*)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/Tests/undo-tests.lisp0000640000175000017500000000340510705412617021763 0ustar pdmpdm;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (cl:in-package :drei-tests) (def-suite undo-tests :description "The test suite for tests related to Drei's undo system." :in drei-tests) (in-suite undo-tests) (defclass test-undo-record (standard-undo-record) ()) (defmethod flip-undo-record ((record test-undo-record))) (test add-undo (let ((tree (make-instance 'standard-undo-tree))) (finishes (add-undo (make-instance 'test-undo-record) tree)) (finishes (add-undo (make-instance 'test-undo-record) tree)))) (test undo (let ((tree (make-instance 'standard-undo-tree))) (add-undo (make-instance 'test-undo-record) tree) (add-undo (make-instance 'test-undo-record) tree) (finishes (undo tree 2)) (signals no-more-undo (undo tree 1)))) (test redo (let ((tree (make-instance 'standard-undo-tree))) (add-undo (make-instance 'test-undo-record) tree) (undo tree 1) (redo tree 1) (finishes (undo tree 1)))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/Tests/editing-tests.lisp0000640000175000017500000003455610741375213022454 0ustar pdmpdm;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (cl:in-package :drei-tests) (def-suite editing-tests :description "The test suite for DREI-EDITING related tests." :in drei-tests) (in-suite editing-tests) (defmacro with-buffer-action-test-functions (&body body) ;; Anamorphic. `(labels ((test-buffer-action-with-stickto (action offset mark-stickto initial-contents end-contents kill-ring-end-contents) (with-buffer (buffer :initial-contents initial-contents) (with-view (view :buffer buffer) ;; If your test surpasses this max size, you're ;; probably doing something semi-insane. (let* ((kill-ring (make-instance 'kill-ring :max-size 20)) (*kill-ring* kill-ring)) (let ((mark (clone-mark (point buffer) mark-stickto))) (setf (offset mark) offset) (funcall action view mark) (is (string= end-contents (buffer-contents buffer))) ;; `kill-ring-end-contents' is a list of what should ;; be at the top of the kill ring now. Assert that ;; it is. (handler-case (mapcar #'(lambda (killed-string expected) (is (string= expected killed-string))) (loop repeat (length kill-ring-end-contents) collecting (coerce (kill-ring-yank kill-ring nil) 'string) do (rotate-yank-position kill-ring 1)) kill-ring-end-contents) (empty-kill-ring () (fail "Kill ring did not contain enough values to satisfy ~A" kill-ring-end-contents)))))))) (test-buffer-action (action offset initial-contents end-contents kill-ring-end-contents) (test-buffer-action-with-stickto action offset :left initial-contents end-contents kill-ring-end-contents) (test-buffer-action-with-stickto action offset :right initial-contents end-contents kill-ring-end-contents))) ,@body)) (defmacro deletion/killing-test (unit ((fromstart-contents1 (&rest fromstart-contents1-killed)) (fromstart-contents2 (&rest fromstart-contents2-killed))) ((fromend-contents1 (&rest fromend-contents1-killed)) (fromend-contents2 (&rest fromend-contents2-killed))) (offset count (forward-contents (&rest forward-contents-killed)) (backward-contents (&rest backward-contents-killed))) initial-contents) ;; Easy to get the ungodly amount of arguments wrong, so insert some ;; type-checks... (check-type unit symbol) (check-type fromstart-contents1 string) (check-type fromstart-contents2 string) (check-type fromend-contents1 string) (check-type fromend-contents2 string) (check-type offset integer) (check-type count integer) (check-type forward-contents string) (check-type backward-contents string) (check-type initial-contents string) (let ((forward-delete (intern (format nil "FORWARD-DELETE-~A" unit))) (backward-delete (intern (format nil "BACKWARD-DELETE-~A" unit))) (forward-kill (intern (format nil "FORWARD-KILL-~A" unit))) (backward-kill (intern (format nil "BACKWARD-KILL-~A" unit))) (end (length initial-contents))) (flet ((make-deletion-test-function-case (operation motion-count initial-offset after-contents kill-ring-end-contents) `(test-buffer-action #'(lambda (view mark) (,operation mark (syntax view) ,motion-count nil)) ,initial-offset ,initial-contents ,after-contents ',kill-ring-end-contents))) `(progn (test ,forward-delete (with-buffer-action-test-functions ,(make-deletion-test-function-case forward-delete 1 0 fromstart-contents1 nil) ,(make-deletion-test-function-case forward-delete 2 0 fromstart-contents2 nil) ,(make-deletion-test-function-case forward-delete count offset forward-contents nil))) (test ,backward-delete (with-buffer-action-test-functions ,(make-deletion-test-function-case backward-delete 1 end fromend-contents1 nil) ,(make-deletion-test-function-case backward-delete 2 end fromend-contents2 nil) ,(make-deletion-test-function-case backward-delete count offset backward-contents nil))) (test ,forward-kill (with-buffer-action-test-functions ,(make-deletion-test-function-case forward-kill 1 0 fromstart-contents1 fromstart-contents1-killed) ,(make-deletion-test-function-case forward-kill 2 0 fromstart-contents2 fromstart-contents2-killed) ,(make-deletion-test-function-case forward-kill count offset forward-contents forward-contents-killed))) (test ,backward-kill (with-buffer-action-test-functions ,(make-deletion-test-function-case backward-kill 1 end fromend-contents1 fromend-contents1-killed) ,(make-deletion-test-function-case backward-kill 2 end fromend-contents2 fromend-contents2-killed) ,(make-deletion-test-function-case backward-kill count offset backward-contents backward-contents-killed))))))) (deletion/killing-test line (("It has multiple lines. The semantics of the kill-line function are not very intuitive. Not to the user, at least, but to the programmer, they are good." ("This is a string. ")) ("The semantics of the kill-line function are not very intuitive. Not to the user, at least, but to the programmer, they are good." ("This is a string. It has multiple lines. "))) (("This is a string. It has multiple lines. The semantics of the kill-line function are not very intuitive. Not t" ("o the user, at least, but to the programmer, they are good.")) ("This is a string. It has multiple lines. The semantics of the kill-line function are not very intuitive. " (" Not to the user, at least, but to the programmer, they are good."))) (50 2 ("This is a string. It has multiple lines. The seman Not to the user, at least, but to the programmer, they are good." ("tics of the kill-line function are not very intuitive. ")) ("This is atics of the kill-line function are not very intuitive. Not to the user, at least, but to the programmer, they are good." (" string. It has multiple lines. The seman"))) "This is a string. It has multiple lines. The semantics of the kill-line function are not very intuitive. Not to the user, at least, but to the programmer, they are good.") (deletion/killing-test word (("! This is a sentence with words." (" Word")) (" is a sentence with words." (" Word! This"))) ((" Word! This is a sentence with " ("words.")) (" Word! This is a sentence " ("with words."))) (20 3 (" Word! This is a sen." ("tence with words")) (" Word! This tence with words." ("is a sen"))) " Word! This is a sentence with words.") (deletion/killing-test page ((" B C D E F" ("A")) (" C D E F" ("A B"))) (("A B C D E " ("F")) ("A B C D " ("E F"))) (5 2 ("A B E F" (" C D")) (" C D E F" ("A B "))) "A B C D E F") (deletion/killing-test paragraph ((" Paragraphs are seperated by double newlines. That really just looks like a single blank line, but it must not contain space characters. If this rule is not followed, that is, as always, a bug. And it should be fixed. This is the last paragraph." ("I am testing paragraphs.")) (" That really just looks like a single blank line, but it must not contain space characters. If this rule is not followed, that is, as always, a bug. And it should be fixed. This is the last paragraph." ("I am testing paragraphs. Paragraphs are seperated by double newlines."))) (("I am testing paragraphs. Paragraphs are seperated by double newlines. That really just looks like a single blank line, but it must not contain space characters. If this rule is not followed, that is, as always, a bug. And it should be fixed. " ("This is the last paragraph.")) ("I am testing paragraphs. Paragraphs are seperated by double newlines. That really just looks like a single blank line, but it must not contain space characters. If this rule is not followed, that is, as always, a bug. " ("And it should be fixed. This is the last paragraph."))) (100 2 ("I am testing paragraphs. Paragraphs are seperated by double newlines. That really just looks like This is the last paragraph." ("a single blank line, but it must not contain space characters. If this rule is not followed, that is, as always, a bug. And it should be fixed.")) ("I am testing paragraphs. a single blank line, but it must not contain space characters. If this rule is not followed, that is, as always, a bug. And it should be fixed. This is the last paragraph." ("Paragraphs are seperated by double newlines. That really just looks like "))) "I am testing paragraphs. Paragraphs are seperated by double newlines. That really just looks like a single blank line, but it must not contain space characters. If this rule is not followed, that is, as always, a bug. And it should be fixed. This is the last paragraph.") (defmacro transposition-test (unit (at-beginning-contents) (at-end-contents &optional no-signal) (&rest offset-contents-tests) initial-contents) (check-type unit symbol) (check-type at-beginning-contents string) (check-type at-end-contents string) (check-type initial-contents string) (let ((transpose (intern (format nil "TRANSPOSE-~AS" unit))) (end (length initial-contents))) (flet ((make-transposition-test-function-case (operation initial-offset after-contents kill-ring-end-contents) `(test-buffer-action #'(lambda (view mark) (,operation mark (syntax view))) ,initial-offset ,initial-contents ,after-contents ',kill-ring-end-contents)) (make-transposition-test-function-case-with-stickto (operation initial-offset stickto after-contents kill-ring-end-contents) `(test-buffer-action-with-stickto #'(lambda (view mark) (,operation mark (syntax view))) ,initial-offset ,stickto ,initial-contents ,after-contents ',kill-ring-end-contents))) `(progn (test ,transpose (with-buffer-action-test-functions ,(make-transposition-test-function-case transpose 0 at-beginning-contents nil) ;; Transposing at the end of the buffer is an error ,(if no-signal `(progn ,(make-transposition-test-function-case-with-stickto transpose end :left at-end-contents nil) ,(make-transposition-test-function-case-with-stickto transpose end :right at-end-contents nil)) `(progn (signals motion-limit-error ,(make-transposition-test-function-case-with-stickto transpose end :left at-end-contents nil)) (signals motion-limit-error ,(make-transposition-test-function-case-with-stickto transpose end :right at-end-contents nil)))) ,@(loop for (offset after-contents) in offset-contents-tests collecting (make-transposition-test-function-case transpose offset after-contents nil)))))))) (transposition-test line ("Second line. First line. Third line.") ("First line. Third line. Second line." t) () "First line. Second line. Third line.") (transposition-test word ("words Many, great words!") ("") ((8 "Many great, words words!") (10 "Many great, words words!")) "Many words, great words!") (transposition-test page ("B A C D E F") ("") ((5 "A C B D E F")) "A B C D E F") (transposition-test paragraph ("B A C D E F") ("") () "A B C D E F") cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/Tests/cl-automaton/0000750000175000017500000000000011347763412021372 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/Tests/cl-automaton/automaton-tests.lisp0000640000175000017500000003231510705412617025432 0ustar pdmpdm;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (cl:in-package :drei-tests) (def-suite automaton-tests :description "The test suite for CL-AUTOMATON related tests." :in drei-tests) (in-suite automaton-tests) (defmacro automaton-test (name &body body) (let ((name-string (symbol-name name))) (flet ((%dts (prefixes) (loop for v1 in prefixes nconc (loop for v2 in '(t nil) collect `(test ,(intern (concatenate 'string (symbol-name v1) (if v2 "" "-LIGHT") "." name-string)) (let ((automaton::*minimization* ',(intern (symbol-name v1) :automaton)) (automaton::*minimize-always* ,v2)) ,@body)))))) `(progn ,@(%dts '(hopcroft huffman brzozowski)))))) (automaton-test regexp-automaton.1 (is-true (automaton-equal (let ((a (regexp-automaton (string-regexp "#")))) (and (not (run a "")) (not (run a "#")) a)) (automaton::minimize (automaton::empty-automaton))))) (automaton-test regexp-automaton.2 (is-true (automaton-equal (let ((a (regexp-automaton (string-regexp "foo")))) (and (run a "foo") a)) (automaton::minimize (automaton::string-automaton "foo")))) (is-true (automaton-equal (let ((a (regexp-automaton (string-regexp "()")))) (and (run a "") (not (run a " ")) a)) (automaton::minimize (automaton::string-automaton "")))) (is-false (automaton-equal (regexp-automaton (string-regexp "()")) (automaton::minimize (automaton::empty-automaton))))) (automaton-test regexp-automaton.3 (is-true (automaton-equal (let ((a (regexp-automaton (string-regexp "c")))) (and (run a "c") (not (run a "C")) a)) (automaton::minimize (automaton::char-automaton (char-code #\c)))))) (automaton-test regexp-automaton.4 (is-true (automaton-equal (let ((a (regexp-automaton (string-regexp ".")))) (and (run a "x") (not (run a "xx")) a)) (automaton::minimize (automaton::any-char-automaton))))) (automaton-test regexp-automaton.5 (is-true (automaton-equal (let ((a (regexp-automaton (string-regexp "@")))) (and (run a "foo") a)) (automaton::minimize (automaton::any-string-automaton))))) (automaton-test regexp-automaton.6 (is-true (automaton-equal (let ((a (regexp-automaton (string-regexp "<11-15>")))) (and (run a "13") (not (run a "10")) (not (run a "16")) (not (run a "20")) (not (run a "011")) a)) (automaton::minimize (automaton::interval-automaton 11 15 2)))) (is-true (automaton-equal (let ((a (regexp-automaton (string-regexp "<115-11>")))) (and (run a "13") (run a "113") (not (run a "116")) (run a "00114") (run a "20") (not (run a "200")) (run a "011") a)) (automaton::minimize (automaton::interval-automaton 11 115 0))))) (automaton-test regexp-automaton.7 (is-true (let ((ht (make-hash-table :test #'equal))) (setf (gethash "sub" ht) (automaton::empty-automaton)) (automaton-equal (let ((a (regexp-automaton (string-regexp "") ht))) (and (not (run a "foo")) a)) (automaton::minimize (automaton::empty-automaton)))))) (automaton-test regexp-automaton.8 (is-true (automaton-equal (let ((a (regexp-automaton (string-regexp "[a-z]")))) (and (run a "a") (run a "z") (not (run a "A")) a)) (automaton::minimize (automaton::char-range-automaton (char-code #\a) (char-code #\z))))) (is-true (automaton-equal (let ((a (regexp-automaton (string-regexp "[a]")))) (and (run a "a") (not (run a "A")) a)) (automaton::minimize (automaton::char-automaton (char-code #\a)))))) (automaton-test regexp-automaton.9 (is-true (automaton-equal (let ((a (regexp-automaton (string-regexp "[a][b][c]")))) (and (run a "abc") (not (run a "ab")) (not (run a "a")) (not (run a "A")) a)) (automaton::minimize (automaton::string-automaton "abc"))))) (automaton-test regexp-automaton.10 (is-true (automaton-equal (let ((a (regexp-automaton (string-regexp "[ab]")))) (and (run a "a") (run a "b") (not (run a "ab")) (not (run a "aa")) (not (run a "A")) a)) (automaton::minimize (automaton::aunion (automaton::char-automaton (char-code #\a)) (automaton::char-automaton (char-code #\b))))))) (automaton-test regexp-automaton.11 (is-true (automaton-equal (let ((a (regexp-automaton (string-regexp "[^a-c0-3]")))) (and (run a "d") (not (run a "a")) (not (run a "0")) (run a "4") (not (run a "dd")) (not (run a "00")) a)) (automaton::minimize (automaton::aintersection (automaton::any-char-automaton) (automaton::acomplement (automaton::aunion (automaton::char-range-automaton (char-code #\a) (char-code #\c)) (automaton::char-range-automaton (char-code #\0) (char-code #\3)))))))) (is-true (automaton-equal (let ((a (regexp-automaton (string-regexp "[a^b-c]")))) (and (run a "a") (run a "^") (run a "b") (run a "c") (not (run a "d")) (not (run a "ad")) a)) (automaton::minimize (automaton::aunion (automaton::aunion (automaton::char-automaton (char-code #\a)) (automaton::char-automaton (char-code #\^))) (automaton::char-range-automaton (char-code #\b) (char-code #\c))))))) (automaton-test regexp-automaton.12 (is-true (automaton-equal (let ((a (regexp-automaton (string-regexp "~[a-c]")))) (and (run a "d") (not (run a "a")) (not (run a "b")) (not (run a "c")) (run a "dd") (run a "cc") (run a "A") a)) (automaton::minimize (automaton::acomplement (automaton::char-range-automaton (char-code #\a) (char-code #\c))))))) (automaton-test regexp-automaton.13 (is-true (automaton-equal (let ((a (regexp-automaton (string-regexp "f?")))) (and (run a "") (run a "f") (not (run a "ff")) (not (run a "F")) a)) (automaton::minimize (automaton::optional (automaton::char-automaton (char-code #\f))))))) (automaton-test regexp-automaton.14 (is-true (automaton-equal (let ((a (regexp-automaton (string-regexp "(\"foo\")?")))) (and (run a "") (run a "foo") (not (run a "foofoo")) (not (run a "FOO")) a)) (automaton::minimize (automaton::optional (automaton::string-automaton "foo")))))) (automaton-test regexp-automaton.15 (is-true (automaton-equal (let ((a (regexp-automaton (string-regexp "[a-c]*")))) (and (run a "a") (run a "bb") (run a "ccc") (run a "abcabc") (not (run a "d")) (run a "") a)) (automaton::minimize (automaton::repeat (automaton::char-range-automaton (char-code #\a) (char-code #\c))))))) (automaton-test regexp-automaton.16 (is-true (automaton-equal (let ((a (regexp-automaton (string-regexp "(\"foo\")+")))) (and (not (run a "")) (run a "foo") (run a "foofoo") (not (run a "FOO")) a)) (automaton::minimize (automaton::repeat-min (automaton::string-automaton "foo") 1))))) (automaton-test regexp-automaton.17 (is-true (automaton-equal (let ((a (regexp-automaton (string-regexp "[a-c]{3}")))) (and (run a "abc") (run a "aaa") (not (run a "a")) (not (run a "aaaa")) (not (run a "AAA")) a)) (automaton::minimize (automaton::repeat-minmax (automaton::char-range-automaton (char-code #\a) (char-code #\c)) 3 3))))) (automaton-test regexp-automaton.18 (is-true (automaton-equal (let ((a (regexp-automaton (string-regexp "(~c){1,2}")))) (and (run a "aa") (run a "AA") (run a "foofoo") (run a "foo") (not (run a "c")) (run a "cc") (run a "ccc") a)) (automaton::minimize (automaton::repeat-minmax (automaton::acomplement (automaton::char-automaton (char-code #\c))) 1 2)))) (is-true (automaton-equal (let ((a (regexp-automaton (string-regexp "~(c{1,2})")))) (and (run a "aa") (run a "AA") (run a "foofoo") (run a "foo") (not (run a "c")) (not (run a "cc")) (run a "ccc") a)) (automaton::minimize (automaton::acomplement (automaton::repeat-minmax (automaton::char-automaton (char-code #\c)) 1 2)))))) (automaton-test regexp-automaton.19 (is-true (automaton-equal (let ((a (regexp-automaton (string-regexp "[a-z]~[0-9]")))) (and (run a "aa") (run a "a") (not (run a "a0")) (not (run a "")) (run a "abc") a)) (automaton::minimize (automaton::aconcatenate (automaton::char-range-automaton (char-code #\a) (char-code #\z)) (automaton::acomplement (automaton::char-range-automaton (char-code #\0) (char-code #\9)))))))) (automaton-test regexp-automaton.20 (is-true (automaton-equal (let ((a (regexp-automaton (string-regexp "(ab+)&(a+b)|c")))) (and (run a "ab") (run a "c") (not (run a "abb")) (not (run a "aab")) a)) (automaton::minimize (automaton::aunion (automaton::aintersection (automaton::aconcatenate (automaton::char-automaton (char-code #\a)) (automaton::repeat-min (automaton::char-automaton (char-code #\b)) 1)) (automaton::aconcatenate (automaton::repeat-min (automaton::char-automaton (char-code #\a)) 1) (automaton::char-automaton (char-code #\b)))) (automaton::char-automaton (char-code #\c))))))) (automaton-test regexp-automaton.21 (is-true (automaton-equal (let ((a (regexp-automaton (string-regexp "a\"b\"+c")))) (and (run a "abc") (run a "abbc") (not (run a "ab")) (not (run a "ac")) a)) (automaton::minimize (automaton::aconcatenate (automaton::char-automaton (char-code #\a)) (automaton::aconcatenate (automaton::repeat-min (automaton::string-automaton "b") 1) (automaton::char-automaton (char-code #\c)))))))) (automaton-test run.1 (is-true (let ((a (regexp-automaton (string-regexp "[Cc]limacs")))) (and (run a "climacs") (run a "Climacs") (not (run a "Klimaks")) (not (run a "climac")) (not (run a "climax")))))) (automaton-test run-to-first-match.1 (is-true (let ((a (regexp-automaton (string-regexp "[a-z]+")))) (and (= (run-to-first-match a "abc") 1) (eq (run-to-first-match a "ABC") nil) (eq (run-to-first-match a "000abc") nil) (= (run-to-first-match a "a") 1) (eq (run-to-first-match a "") nil))))) (automaton-test run-to-first-match.2 (is-true (let ((a (regexp-automaton (string-regexp "(ab)+")))) (and (= (run-to-first-match a "abab") 2) (= (run-to-first-match a "ababac") 2))))) (automaton-test run-to-first-unmatch.1 (is-true (let ((a (regexp-automaton (string-regexp "[a-z]+")))) (and (= (run-to-first-unmatch a "abc") 3) (eq (run-to-first-unmatch a "ABC") nil) (eq (run-to-first-unmatch a "000abc") nil) (= (run-to-first-unmatch a "a") 1) (eq (run-to-first-unmatch a "") nil) (= (run-to-first-unmatch a "abc9d") 3))))) (automaton-test run-to-first-unmatch.2 (is-true (let ((a (regexp-automaton (string-regexp "(ab)+")))) (and (= (run-to-first-unmatch a "abab") 2) (= (run-to-first-unmatch a "ababac") 2)))))cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/Tests/cl-automaton/regexp-tests.lisp0000640000175000017500000002102410705412617024710 0ustar pdmpdm;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (cl:in-package :drei-tests) (def-suite regexp-tests :description "The test suite for CL-AUTOMATON regexp related tests." :in automaton-tests) (in-suite regexp-tests) (automaton-test string-regexp.1 (is-true (regexp-equal (string-regexp "#") (automaton::make-regexp :empty)))) (automaton-test string-regexp.2 (is-true (regexp-equal (string-regexp "foo") (make-instance 'automaton::regexp :kind :string :s "foo"))) (is-true (regexp-equal (string-regexp "\"foo\"") (make-instance 'automaton::regexp :kind :string :s "foo"))) (is-true (regexp-equal (string-regexp "()") (make-instance 'automaton::regexp :kind :string :s "")))) (automaton-test string-regexp.3 (is-true (regexp-equal (string-regexp "c") (make-instance 'automaton::regexp :kind :char :c #\c))) (is-true (regexp-equal (string-regexp "\c") (make-instance 'automaton::regexp :kind :char :c #\c))) (is-true (regexp-equal (string-regexp "\\c") (make-instance 'automaton::regexp :kind :char :c #\c)))) (automaton-test string-regexp.4 (is-true (regexp-equal (string-regexp ".") (automaton::make-regexp :anychar)))) (automaton-test string-regexp.5 (is-true (regexp-equal (string-regexp "@") (automaton::make-regexp :anystring)))) (automaton-test string-regexp.6 (is-true (regexp-equal (string-regexp "<11-15>") (make-instance 'automaton::regexp :kind :interval :minr 11 :maxr 15 :digits 2))) (is-true (regexp-equal (string-regexp "<11-115>") (make-instance 'automaton::regexp :kind :interval :minr 11 :maxr 115 :digits 0))) (is-true (regexp-equal (string-regexp "<115-11>") (make-instance 'automaton::regexp :kind :interval :minr 11 :maxr 115 :digits 0)))) (automaton-test string-regexp.7 (is-true (regexp-equal (string-regexp "") (make-instance 'automaton::regexp :kind :automaton :s "sub")))) (automaton-test string-regexp.8 (is-true (regexp-equal (string-regexp "[a-z]") (make-instance 'automaton::regexp :kind :char-range :from #\a :to #\z))) (is-true (regexp-equal (string-regexp "[a]") (make-instance 'automaton::regexp :kind :char :c #\a)))) (automaton-test string-regexp.9 (is-true (regexp-equal (string-regexp "[a][b][c]") (make-instance 'automaton::regexp :kind :string :s "abc")))) (automaton-test string-regexp.10 (is-true (regexp-equal (string-regexp "[ab]") (automaton::make-regexp :union (make-instance 'automaton::regexp :kind :char :c #\a) (make-instance 'automaton::regexp :kind :char :c #\b))))) (automaton-test string-regexp.11 (is-true (regexp-equal (string-regexp "[^a-c0-3]") (automaton::make-regexp :intersection (automaton::make-regexp :anychar) (automaton::make-regexp :complement (automaton::make-regexp :union (make-instance 'automaton::regexp :kind :char-range :from #\a :to #\c) (make-instance 'automaton::regexp :kind :char-range :from #\0 :to #\3)))))) (is-true (regexp-equal (string-regexp "[a^b-c]") (automaton::make-regexp :union (automaton::make-regexp :union (make-instance 'automaton::regexp :kind :char :c #\a) (make-instance 'automaton::regexp :kind :char :c #\^)) (make-instance 'automaton::regexp :kind :char-range :from #\b :to #\c))))) (automaton-test string-regexp.12 (is-true (regexp-equal (string-regexp "~[a-c]") (automaton::make-regexp :complement (make-instance 'automaton::regexp :kind :char-range :from #\a :to #\c))))) (automaton-test string-regexp.13 (is-true (regexp-equal (string-regexp "f?") (automaton::make-regexp :optional (make-instance 'automaton::regexp :kind :char :c #\f))))) (automaton-test string-regexp.14 (is-true (regexp-equal (string-regexp "(\"foo\")?") (automaton::make-regexp :optional (make-instance 'automaton::regexp :kind :string :s "foo"))))) (automaton-test string-regexp.15 (is-true (regexp-equal (string-regexp "[a-c]*") (automaton::make-regexp :repeat (make-instance 'automaton::regexp :kind :char-range :from #\a :to #\c))))) (automaton-test string-regexp.16 (is-true (regexp-equal (string-regexp "(\"foo\")+") (make-instance 'automaton::regexp :kind :repeat-min :exp1 (make-instance 'automaton::regexp :kind :string :s "foo") :minr 1)))) (automaton-test string-regexp.17 (is-true (regexp-equal (string-regexp "[a-c]{3}") (make-instance 'automaton::regexp :kind :repeat-minmax :exp1 (make-instance 'automaton::regexp :kind :char-range :from #\a :to #\c) :minr 3 :maxr 3)))) (automaton-test string-regexp.18 (is-true (regexp-equal (string-regexp "(~c){1,2}") (make-instance 'automaton::regexp :kind :repeat-minmax :exp1 (automaton::make-regexp :complement (make-instance 'automaton::regexp :kind :char :c #\c)) :minr 1 :maxr 2)))) (automaton-test string-regexp.19 (is-true (regexp-equal (string-regexp "[a-z]~[0-9]") (automaton::make-regexp :concatenation (make-instance 'automaton::regexp :kind :char-range :from #\a :to #\z) (automaton::make-regexp :complement (make-instance 'automaton::regexp :kind :char-range :from #\0 :to #\9)))))) (automaton-test string-regexp.20 (is-true (regexp-equal (string-regexp "(ab+)&(a+b)|c") (automaton::make-regexp :union (automaton::make-regexp :intersection (automaton::make-regexp :concatenation (make-instance 'automaton::regexp :kind :char :c #\a) (make-instance 'automaton::regexp :kind :repeat-min :exp1 (make-instance 'automaton::regexp :kind :char :c #\b) :minr 1)) (automaton::make-regexp :concatenation (make-instance 'automaton::regexp :kind :repeat-min :exp1 (make-instance 'automaton::regexp :kind :char :c #\a) :minr 1) (make-instance 'automaton::regexp :kind :char :c #\b))) (make-instance 'automaton::regexp :kind :char :c #\c))))) (automaton-test string-regexp.21 (is-true (regexp-equal (string-regexp "a\"b\"+c") (automaton::make-regexp :concatenation (make-instance 'automaton::regexp :kind :char :c #\a) (automaton::make-regexp :concatenation (make-instance 'automaton::regexp :kind :repeat-min :exp1 (make-instance 'automaton::regexp :kind :string :s "b") :minr 1) (make-instance 'automaton::regexp :kind :char :c #\c)))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/Tests/cl-automaton/state-and-transition-tests.lisp0000640000175000017500000001306210705412617027471 0ustar pdmpdm;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (cl:in-package :drei-tests) (def-suite state-and-transition-tests :description "The test suite for CL-AUTOMATON state-and-transition related tests." :in automaton-tests) (in-suite state-and-transition-tests) (test clone.transition (let* ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (t2 (automaton::clone t1))) (is (eqv t1 t2 +equalp-key-situation+)) (is (eql (hash t1 +equalp-key-situation+) (hash t2 +equalp-key-situation+))))) (test transition<.1 (let ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (t2 (make-instance 'automaton::transition :minc (char-code #\c) :maxc (char-code #\d) :to (make-instance 'automaton::state))) (automaton::*to-first* nil)) (is-true (automaton::transition< t1 t2)))) (test transition<.2 (let ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (t2 (make-instance 'automaton::transition :minc (char-code #\c) :maxc (char-code #\d) :to (make-instance 'automaton::state))) (automaton::*to-first* t)) (setf (automaton::num (automaton::to t1)) 1) (is-true (automaton::transition< t2 t1))) (let ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (t2 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\d) :to (make-instance 'automaton::state))) (automaton::*to-first* t)) (is-true (automaton::transition< t2 t1)))) (test transition<.3 (let ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\c) :to (make-instance 'automaton::state))) (t2 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (automaton::*to-first* nil)) (is-true (automaton::transition< t1 t2)))) (test sstep.test-1 (let* ((s (make-instance 'automaton::state)) (tr (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to s))) (htadd (automaton::transitions s) tr) (is (eq (automaton::sstep s #\a) s)))) (test sstep.test-2 (let* ((s (make-instance 'automaton::state)) (tr (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to s))) (htadd (automaton::transitions s) tr) (is-false (automaton::sstep s #\c)))) (test add-epsilon (let* ((s1 (make-instance 'automaton::state)) (s2 (make-instance 'automaton::state)) (tr (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to s2))) (htadd (automaton::transitions s2) tr) (automaton::add-epsilon s1 s2) (is-true (htpresent (automaton::transitions s1) tr)))) (test sorted-transition-vector (let* ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\c) :to (make-instance 'automaton::state))) (t2 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (s (make-instance 'automaton::state))) (htadd (automaton::transitions s) t1) (htadd (automaton::transitions s) t2) (is (equalp (automaton::sorted-transition-vector s nil) (vector t1 t2))))) (test sorted-transition-list (let* ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\c) :to (make-instance 'automaton::state))) (t2 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (s (make-instance 'automaton::state))) (htadd (automaton::transitions s) t1) (htadd (automaton::transitions s) t2) (is (equal (automaton::sorted-transition-list s nil) (list t1 t2)))))cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/Tests/cl-automaton/eqv-hash-tests.lisp0000640000175000017500000001432110705412617025134 0ustar pdmpdm;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (cl:in-package :drei-tests) (def-suite eqv-hash-tests :description "The test suite for CL-AUTOMATON eqv-hash related tests." :in automaton-tests) (in-suite eqv-hash-tests) (defclass foo () ((slot1 :initform 0 :initarg :slot1 :type fixnum :accessor slot1) (slot2 :initform 0 :initarg :slot2 :type fixnum :accessor slot2))) (defclass foo-intention (equalp-key-situation) ()) (defparameter +foo-intention+ (make-instance 'foo-intention)) (defmethod eqv ((foo1 foo) (foo2 foo) (s (eql +foo-intention+))) (eql (slot1 foo1) (slot1 foo2))) (defmethod hash ((foo1 foo) (s (eql +foo-intention+))) (floor (slot1 foo1) 2)) (test htref.test-1 ; (eqv i1 i2), (= (hash i1) (hash i2)) (let ((ght (make-generalized-hash-table +foo-intention+)) (i1 (make-instance 'foo :slot1 1 :slot2 2)) (i2 (make-instance 'foo :slot1 1 :slot2 3))) (setf (htref ght i1) i1) (setf (htref ght i2) i2) (is (= (cnt ght) 1)) (is (eq (htref ght i1) i2)) (is (htref ght i2) i2))) (test htref.test-2 ; (not (eqv i1 i2)), (= (hash i1) (hash i2)) (let ((ght (make-generalized-hash-table +foo-intention+)) (i1 (make-instance 'foo :slot1 2)) (i2 (make-instance 'foo :slot1 3))) (setf (htref ght i1) i1) (setf (htref ght i2) i2) (is (= (cnt ght) 2)) (is (eq (htref ght i1) i1)) (is (eq (htref ght i2) i2)))) (test htref.test-3 ; (not (eqv i1 i2)), (/= (hash i1) (hash i2)) (let ((ght (make-generalized-hash-table +foo-intention+)) (i1 (make-instance 'foo :slot1 2)) (i2 (make-instance 'foo :slot1 4))) (setf (htref ght i1) i1) (setf (htref ght i2) i2) (is (= (cnt ght) 2)) (is (eq (htref ght i1) i1)) (is (eq (htref ght i2) i2)))) (test htref.test-4 (let ((ght (make-generalized-hash-table +foo-intention+)) (i1 (make-instance 'foo :slot1 1 :slot2 2)) (i2 (make-instance 'foo :slot1 1 :slot2 3))) (setf (htref ght i1) i1) (is (= (cnt ght) 1)) (is (eq (htref ght i2) i1)))) (test htref.test-5 (let ((ght (make-generalized-hash-table +foo-intention+)) (i1 (make-instance 'foo :slot1 1 :slot2 2)) (i2 (make-instance 'foo :slot1 1 :slot2 3))) (setf (htref ght i1) i1) (multiple-value-bind (v vp) (htref ght i2) (declare (ignore v)) (is (= (cnt ght) 1)) (is-true vp)))) (test htref.test-6 (let ((ght (make-generalized-hash-table +foo-intention+)) (i1 (make-instance 'foo :slot1 2)) (i2 (make-instance 'foo :slot1 3))) (setf (htref ght i1) i1) (multiple-value-bind (a b) (htref ght i2) (is-false a) (is-false b)))) (test htref.test-7 (let ((ght (make-generalized-hash-table +foo-intention+)) (i1 (make-instance 'foo :slot1 2)) (i2 (make-instance 'foo :slot1 3))) (is (eq (setf (htref ght i1) i2) i2)) (is (= (cnt ght) 1)))) (test htadd.test-1 (let ((ght (make-generalized-hash-table +foo-intention+)) (i1 (make-instance 'foo :slot1 2))) (is-true (htadd ght i1)) (is-true (htref ght i1)))) (test htadd.test-2 (let ((ght (make-generalized-hash-table +foo-intention+)) (i1 (make-instance 'foo :slot1 2))) (multiple-value-bind (a b) (htref ght i1) (is-false a) (is-false b)))) (test htadd.test-3 (let ((ght (make-generalized-hash-table +foo-intention+)) (i1 (make-instance 'foo :slot1 2)) (i2 (make-instance 'foo :slot1 3))) (htadd ght i1) (multiple-value-bind (a b) (htref ght i2) (is-false a) (is-false b)))) (test htpresent.test-1 (let ((ght (make-generalized-hash-table +foo-intention+)) (i1 (make-instance 'foo :slot1 2))) (htadd ght i1) (is (= (cnt ght) 1)) (is (htpresent ght i1)))) (test htpresent.test-2 (let ((ght (make-generalized-hash-table +foo-intention+)) (i1 (make-instance 'foo :slot1 2))) (is (= (cnt ght) 0)) (is-false (htpresent ght i1)))) (test htremove.test-1 (let ((ght (make-generalized-hash-table +foo-intention+)) (i1 (make-instance 'foo :slot1 2))) (is-false (htremove ght i1)) (is (= (cnt ght) 0)) (is-false (htref ght i1)))) (test htremove.test-2 (let ((ght (make-generalized-hash-table +foo-intention+)) (i1 (make-instance 'foo :slot1 2))) (htadd ght i1) (is-true (htremove ght i1)) (is-true (= (cnt ght) 0)) (is-false (htref ght i1)))) (test with-ht.test-1 (let ((ght (make-generalized-hash-table +foo-intention+)) (i1 (make-instance 'foo :slot1 2)) (i2 (make-instance 'foo :slot1 3)) l) (htadd ght i1) (htadd ght i2) (with-ht (k v) ght (push (cons k v) l)) (is (= (length l) 2)) (is (equal (assoc i1 l) (cons i1 t))) (is (equal (assoc i2 l) (cons i2 t))))) (test with-ht.test-2 (let ((ght (make-generalized-hash-table +foo-intention+)) l) (with-ht (k v) ght (push (cons k v) l)) (is-false l))) (test with-ht-collect.test-1 (let ((ght (make-generalized-hash-table +foo-intention+)) (i1 (make-instance 'foo :slot1 2)) (i2 (make-instance 'foo :slot1 3))) (htadd ght i1) (htadd ght i2) (let ((l (with-ht-collect (k v) ght (cons k v)))) (is (= (length l) 2)) (is (equal (assoc i1 l) (cons i1 t))) (is (equal (assoc i2 l) (cons i2 t)))))) (test with-ht-collect.test-2 (let ((ght (make-generalized-hash-table +foo-intention+))) (is-false (with-ht-collect (k v) ght (cons k v))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/Tests/rectangle-tests.lisp0000640000175000017500000003415610741375213022771 0ustar pdmpdm;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (cl:in-package :drei-tests) (def-suite rectangle-tests :description "The test suite for rectangle-editing related tests." :in drei-tests) (in-suite rectangle-tests) (test map-rectangle-lines (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (macrolet ((check (startcol endcol) `(progn (is-true (beginning-of-line-p mark)) (is (= (line-number mark) (incf line))) (is (> 4 line)) (is (= startcol ,startcol)) (is (= endcol ,endcol))))) (beginning-of-buffer (point)) (end-of-buffer (mark)) (let ((line -1)) (map-rectangle-lines (current-view) #'(lambda (mark startcol endcol) (check 0 16)) (point) (mark)) (is (= line 3))) (let ((line -1)) (map-rectangle-lines (current-view) #'(lambda (mark startcol endcol) (check 0 16)) (mark) (point)) (is (= line 3))) (setf (offset (point)) 2) (setf (offset (mark)) 63) (let ((line -1)) (map-rectangle-lines (current-view) #'(lambda (mark startcol endcol) (check 2 13)) (point) (mark)) (is (= line 3))) (let ((line -1)) (map-rectangle-lines (current-view) #'(lambda (mark startcol endcol) (check 2 13)) (mark) (point)) (is (= line 3))) (beginning-of-buffer (point)) (beginning-of-buffer (mark)) (let ((line -1)) (map-rectangle-lines (current-view) #'(lambda (mark startcol endcol) (check 0 0)) (point) (mark)) (is (= line 0)))))) (test extract-and-delete-rectangle-line (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer (point)) (end-of-buffer (mark)) (is (equal (map-rectangle-lines (current-view) #'extract-and-delete-rectangle-line (point) (mark)) '("Line number one " "Line number two " "Line number thre" "Line number four"))) (buffer-is " e ")) (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer (point)) (end-of-buffer (mark)) (beginning-of-line (mark)) (is (equal (map-rectangle-lines (current-view) #'extract-and-delete-rectangle-line (point) (mark)) '("" "" "" ""))) (buffer-is "Line number one Line number two Line number three Line number four")) (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer (point)) (forward-line (point) (current-syntax)) (forward-object (point) 5) (end-of-buffer (mark)) (backward-line (mark) (current-syntax)) (beginning-of-line (mark)) (forward-object (mark) 12) (is (equal (map-rectangle-lines (current-view) #'extract-and-delete-rectangle-line (point) (mark)) '("number " "number "))) (buffer-is "Line number one Line two Line three Line number four"))) (test open-rectangle-line (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer (point)) (end-of-buffer (mark)) (map-rectangle-lines (current-view) #'open-rectangle-line (point) (mark)) (buffer-is " Line number one Line number two Line number three Line number four")) (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer (point)) (end-of-buffer (mark)) (beginning-of-line (mark)) (map-rectangle-lines (current-view) #'open-rectangle-line (point) (mark)) (buffer-is "Line number one Line number two Line number three Line number four")) (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer (point)) (forward-line (point) (current-syntax)) (forward-object (point) 5) (end-of-buffer (mark)) (backward-line (mark) (current-syntax)) (beginning-of-line (mark)) (forward-object (mark) 12) (map-rectangle-lines (current-view) #'open-rectangle-line (point) (mark)) (buffer-is "Line number one Line number two Line number three Line number four"))) (test clear-rectangle-line (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer (point)) (end-of-buffer (mark)) (map-rectangle-lines (current-view) #'clear-rectangle-line (point) (mark)) (buffer-is " e ")) (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer (point)) (end-of-buffer (mark)) (beginning-of-line (mark)) (map-rectangle-lines (current-view) #'clear-rectangle-line (point) (mark)) (buffer-is "Line number one Line number two Line number three Line number four")) (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer (point)) (forward-line (point) (current-syntax)) (forward-object (point) 5) (end-of-buffer (mark)) (backward-line (mark) (current-syntax)) (beginning-of-line (mark)) (forward-object (mark) 12) (map-rectangle-lines (current-view) #'clear-rectangle-line (point) (mark)) (buffer-is "Line number one Line two Line three Line number four"))) (test delete-rectangle-line-whitespace (with-drei-environment (:initial-contents " Line number one Line number two Line number three Line number four") (beginning-of-buffer (point)) (end-of-buffer (mark)) (map-rectangle-lines (current-view) #'delete-rectangle-line-whitespace (point) (mark)) (buffer-is "Line number one Line number two Line number three Line number four")) (with-drei-environment (:initial-contents " Line number one Line number two Line number three Line number four") (beginning-of-buffer (point)) (end-of-buffer (mark)) (beginning-of-line (mark)) (map-rectangle-lines (current-view) #'delete-rectangle-line-whitespace (point) (mark)) (buffer-is "Line number one Line number two Line number three Line number four")) (with-drei-environment (:initial-contents " Line number one Line number two Line number three Line number four") (beginning-of-buffer (point)) (forward-line (point) (current-syntax)) (end-of-buffer (mark)) (backward-line (mark) (current-syntax)) (beginning-of-line (mark)) (map-rectangle-lines (current-view) #'delete-rectangle-line-whitespace (point) (mark)) (buffer-is " Line number one Line number two Line number three Line number four"))) (test replace-rectangle-line (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer (point)) (end-of-buffer (mark)) (map-rectangle-lines (current-view) #'(lambda (mark startcol endcol) (replace-rectangle-line mark startcol endcol "DREI")) (point) (mark)) (buffer-is "DREI DREI DREIe DREI")) (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer (point)) (end-of-buffer (mark)) (beginning-of-line (mark)) (map-rectangle-lines (current-view) #'(lambda (mark startcol endcol) (replace-rectangle-line mark startcol endcol "DREI")) (point) (mark)) (buffer-is "DREILine number one DREILine number two DREILine number three DREILine number four")) (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer (point)) (forward-line (point) (current-syntax)) (forward-object (point) 5) (end-of-buffer (mark)) (backward-line (mark) (current-syntax)) (beginning-of-line (mark)) (forward-object (mark) 12) (map-rectangle-lines (current-view) #'(lambda (mark startcol endcol) (replace-rectangle-line mark startcol endcol "DREI")) (point) (mark)) (buffer-is "Line number one Line DREItwo Line DREIthree Line number four"))) (test insert-in-rectangle-line (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer (point)) (end-of-buffer (mark)) (map-rectangle-lines (current-view) #'(lambda (mark startcol endcol) (insert-in-rectangle-line mark startcol endcol "DREI")) (point) (mark)) (buffer-is "DREILine number one DREILine number two DREILine number three DREILine number four")) (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer (point)) (end-of-buffer (mark)) (beginning-of-line (mark)) (map-rectangle-lines (current-view) #'(lambda (mark startcol endcol) (insert-in-rectangle-line mark startcol endcol "DREI")) (point) (mark)) (buffer-is "DREILine number one DREILine number two DREILine number three DREILine number four")) (with-drei-environment (:initial-contents "Line number one Line number two Line number three Line number four") (beginning-of-buffer (point)) (forward-line (point) (current-syntax)) (forward-object (point) 5) (end-of-buffer (mark)) (backward-line (mark) (current-syntax)) (beginning-of-line (mark)) (forward-object (mark) 12) (map-rectangle-lines (current-view) #'(lambda (mark startcol endcol) (insert-in-rectangle-line mark startcol endcol "DREI")) (point) (mark)) (buffer-is "Line number one Line DREInumber two Line DREInumber three Line number four"))) (test insert-rectangle-at-mark (macrolet ((check (before rectangle offset after) (check-type before string) (check-type rectangle list) (check-type after string) `(with-drei-environment (:initial-contents ,before) (setf (offset (point)) ,offset) (insert-rectangle-at-mark (current-view) (point) ,rectangle) (buffer-is ,after)))) (check "Line number one Line number two Line number three Line number four " '("Line number one " "Line number two " "Line number thre" "Line number four") 0 "Line number one Line number one Line number two Line number two Line number threLine number three Line number fourLine number four ") (check "Line number one Line number two Line number three Line number four " '("DREI " "CLIMACS") 20 "Line number one LineDREI number two LineCLIMACS number three Line number four ") (check "Line number one Line number two Line number three Line number four " '("DREI " "CLIMACS") 66 "Line number one Line number two Line number three Line number fourDREI CLIMACS "))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/Tests/base-tests.lisp0000640000175000017500000007222410741375213021735 0ustar pdmpdm;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; ;;; The test cases in this files test the functions of the DREI-BASE ;;; package built on top of the buffer protocol. (cl:in-package :drei-tests) (def-suite base-tests :description "The test suite for DREI-BASE related tests." :in drei-tests) (in-suite base-tests) (buffer-test previous-line (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs climacs") (let ((mark (make-buffer-mark buffer 16 :left))) (previous-line mark nil 2) (is (= (offset mark) 0)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs climacs") (let ((mark (make-buffer-mark buffer 19 :right))) (previous-line mark 2 2) (is (= (offset mark) 2)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") (let ((mark (make-buffer-mark buffer 7 :left))) (previous-line mark) (is (= (offset mark) 7)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") (let ((mark (make-buffer-mark buffer 7 :right))) (previous-line mark 2) (is (= (offset mark) 2)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") (let ((mark (make-buffer-mark buffer 0 :left))) (previous-line mark) (is (= (offset mark) 0)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") (let ((mark (make-buffer-mark buffer 0 :right))) (previous-line mark 2) (is (= (offset mark) 2)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs2") (let ((mark (make-buffer-mark buffer 15 :left))) (previous-line mark) (is (= (offset mark) 7))))) (buffer-test next-line (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs climacs") (let ((mark (make-buffer-mark buffer 6 :left))) (next-line mark nil 2) (is (= (offset mark) 22)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs climacs") (let ((mark (make-buffer-mark buffer 3 :right))) (next-line mark 2 2) (is (= (offset mark) 18)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") (let ((mark (make-buffer-mark buffer 8 :left))) (next-line mark) (is (= (offset mark) 8)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") (let ((mark (make-buffer-mark buffer 8 :right))) (is (next-line mark 2)) (= (offset mark) 10))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") (let ((mark (make-buffer-mark buffer 15 :left))) (next-line mark) (is (= (offset mark) 15)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") (let ((mark (make-buffer-mark buffer 15 :right))) (next-line mark 2) (is (= (offset mark) 10)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") (let ((mark (make-buffer-mark buffer 0 :left))) (next-line mark) (is (= (offset mark) 8))))) (buffer-test open-line (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((mark (make-buffer-mark buffer 0 :left))) (open-line mark 2) (is (string= (buffer-contents buffer) #.(format nil "~%~%climacs"))) (is (= (offset mark) 0)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((mark (make-buffer-mark buffer 0 :right))) (open-line mark) (is (string= (buffer-contents buffer) #. (format nil "~%climacs"))) (is (= (offset mark) 0)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((mark (make-buffer-mark buffer 7 :left))) (open-line mark) (is (string= (buffer-contents buffer) #.(format nil "climacs~%"))) (is (= (offset mark) 7)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((mark (make-buffer-mark buffer 7 :right))) (open-line mark) (is (string= (buffer-contents buffer) #.(format nil "climacs~%"))) (is (= (offset mark) 7))))) (buffer-test delete-line (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((mark (make-buffer-mark buffer 0 :left))) (delete-line mark) (is (string= (buffer-contents buffer) "")) (is (= (offset mark) 0)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((mark (make-buffer-mark buffer 0 :right))) (delete-line mark) (is (string= (buffer-contents buffer) "")) (is (= (offset mark) 0)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((mark (make-buffer-mark buffer 7 :left))) (delete-line mark) (is (string= (buffer-contents buffer) "climacs")) (is (= (offset mark) 7)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((mark (make-buffer-mark buffer 7 :right))) (delete-line mark) (values (buffer-contents buffer) (offset mark)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") (let ((mark (make-buffer-mark buffer 7 :left))) (delete-line mark) (is (string= (buffer-contents buffer) "climacsclimacs")) (is (= (offset mark) 7)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") (let ((mark (make-buffer-mark buffer 7 :right))) (delete-line mark) (is (string= (buffer-contents buffer) "climacsclimacs")) (is (= (offset mark) 7))))) (buffer-test empty-line-p (let* ((buffer (make-instance %%buffer)) (m1 (make-buffer-mark buffer 0 :left)) (m2 (make-buffer-mark buffer 0 :right))) (is-true (empty-line-p m1)) (is-true (empty-line-p m2))) (let ((buffer (make-instance %%buffer))) (insert-buffer-object buffer 0 #\a) (let ((m1 (make-buffer-mark buffer 0 :left)) (m2 (make-buffer-mark buffer 0 :right))) (is-false (empty-line-p m1)) (is-false (empty-line-p m2)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-object buffer 0 #\a) (let ((m1 (make-buffer-mark buffer 0 :left)) (m2 (make-buffer-mark buffer 0 :right))) (is-false (empty-line-p m1)) (is-false (empty-line-p m2)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "a b") (let ((m1 (make-buffer-mark buffer 0 :left)) (m2 (make-buffer-mark buffer 0 :right))) (setf (offset m1) 1 (offset m2) 1) (is-false (empty-line-p m1)) (is-false (empty-line-p m2))))) (buffer-test line-indentation (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 " climacs") (let ((m1 (make-buffer-mark buffer 0 :left)) (m2 (make-buffer-mark buffer 0 :right)) (m3 (make-buffer-mark buffer 10 :left)) (m4 (make-buffer-mark buffer 10 :right))) (is (= (line-indentation m1 8) 10)) (is (= (line-indentation m2 8) 10)) (is (= (line-indentation m3 8) 10)) (is (= (line-indentation m4 8) 10)) (is (= (offset m1) 0)) (is (= (offset m2) 0)) (is (= (offset m3) 10)) (is (= (offset m4) 10)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 " climacs") (let ((m1 (make-buffer-mark buffer 0 :left)) (m2 (make-buffer-mark buffer 0 :right)) (m3 (make-buffer-mark buffer 11 :left)) (m4 (make-buffer-mark buffer 11 :right))) (is (= (line-indentation m1 8) 18)) (is (= (line-indentation m2 8) 18)) (is (= (line-indentation m3 8) 18)) (is (= (line-indentation m4 8) 18)) (is (= (offset m1) 0)) (is (= (offset m2) 0)) (is (= (offset m3) 11)) (is (= (offset m4) 11)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 " climacs ") (let ((m1 (make-buffer-mark buffer 0 :left)) (m2 (make-buffer-mark buffer 0 :right)) (m3 (make-buffer-mark buffer 11 :left)) (m4 (make-buffer-mark buffer 11 :right))) (is (= (line-indentation m1 8) 10)) (is (= (line-indentation m2 8) 10)) (is (= (line-indentation m3 8) 10)) (is (= (line-indentation m4 8) 10)) (is (= (offset m1) 0)) (is (= (offset m2) 0)) (is (= (offset m3) 11)) (is (= (offset m4) 11))))) (buffer-test buffer-number-of-lines-in-region (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") (is (= (drei-base::buffer-number-of-lines-in-region buffer 0 6) 0)) (is (= (drei-base::buffer-number-of-lines-in-region buffer 0 7) 0)) (is (= (drei-base::buffer-number-of-lines-in-region buffer 0 8) 1)) (is (= (drei-base::buffer-number-of-lines-in-region buffer 0 10) 1)) (is (= (drei-base::buffer-number-of-lines-in-region buffer 0 13) 1)) (is (= (drei-base::buffer-number-of-lines-in-region buffer 0 14) 1)) (is (= (drei-base::buffer-number-of-lines-in-region buffer 7 10) 1)) (is (= (drei-base::buffer-number-of-lines-in-region buffer 8 13) 0)) (is (= (drei-base::buffer-number-of-lines-in-region buffer 8 14) 0)))) (buffer-test buffer-display-column (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 " cli macs") (is (= (buffer-display-column buffer 0 8) 0)) (is (= (buffer-display-column buffer 1 8) 8)) (is (= (buffer-display-column buffer 2 8) 16)) (is (= (buffer-display-column buffer 5 8) 19)) (is (= (buffer-display-column buffer 6 8) 24)))) (buffer-test number-of-lines-in-region (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 " climacs climacs ") (let ((m1l (make-buffer-mark buffer 0 :left)) (m1r (make-buffer-mark buffer 0 :right)) (m2l (make-buffer-mark buffer 1 :left)) (m2r (make-buffer-mark buffer 1 :right)) (m3l (make-buffer-mark buffer 3 :left)) (m3r (make-buffer-mark buffer 3 :right)) (m4l (make-buffer-mark buffer 8 :left)) (m4r (make-buffer-mark buffer 8 :right)) (m5l (make-buffer-mark buffer 15 :left)) (m5r (make-buffer-mark buffer 15 :right)) (m6l (make-buffer-mark buffer 16 :left)) (m6r (make-buffer-mark buffer 16 :right))) (is (= (number-of-lines-in-region m1l m1r) 0)) (is (= (number-of-lines-in-region m1r m1l) 0)) (is (= (number-of-lines-in-region m1l m2l) 1)) (is (= (number-of-lines-in-region m2r m1r) 1)) (is (= (number-of-lines-in-region m1l m2r) 1)) (is (= (number-of-lines-in-region m2r m1l) 1)) (is (= (number-of-lines-in-region m1r m2l) 1)) (is (= (number-of-lines-in-region m1l m3l) 1)) (is (= (number-of-lines-in-region m1r m3r) 1)) (is (= (number-of-lines-in-region m4r m1l) 1)) (is (= (number-of-lines-in-region m4l m1r) 1)) (is (= (number-of-lines-in-region m3l m5l) 1)) (is (= (number-of-lines-in-region m5r m4r) 1)) (is (= (number-of-lines-in-region m5l m6l) 0)) (is (= (number-of-lines-in-region m6r m5r) 0)) (is (= (number-of-lines-in-region m6l m6r) 0)) (is (= (number-of-lines-in-region m1l m6r) 2)) (is (= (number-of-lines-in-region m3r m6l) 1)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") (let ((m1l (make-buffer-mark buffer 6 :left)) (m1r (make-buffer-mark buffer 6 :right)) (m2l (make-buffer-mark buffer 7 :left)) (m2r (make-buffer-mark buffer 7 :right))) (is (= (number-of-lines-in-region m1l 10) 1)) (is (= (number-of-lines-in-region 10 m1l) 1)) (is (= (number-of-lines-in-region m1r 10) 1)) (is (= (number-of-lines-in-region 10 m1r) 1)) (is (= (number-of-lines-in-region m1l 3) 0)) (is (= (number-of-lines-in-region 3 m2l) 0)) (is (= (number-of-lines-in-region 3 m2r) 0)) (is (= (number-of-lines-in-region m2l 10) 1)) (is (= (number-of-lines-in-region 10 m2r) 1))))) (test constituentp ; NOTE: more tests may be needed for sbcl (is-true (constituentp #\a)) (is-false (constituentp #\Newline)) (is-false (constituentp #\Space)) (is-false (constituentp #\Tab)) (is-false (constituentp "a")) (is-false (constituentp #\Null))) (test buffer-whitespacep (is-false (buffer-whitespacep #\a)) (is-true (buffer-whitespacep #\Newline)) (is-true (buffer-whitespacep #\Space)) (is-true (buffer-whitespacep #\Tab)) (is-false (buffer-whitespacep " ")) (is-false (buffer-whitespacep #\Null))) (buffer-test downcase-buffer-region (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 #.(format nil "CLi~Amac5" #\Tab)) (drei-base::downcase-buffer-region buffer 1 (size buffer)) (is (string= (buffer-contents buffer) "Cli mac5")))) (buffer-test downcase-region (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 #.(format nil "_CLi~Amac5_" #\Tab)) (let ((m1 (make-buffer-mark buffer 1 :left)) (m2 (make-buffer-mark buffer 8 :right))) (downcase-region m2 m1) (is (string= (buffer-contents buffer) #.(format nil "_cli~Amac5_" #\Tab))))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 #.(format nil "_CLi~Amac5_" #\Tab)) (let ((m1 (make-buffer-mark buffer 1 :right))) (downcase-region 8 m1) (is (string= (buffer-contents buffer) #.(format nil "_cli~Amac5_" #\Tab))))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 #.(format nil "_CLi~Amac5_" #\Tab)) (let ((m1 (make-buffer-mark buffer 8 :left))) (downcase-region 1 m1) (is (string= (buffer-contents buffer) #.(format nil "_cli~Amac5_" #\Tab)))))) (buffer-test upcase-buffer-region (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 #.(format nil "_cli~Amac5_" #\Tab)) (drei-base::upcase-buffer-region buffer 1 (size buffer)) (is (string= (buffer-contents buffer) #.(format nil "_CLI~AMAC5_" #\Tab))))) (buffer-test upcase-region (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 #.(format nil "_cli~Amac5_" #\Tab)) (let ((m1 (make-buffer-mark buffer 1 :left)) (m2 (make-buffer-mark buffer 8 :right))) (upcase-region m2 m1) (is (string= (buffer-contents buffer) #.(format nil "_CLI~AMAC5_" #\Tab))))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 #.(format nil "_Cli~Amac5_" #\Tab)) (let ((m1 (make-buffer-mark buffer 1 :right))) (upcase-region 8 m1) (is (string= (buffer-contents buffer) #.(format nil "_CLI~AMAC5_" #\Tab))))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 #.(format nil "_Cli~Amac5_" #\Tab)) (let ((m1 (make-buffer-mark buffer 8 :left))) (upcase-region 1 m1) (is (string= (buffer-contents buffer) #.(format nil "_CLI~AMAC5_" #\Tab)))))) (buffer-test capitalize-buffer-region (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "cli ma cs") (drei-base::capitalize-buffer-region buffer 1 (size buffer)) (is (string= (buffer-contents buffer) "cLi Ma Cs"))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "CLI mA Cs") (drei-base::capitalize-buffer-region buffer 0 (size buffer)) (is (string= (buffer-contents buffer) "Cli Ma Cs")))) (buffer-test capitalize-region (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 #. (format nil "_Cli~Amac5_" #\Tab)) (let ((m1 (make-buffer-mark buffer 1 :left)) (m2 (make-buffer-mark buffer 8 :right))) (capitalize-region m2 m1) (is (string= (buffer-contents buffer) #.(format nil "_Cli~AMac5_" #\Tab))))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 #.(format nil "_Cli~Amac5_" #\Tab)) (let ((m1 (make-buffer-mark buffer 1 :right))) (capitalize-region 8 m1) (is (string= (buffer-contents buffer) #.(format nil "_Cli~AMac5_" #\Tab))))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 #.(format nil "_Cli~Amac5_" #\Tab)) (let ((m1 (make-buffer-mark buffer 8 :left))) (capitalize-region 1 m1) (is (string= (buffer-contents buffer) #.(format nil "_Cli~AMac5_" #\Tab)))))) (buffer-test tabify-buffer-region (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "c l im acs") (drei-base::tabify-buffer-region buffer 0 (size buffer) 8) (is (string= (buffer-contents buffer) #.(format nil "c~Al~Aim~A~Aacs" #\Tab #\Tab #\Tab #\Tab)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "c l im acs") (drei-base::tabify-buffer-region buffer 0 (size buffer) 8) (is (string= (buffer-contents buffer) #.(format nil "c l im~A acs" #\Tab))))) (buffer-test tabify-region (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "clim acs") (let ((m1 (make-buffer-mark buffer 3 :left)) (m2 (make-buffer-mark buffer 7 :right))) (tabify-region m2 m1 4) (is (string= (buffer-contents buffer) #. (format nil "clim~Aacs" #\Tab))))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "clim acs") (let ((m1 (make-buffer-mark buffer 3 :right))) (tabify-region 7 m1 4) (is (string= (buffer-contents buffer) #.(format nil "clim~Aacs" #\Tab))))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "clim acs") (let ((m1 (make-buffer-mark buffer 7 :left))) (tabify-region 3 m1 4) (is (string= (buffer-contents buffer) #.(format nil "clim~Aacs" #\Tab)))))) (buffer-test untabify-buffer-region (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 #.(format nil "c~Al~Aim~A~Aacs" #\Tab #\Tab #\Tab #\Tab)) (drei-base::untabify-buffer-region buffer 0 (size buffer) 8) (is (string= (buffer-contents buffer) "c l im acs"))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 #.(format nil "c l im~A acs" #\Tab)) (drei-base::untabify-buffer-region buffer 0 (size buffer) 8) (is (string= (buffer-contents buffer) "c l im acs"))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 #.(format nil "clim~Aacs" #\Tab)) (let ((m1 (make-buffer-mark buffer 0 :left)) (m2 (make-buffer-mark buffer 0 :right))) (setf (offset m1) 3 (offset m2) 5) (untabify-region m2 m1 4) (is (string= (buffer-contents buffer) "clim acs")))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 #.(format nil "clim~Aacs" #\Tab)) (let ((m1 (make-buffer-mark buffer 0 :right))) (setf (offset m1) 3) (untabify-region 5 m1 4) (is (string= (buffer-contents buffer) "clim acs")))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 #.(format nil "clim~Aacs" #\Tab)) (let ((m1 (make-buffer-mark buffer 0 :left))) (setf (offset m1) 5) (untabify-region 3 m1 4) (is (string= (buffer-contents buffer) "clim acs"))))) (buffer-test indent-line (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 #.(format nil " ~Aclimacs " #\Tab)) (let ((m (make-buffer-mark buffer 3 :left))) (indent-line m 4 nil) (is (= (offset m) 0)) (is (string= (buffer-contents buffer) " climacs ")))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 " climacs ") (let ((m (make-buffer-mark buffer 4 :left))) (indent-line m 5 4) (is (= (offset m) 3)) (is (string= (buffer-contents buffer) #.(format nil "~A climacs " #\Tab))))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 " climacs ") (let ((m (make-buffer-mark buffer 3 :right))) (indent-line m 5 4) (is (= (offset m) 2)) (is (string= (buffer-contents buffer) #.(format nil "~A climacs " #\Tab)))))) (buffer-test buffer-looking-at (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs ") (is-true (buffer-looking-at buffer 0 "climacs")) (is-true (buffer-looking-at buffer 0 "CLIMACS" :test #'char-equal)) (is-true (buffer-looking-at buffer 0 "")) (is-true (buffer-looking-at buffer 8 "")) (is-false (buffer-looking-at buffer 9 "")) (is-false (buffer-looking-at buffer 10 ""))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 " climacs") (is-false (buffer-looking-at buffer 0 "climacs"))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climac") (is-false (buffer-looking-at buffer 0 "climacs"))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((m1 (make-buffer-mark buffer 1 :left)) (m2 (make-buffer-mark buffer 3 :right))) (is-true (looking-at m1 "lima")) (is-true (looking-at m2 "mac")) (is-true (looking-at m1 "lIMa" :test #'char-equal)) (is-true (looking-at m2 "Mac" :test #'char-equal)) (is-false (looking-at m1 "climacs")) (is-false (looking-at m2 "climacs")) (is-true (looking-at m1 "")) (is-true (looking-at m2 "")) (is (= (offset m1) 1)) (is (= (offset m2) 3))))) (buffer-test buffer-search-forward (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 " climacs") (is (= (buffer-search-forward buffer 0 "clim") 1)) (is (= (buffer-search-forward buffer 0 "CLIM" :test #'char-equal) 1)) (is (= (buffer-search-forward buffer 0 "macs") 4)) (is (= (buffer-search-forward buffer 0 "") 0)) (is-false (buffer-search-forward buffer 2 "clim")) (is (= (buffer-search-forward buffer 8 "") 8)) (is-false (buffer-search-forward buffer 9 "")) (is-false (buffer-search-forward buffer 10 "")))) (buffer-test buffer-search-backward (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs ") (is (= (buffer-search-backward buffer 8 "macs") 3)) (is (= (buffer-search-backward buffer 8 "MACS" :test #'char-equal) 3)) (is (= (buffer-search-backward buffer 4 "clim") 0)) (is (= (buffer-search-backward buffer 8 "") 8)) (is-false (buffer-search-backward buffer 6 "macs")) (is-false (buffer-search-backward buffer -1 "")) (is (= (buffer-search-backward buffer 0 "") 0)) (is (= (buffer-search-backward buffer 1 "") 1)))) (buffer-test buffer-re-search-forward (let ((buffer (make-instance %%buffer)) (a1 (automaton::determinize (regexp-automaton (string-regexp "i[mac]+s")))) (a2 (automaton::determinize (regexp-automaton (string-regexp "[^aeiou][aeiou]")))) (a3 (regexp-automaton (string-regexp "imacs")))) (insert-buffer-sequence buffer 0 " climacs") (is (equal (multiple-value-list (buffer-re-search-forward a1 buffer 0)) '(3 8))) (is (equal (multiple-value-list (buffer-re-search-forward a2 buffer 1)) '(2 4))) (is (equal (multiple-value-list (buffer-re-search-forward a3 buffer 1)) '(3 8))) (is-false (buffer-re-search-forward a1 buffer 4)) (is-false (buffer-re-search-forward a2 buffer 6)) (is-false (buffer-re-search-forward a3 buffer 6)))) (buffer-test buffer-re-search-backward (let ((buffer (make-instance %%buffer)) (a1 (drei-base::reversed-deterministic-automaton (regexp-automaton (string-regexp "i[ma]+c")))) (a2 (drei-base::reversed-deterministic-automaton (regexp-automaton (string-regexp "[^aeiou][aeiou]")))) (a3 (regexp-automaton (string-regexp "cami")))) (insert-buffer-sequence buffer 0 " climacs") (is (equal (multiple-value-list (buffer-re-search-backward a1 buffer 7)) '(3 7))) (is (equal (multiple-value-list (buffer-re-search-backward a2 buffer 7)) '(4 6))) (is (equal (multiple-value-list (buffer-re-search-backward a3 buffer 7)) '(3 7))) (is-false (buffer-re-search-backward a1 buffer 5)) (is-false (buffer-re-search-backward a2 buffer 2)) (is-false (buffer-re-search-backward a3 buffer 5)))) (buffer-test search-forward (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 " climacs") (let ((m (make-buffer-mark buffer 0 :left))) (search-forward m "Mac" :test #'char-equal) (is (= (offset m) 7)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((m (make-buffer-mark buffer 3 :right))) (search-forward m "Mac" :test #'char-equal) (is (= (offset m) 6)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((m (make-buffer-mark buffer 3 :right))) (search-forward m "klimaks") (is (= (offset m) 3))))) (buffer-test search-backward (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs ") (let ((m (make-buffer-mark buffer 8 :left))) (search-backward m "Mac" :test #'char-equal) (is (= (offset m) 3)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((m (make-buffer-mark buffer 6 :right))) (search-backward m "Mac" :test #'char-equal) (is (= (offset m) 3)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((m (make-buffer-mark buffer 3 :right))) (search-backward m "klimaks") (is (= (offset m) 3))))) (buffer-test re-search-forward (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 " climacs") (let ((m (make-buffer-mark buffer 0 :left))) (re-search-forward m "[mac]{3}") (is (= (offset m) 7)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((m (make-buffer-mark buffer 3 :right))) (re-search-forward m "[mac]{3}") (is (= (offset m) 6)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((m (make-buffer-mark buffer 3 :right))) (re-search-forward m "klimaks") (is (= (offset m) 3))))) (buffer-test re-search-backward (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs ") (let ((m (make-buffer-mark buffer 8 :left))) (re-search-backward m "[mac]{3}") (is (= (offset m) 3)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((m (make-buffer-mark buffer 6 :right))) (re-search-backward m "[mac]{3}") (is (= (offset m) 3)))) (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((m (make-buffer-mark buffer 3 :right))) (re-search-backward m "klimaks") (is (= (offset m) 3))))) (buffer-test buffer-search-word-forward (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 " climacs") (is (= (buffer-search-word-forward buffer 0 "climacs") 2)) (is-false (buffer-search-word-forward buffer 3 "climacs")) (is-false (buffer-search-word-forward buffer 0 "clim")) (is-false (buffer-search-word-forward buffer 5 "macs")) (is (= (buffer-search-word-forward buffer 0 "") 0)))) (buffer-test buffer-search-word-backward (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs ") (is (= (buffer-search-word-backward buffer 8 "climacs") 0)) (is-false (buffer-search-word-backward buffer 5 "climacs")) (is-false (buffer-search-word-backward buffer 4 "clim")) (is-false (buffer-search-word-backward buffer 8 "macs")) (is (= (buffer-search-word-backward buffer 8 "") 8)))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/Tests/core-tests.lisp0000644000175000017500000004311311345155772021761 0ustar pdmpdm;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (cl:in-package :drei-tests) (def-suite core-tests :description "The test suite for DREI-CORE related tests." :in drei-tests) (in-suite core-tests) (test possibly-fill-line (with-drei-environment () (possibly-fill-line) (is (string= (buffer-contents) ""))) (with-drei-environment (:initial-contents "Very long line, this should be filled, if auto-fill is on.") (setf (auto-fill-column (current-view)) 200 (auto-fill-mode (current-view)) nil (offset (point)) (size (current-buffer))) (possibly-fill-line) (is (string= (buffer-contents) "Very long line, this should be filled, if auto-fill is on.")) (setf (auto-fill-mode (current-view)) t) (possibly-fill-line) (is (string= (buffer-contents) "Very long line, this should be filled, if auto-fill is on.")) (setf (auto-fill-column (current-view)) 20) (possibly-fill-line) (is (string= (buffer-contents) "Very long line, this should be filled, if auto-fill is on.")))) (test back-to-indentation (with-drei-environment (:initial-contents #.(format nil " ~A Foobar!" #\Tab)) (end-of-buffer (point)) (back-to-indentation (point) (current-syntax)) (is (= (offset (point)) 4)))) (test insert-character ;; Test: ;; - Overwriting ;; - Auto-filling ;; - Standard insertion (with-drei-environment () (setf (auto-fill-mode (current-view)) nil (overwrite-mode (current-view)) nil) (insert-character #\a) (is (string= (buffer-contents) "a")) (insert-character #\b) (is (string= (buffer-contents) "ab")) (backward-object (point) 2) (insert-character #\t) (is (string= (buffer-contents) "tab")) (setf (overwrite-mode (current-view)) t) (insert-character #\i) (insert-character #\p) (is (string= (buffer-contents) "tip")) ;; TODO: Also test dynamic abbreviations? )) (test delete-horizontal-space (with-drei-environment (:initial-contents " foo") (setf (offset (point)) 3) (delete-horizontal-space (point) (current-syntax)) (is (string= (buffer-contents) "foo")) (insert-sequence (point) " ") (setf (offset (point)) 3) (delete-horizontal-space (point) (current-syntax) t) (is (string= (buffer-contents) " foo")) (delete-horizontal-space (point) (current-syntax)) (is (string= (buffer-contents) "foo")) (delete-horizontal-space (point) (current-syntax)) (is (string= (buffer-contents) "foo")))) (test indent-current-line (with-drei-environment (:initial-contents "Foo bar baz Quux") (indent-current-line (current-view) (point)) (is (string= (buffer-contents) "Foo bar baz Quux")) (setf (offset (point)) 12) (indent-current-line (current-view) (point)) (is (string= (buffer-contents) "Foo bar baz Quux")))) (test insert-pair (with-drei-environment () (insert-pair (mark) (current-syntax)) (buffer-is "()") (beginning-of-buffer (point)) (insert-pair (point) (current-syntax) 0 #\[ #\]) (buffer-is "[] ()"))) (test goto-position (with-drei-environment (:initial-contents "foobarbaz") (goto-position (point) 5) (is (= (offset (point)) 5)))) (test goto-line (with-drei-environment (:initial-contents "First line Second line Third line") (goto-line (point) 1) (is (= (line-number (point)) 0)) (is (= (offset (point)) 0)) (goto-line (point) 2) (is (= (line-number (point)) 1)) (is (= (offset (point)) 11)) (goto-line (point) 3) (is (= (line-number (point)) 2)) (is (= (offset (point)) 23)) (goto-line (point) 4) (is (= (line-number (point)) 2)) (is (= (offset (point)) 23)))) (test replace-one-string (with-drei-environment (:initial-contents "Drei Climacs Drei") (replace-one-string (point) 17 "foo bar" nil) (buffer-is "foo bar")) (with-drei-environment (:initial-contents "drei climacs drei") (replace-one-string (point) 17 "foo bar" t) (buffer-is "foo bar")) (with-drei-environment (:initial-contents "Drei Climacs Drei") (replace-one-string (point) 17 "foo bar" t) (buffer-is "Foo Bar")) (with-drei-environment (:initial-contents "DREI CLIMACS DREI") (replace-one-string (point) 17 "foo bar" t) (buffer-is "FOO BAR"))) (test downcase-word (with-drei-environment () (downcase-word (point) (current-syntax) 1) (is (string= (buffer-contents) ""))) (with-drei-environment (:initial-contents "Drei Climacs Drei") (downcase-word (point) (current-syntax) 1) (buffer-is "drei Climacs Drei") (downcase-word (point) (current-syntax) 1) (buffer-is "drei climacs Drei") (downcase-word (point) (current-syntax) 1) (buffer-is "drei climacs drei")) (with-drei-environment (:initial-contents "Drei Climacs Drei") (downcase-word (point) (current-syntax) 0) (buffer-is "Drei Climacs Drei")) (with-drei-environment (:initial-contents "Drei Climacs Drei") (downcase-word (point) (current-syntax) 2) (buffer-is "drei climacs Drei")) (with-drei-environment (:initial-contents "Drei Climacs Drei") (downcase-word (point) (current-syntax) 3) (buffer-is "drei climacs drei")) (with-drei-environment (:initial-contents "CLI MA CS CLIMACS") (downcase-word (point) (current-syntax) 3) (is (buffer-is "cli ma cs CLIMACS")) (is (= 9 (offset (point)))))) (test upcase-word (with-drei-environment () (upcase-word (point) (current-syntax) 1) (is (string= (buffer-contents) ""))) (with-drei-environment (:initial-contents "Drei Climacs Drei") (upcase-word (point) (current-syntax) 1) (buffer-is "DREI Climacs Drei") (upcase-word (point) (current-syntax) 1) (buffer-is "DREI CLIMACS Drei") (upcase-word (point) (current-syntax) 1) (buffer-is "DREI CLIMACS DREI")) (with-drei-environment (:initial-contents "Drei Climacs Drei") (upcase-word (point) (current-syntax) 0) (buffer-is "Drei Climacs Drei")) (with-drei-environment (:initial-contents "Drei Climacs Drei") (upcase-word (point) (current-syntax) 2) (buffer-is "DREI CLIMACS Drei")) (with-drei-environment (:initial-contents "Drei Climacs Drei") (upcase-word (point) (current-syntax) 3) (buffer-is "DREI CLIMACS DREI")) (with-drei-environment (:initial-contents "cli ma cs climacs") (let ((m (clone-mark (point) :right))) (setf (offset m) 0) (upcase-word m (current-syntax) 3) (is (string= (buffer-contents) "CLI MA CS climacs")) (is (= (offset m) 9))))) (test capitalize-word (with-drei-environment () (capitalize-word (point) (current-syntax) 1) (is (string= (buffer-contents) ""))) (with-drei-environment (:initial-contents "drei climacs drei") (capitalize-word (point) (current-syntax) 1) (buffer-is "Drei climacs drei") (capitalize-word (point) (current-syntax) 1) (buffer-is "Drei Climacs drei") (capitalize-word (point) (current-syntax) 1) (buffer-is "Drei Climacs Drei")) (with-drei-environment (:initial-contents "drei climacs drei") (capitalize-word (point) (current-syntax) 0) (buffer-is "drei climacs drei")) (with-drei-environment (:initial-contents "drei climacs drei") (capitalize-word (point) (current-syntax) 2) (buffer-is "Drei Climacs drei")) (with-drei-environment (:initial-contents "drei climacs drei") (capitalize-word (point) (current-syntax) 3) (buffer-is "Drei Climacs Drei")) (with-drei-environment ( :initial-contents "cli ma cs climacs") (let ((m (clone-mark (point) :right))) (setf (offset m) 0) (capitalize-word m (current-syntax) 3) (is (string= (buffer-contents) "Cli Ma Cs climacs")) (is (= (offset m) 9))))) (test indent-region ;; FIXME: Sadly, we can't test this function, because it requires a ;; CLIM pane. ) (test fill-line (flet ((fill-it (fill-column) (fill-line (point) (lambda (mark) (proper-line-indentation (current-view) mark)) fill-column (tab-space-count (current-view)) (current-syntax)))) (with-drei-environment (:initial-contents "climacs climacs climacs climacs") (let ((m (clone-mark (point) :right))) (setf (offset m) 25) (fill-line m #'(lambda (m) (declare (ignore m)) 8) 10 8 (current-syntax)) (is (= (offset m) 25)) (buffer-is "climacs climacs climacs climacs"))) (with-drei-environment (:initial-contents "climacs climacs climacs climacs") (let ((m (clone-mark (point) :right))) (setf (offset m) 25) (fill-line m #'(lambda (m) (declare (ignore m)) 8) 10 8 (current-syntax) nil) (is (= (offset m) 27)) (buffer-is "climacs climacs climacs climacs"))) (with-drei-environment (:initial-contents #.(format nil "climacs~Aclimacs~Aclimacs~Aclimacs" #\Tab #\Tab #\Tab)) (let ((m (clone-mark (point) :left))) (setf (offset m) 25) (fill-line m #'(lambda (m) (declare (ignore m)) 8) 10 8 (current-syntax)) (is (= (offset m) 27)) (buffer-is "climacs climacs climacs climacs"))) (with-drei-environment (:initial-contents #.(format nil "climacs~Aclimacs~Aclimacs~Aclimacs" #\Tab #\Tab #\Tab)) (let ((m (clone-mark (point) :left))) (setf (offset m) 25) (fill-line m #'(lambda (m) (declare (ignore m)) 8) 10 8 (current-syntax)) (is (= (offset m) 27)) (buffer-is "climacs climacs climacs climacs"))) (with-drei-environment (:initial-contents "c l i m a c s") (let ((m (clone-mark (point) :right))) (setf (offset m) 1) (fill-line m #'(lambda (m) (declare (ignore m)) 8) 0 8 (current-syntax)) (is (= (offset m) 1)) (buffer-is "c l i m a c s"))) (with-drei-environment (:initial-contents "c l i m a c s") (let ((m (clone-mark (point) :right))) (setf (offset m) 1) (fill-line m #'(lambda (m) (declare (ignore m)) 8) 0 8 (current-syntax) nil) (is (= (offset m) 1)) (buffer-is "c l i m a c s"))) (with-drei-environment () (fill-it 80) (buffer-is "")) (with-drei-environment (:initial-contents "Very long line, this should certainly be filled, if everything works") (end-of-buffer (point)) (fill-it 200) (buffer-is "Very long line, this should certainly be filled, if everything works") (fill-it 20) (buffer-is "Very long line, this should certainly be filled, if everything works")))) (test fill-region (flet ((fill-it (fill-column) (fill-region (point) (mark) (lambda (mark) (proper-line-indentation (current-view) mark)) fill-column (tab-space-count (current-view)) (current-syntax)))) (with-drei-environment (:initial-contents "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum. What, you thought I would write something this long myself? Not a chance. Though this line is growing by a fair bit too, I better test it as well.") (end-of-line (mark)) (fill-it 80) (buffer-is "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum. What, you thought I would write something this long myself? Not a chance. Though this line is growing by a fair bit too, I better test it as well.") (end-of-buffer (mark)) (forward-paragraph (point) (current-syntax) 2 nil) (backward-paragraph (point) (current-syntax) 1) (fill-it 80) (buffer-is "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum. What, you thought I would write something this long myself? Not a chance. Though this line is growing by a fair bit too, I better test it as well.")))) (test indent-line (dolist (stick-to '(:left :right)) (with-drei-environment () (buffer-is "")) (with-drei-environment (:initial-contents "I am to be indented") (indent-line (clone-mark (point) stick-to) 11 nil) (buffer-is " I am to be indented")) (with-drei-environment (:initial-contents "I am to be indented") (indent-line (clone-mark (point) stick-to) 11 2) (buffer-is #. (format nil "~A~A~A~A~A I am to be indented" #\Tab #\Tab #\Tab #\Tab #\Tab))))) (test delete-indentation (with-drei-environment (:initial-contents "") (delete-indentation (current-syntax) (point)) (buffer-is "")) (with-drei-environment (:initial-contents "Foo") (delete-indentation (current-syntax) (point)) (buffer-is "Foo")) (with-drei-environment (:initial-contents " Foo") (delete-indentation (current-syntax) (point)) (buffer-is "Foo")) (with-drei-environment (:initial-contents " Foo ") (delete-indentation (current-syntax) (point)) (buffer-is "Foo ")) (with-drei-environment (:initial-contents " Foo Bar Baz") (forward-line (point) (current-syntax)) (delete-indentation (current-syntax) (point)) (buffer-is " Foo Bar Baz")) (with-drei-environment (:initial-contents " foo bar") (let ((start (clone-mark (point (current-view)))) (end (clone-mark (point (current-view)))) (orig-contents (buffer-contents))) (beginning-of-buffer start) (end-of-buffer end) (do-buffer-region-lines (line start end) (delete-indentation (current-syntax) line)) (buffer-is orig-contents)))) (test join-line (with-drei-environment (:initial-contents " climacs ") (let ((m (clone-mark (point) :left))) (setf (offset m) 3) (join-line (current-syntax) m) (is (= (offset m) 0)) (buffer-is "climacs "))) (with-drei-environment (:initial-contents " climacs ") (let ((m (clone-mark (point) :right))) (setf (offset m) 7) (join-line (current-syntax) m) (is (= (offset m) 0)) (buffer-is "climacs "))) (with-drei-environment (:initial-contents " climacs ") (let ((m (clone-mark (point) :left))) (setf (offset m) 7) (join-line (current-syntax) m) (is (= (offset m) 0)) (buffer-is " climacs "))) (with-drei-environment (:initial-contents "climacs climacs ") (let ((m (clone-mark (point) :right))) (setf (offset m) 12) (join-line (current-syntax) m) (is (= (offset m) 8)) (buffer-is "climacs climacs "))) (with-drei-environment (:initial-contents " climacs ") (let ((m (clone-mark (point) :right))) (setf (offset m) 12) (join-line (current-syntax) m) (is (= (offset m) 0)) (buffer-is "climacs ")))) (test set-syntax (dolist (syntax-designator `("Lisp" drei-lisp-syntax::lisp-syntax ,(find-class 'drei-lisp-syntax::lisp-syntax))) (with-drei-environment () (let ((old-syntax (current-syntax))) (set-syntax (current-view) syntax-designator) (is (not (eq old-syntax (current-syntax)))) (is (typep (current-syntax) 'drei-lisp-syntax::lisp-syntax)))))) (test with-narrowed-buffer (with-drei-environment (:initial-contents "foo bar baz quux") (setf (offset (point)) 1 (offset (mark)) (1- (size (current-buffer)))) (let ((mark1 (clone-mark (point) :left)) (mark2 (clone-mark (mark) :right))) (forward-object mark1) (backward-object mark2) (dolist (low (list 2 mark1)) (dolist (high (list (- (size (current-buffer)) 2) mark2)) (with-narrowed-buffer ((drei-instance) low high t) (is (= (offset (point)) 2)) (is (= (offset (mark)) (- (size (current-buffer)) 2))))))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/Tests/testing.lisp0000644000175000017500000001173611345155772021354 0ustar pdmpdm;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (cl:in-package :drei-tests) ;; Define some stuff to ease the pain of writing repetitive test ;; cases. Also provide global test-suite and test-running entry point. (defclass delegating-standard-buffer (delegating-buffer) () (:default-initargs :implementation (make-instance 'standard-buffer))) (eval-when (:load-toplevel :compile-toplevel :execute) (defparameter *buffer-classes* '((standard-buffer) (delegating-standard-buffer) (binseq-buffer persistent-left-sticky-mark persistent-right-sticky-mark) (obinseq-buffer persistent-left-sticky-mark persistent-right-sticky-mark) (binseq2-buffer persistent-left-sticky-line-mark persistent-right-sticky-line-mark)))) (defmacro buffer-test (name &body body) "Define FiveAM tests for all the standard buffer classes. %%BUFFER in `body' will be substituted for a buffer class, %%LEFT-STICKY-MARK will be substituted for a left-sticky-mark class and %%RIGHT-STICKY-MARK will be substituted for a right sticky mark class." (let (result) (dolist (class-spec *buffer-classes*) (destructuring-bind (buffer &optional (left-sticky-mark 'standard-left-sticky-mark) (right-sticky-mark 'standard-right-sticky-mark)) class-spec (let ((alist (list (cons '%%buffer `',buffer) (cons '%%left-sticky-mark `',left-sticky-mark) (cons '%%right-sticky-mark `',right-sticky-mark)))) (push `(test ,(intern (concatenate 'string (symbol-name buffer) "-" (symbol-name name))) ,@(sublis alist body)) result)))) (list* 'progn result))) (defmacro with-buffer ((buffer &key (initial-contents "")) &body body) `(let ((,buffer (make-instance 'drei-buffer :initial-contents ,initial-contents))) ,@body)) (defmacro with-view ((view &key (buffer (make-instance 'drei-buffer)) (syntax ''drei-fundamental-syntax:fundamental-syntax)) &body body) (once-only (buffer) `(let ((,view (make-instance 'textual-drei-syntax-view :buffer ,buffer))) (setf (syntax ,view) (make-syntax-for-view ,view ,syntax)) ,@body))) (defun buffer-contents (&optional (buffer (current-buffer))) "The contents of `(current-buffer)' as a string." (buffer-substring buffer 0 (size buffer))) (defun buffer-is (string &optional (buffer (current-buffer)) (begin-offset 0) (end-offset (size buffer))) "Check (using FiveAM) whether `buffer' contains `string' in the subsequence delimited by `begin-offset' and `end-offset'." (is (string= string (buffer-substring buffer begin-offset end-offset)))) (defclass test-drei (drei) () (:documentation "An instantiable Drei variant with no display. Used for testing.") (:metaclass modual-class) (:default-initargs :no-cursors t)) (defmacro with-drei-environment ((&key (initial-contents "") (syntax ''drei-fundamental-syntax:fundamental-syntax)) &body body) (with-gensyms (buffer view drei) `(with-buffer (,buffer :initial-contents ,initial-contents) (with-view (,view :buffer ,buffer :syntax ,syntax) (let ((,drei (make-instance 'test-drei :view ,view))) (with-bound-drei-special-variables (,drei :minibuffer nil) ,@body)))))) (def-suite drei-tests :description "The test suite for all Drei test cases. Has nested test suites for the actual tests.") (defun run-tests () "Run the Drei test suite. A dot will be printed for each passed test, a \"f\" for each failed test, a \"X\" for each test that causes an error, and an \"s\" for each skipped test." (run! 'drei-tests)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/motion.lisp0000644000175000017500000004717711345155772020112 0ustar pdmpdm;;; -*- Mode: Lisp; Package: DREI-MOTION; -*- ;;; (c) copyright 2006 by ;;; Taylor R. Campbell (campbell@mumble.net) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Drei Motion ;;; A basic motion function is a function named FORWARD-ONE-' or ;;; BACKWARD-ONE- of the signature ( ) that ;;; returns true if any motion happened or false if a limit was ;;; reached. ;;; ;;; A general motion function is a function named FORWARD- or ;;; BACKWARD- of the signature ( &OPTIONAL ;;; ( 1) ( #'ERROR-LIMIT-ACTION)) that returns ;;; true if it could move forward or backward over the requested ;;; number of units, , which may be positive or negative; and ;;; calls the limit action if it could not, or returns nil if the ;;; limit action is nil. ;;; ;;; A limit action is a function usually named -LIMIT-ACTION ;;; of the signature ( ;;; ) that is called whenever a general motion function ;;; cannot complete the motion. is the mark the object in ;;; motion; is the original offset of the mark, ;;; before any motion; is the number of units left ;;; until the motion would be complete; is a string naming the ;;; unit; and is the syntax instance passed to the motion ;;; function. ;;; ;;; A motion command is a CLIM command named Forward or ;;; Backward which can take a numeric prefix argument and moves ;;; the point over the requested number, or 1, of units, by calling ;;; the general motion function FORWARD- or BACKWARD-. ;;; ;;; Given the basic motion functions FORWARD-ONE- and ;;; BACKWARD-ONE-, ;;; ;;; (DEFINE-MOTION-FNS ) ;;; ;;; defines the general motion functions FORWARD- and ;;; BACKWARD-. ;;; ;;; NOTE: FORWARD-OBJECT and BACKWARD-OBJECT, by virtue of their ;;; low-level status and placement in the buffer protocol (see ;;; buffer.lisp) do not obey this protocol, in that they have no ;;; syntax argument. Therefore, all -OBJECT functions and ;;; commands lack this argument as well (FIXME? We could shadow the ;;; definition from the buffer protocol and just ignore the syntax ;;; argument). There are no FORWARD-ONE-OBJECT or BACKWARD-ONE-OBJECT ;;; functions. (in-package :drei-motion) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Functions to move mark around based on the syntax: (defun forward-to-word-boundary (mark syntax) "Move the mark forward to the beginning of the next word." (loop until (end-of-buffer-p mark) until (word-constituentp syntax (object-after mark)) do (incf (offset mark)))) (defun backward-to-word-boundary (mark syntax) "Move the mark backward to the end of the previous word." (loop until (beginning-of-buffer-p mark) until (word-constituentp syntax (object-before mark)) do (decf (offset mark)))) (defun beep-limit-action (mark original-offset remaining unit syntax) "This limit action will beep at the user." (declare (ignore mark original-offset remaining unit syntax)) (clim:beep) nil) (defun revert-limit-action (mark original-offset remaining unit syntax) "This limit action will try to restore the mark state from before the attempted action. Note that this will not restore any destructive actions that have been performed, it will only restore the position of `mark'." (declare (ignore remaining unit syntax)) (setf (offset mark) original-offset) nil) (define-condition motion-limit-error (error) ((mark :initarg :mark) (original-offset :initarg :original-offset) (unit :initarg :unit) (remaining :initarg :remaining) (syntax :initarg :syntax)) (:documentation "This error condition signifies that a motion cannot be performed.") (:report (lambda (condition stream) (format stream "Motion by ~A reached limit." (slot-value condition 'UNIT))))) (defun error-limit-action (mark original-offset remaining unit syntax) "This limit action will signal an error of type `motion-limit-error'." (error 'MOTION-LIMIT-ERROR :mark mark :original-offset original-offset :remaining remaining :unit unit :syntax syntax)) (defmacro define-motion-fns (unit &key plural) (labels ((concat (&rest strings) (apply #'concatenate 'string (mapcar #'string strings))) (symbol (&rest strings) (intern (apply #'concat strings)))) (let ((forward-one (symbol "FORWARD-ONE-" unit)) (backward-one (symbol "BACKWARD-ONE-" unit)) (forward (symbol "FORWARD-" unit)) (backward (symbol "BACKWARD-" unit)) (unit-name (string-downcase unit))) (let ((plural (or plural (concat unit-name "s")))) `(progn (defgeneric ,forward (mark syntax &optional count limit-action) (:documentation ,(concat "Move MARK forward by COUNT " plural "."))) (defgeneric ,backward (mark syntax &optional count limit-action) (:documentation ,(concat "Move MARK backward by COUNT " plural "."))) (defmethod ,forward (mark syntax &optional (count 1) (limit-action #'error-limit-action)) (let ((offset (offset mark))) (dotimes (i count t) (if (not (,forward-one mark syntax)) (return (and limit-action (funcall limit-action mark offset (- count i) ,unit-name syntax))))))) (defmethod ,backward (mark syntax &optional (count 1) (limit-action #'error-limit-action)) (let ((offset (offset mark))) (dotimes (i count t) (if (not (,backward-one mark syntax)) (return (and limit-action (funcall limit-action mark offset (- i count) ,unit-name syntax))))))) (defmethod ,forward :around (mark syntax &optional (count 1) (limit-action :error)) (cond ((minusp count) (,backward mark syntax (- count) limit-action)) ((plusp count) (call-next-method)) (t t))) (defmethod ,backward :around (mark syntax &optional (count 1) (limit-action :error)) (cond ((minusp count) (,forward mark syntax (- count) limit-action)) ((plusp count) (call-next-method)) (t t)))))))) (defun make-diligent-motor (motor fiddler) "Create and return a diligent motor with a default limit action of `beep-limit-action'. `Motor' and `fiddler' will take turns being called until either `motor' succeeds or `fiddler' fails." (labels ((make-limit-action (loser) (labels ((limit-action (mark original-offset remaining unit syntax) (declare (ignore original-offset unit)) (and (funcall fiddler mark syntax 1 loser) (funcall motor mark syntax (if (minusp remaining) (- -1 remaining) (- remaining 1)) #'limit-action)))) #'limit-action)) (move (mark syntax &optional (count 1) (loser #'beep-limit-action)) (funcall motor mark syntax count (make-limit-action loser)))) #'move)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Line start motion (defgeneric forward-one-line-start (mark syntax) (:documentation "Move MARK to the start of the next line.")) (defmethod forward-one-line-start (mark syntax) (when (forward-object mark) (loop until (beginning-of-line-p mark) do (forward-object mark) finally (return t)))) (defgeneric backward-one-line-start (mark syntax) (:documentation "Move MARK to the end of the next line.")) (defmethod backward-one-line-start (mark syntax) (when (backward-object mark) (loop until (beginning-of-line-p mark) do (backward-object mark) finally (return t)))) (define-motion-fns line-start) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Line end motion (defgeneric forward-one-line-end (mark syntax) (:documentation "Move MARK to the end of the next line.")) (defmethod forward-one-line-end (mark syntax) (when (forward-object mark) (loop until (end-of-line-p mark) do (forward-object mark) finally (return t)))) (defgeneric backward-one-line-end (mark syntax) (:documentation "Move MARK to the end of the previous line.")) (defmethod backward-one-line-end (mark syntax) (when (backward-object mark) (loop until (end-of-line-p mark) do (backward-object mark) finally (return t)))) (define-motion-fns line-end) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Word motion (defgeneric forward-one-word (mark syntax) (:documentation "Move MARK forward over the next word. Return T if successful, or NIL if the buffer limit was reached.")) (defmethod forward-one-word (mark syntax) (unless (end-of-buffer-p mark) (forward-to-word-boundary mark syntax) (loop until (end-of-buffer-p mark) while (word-constituentp syntax (object-after mark)) do (forward-object mark) finally (return t)))) (defgeneric backward-one-word (mark syntax) (:documentation "Move MARK backward over the previous word. Return T if successful, or NIL if the buffer limit was reached.")) (defmethod backward-one-word (mark syntax) (unless (beginning-of-buffer-p mark) (backward-to-word-boundary mark syntax) (loop until (beginning-of-buffer-p mark) while (word-constituentp syntax (object-before mark)) do (backward-object mark) finally (return t)))) (define-motion-fns word) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Line motion (defgeneric forward-one-line (mark syntax) (:documentation "Move MARK forward to the next line, preserving column. Return T if successful, or NIL if the buffer limit was reached.")) (defmethod forward-one-line (mark syntax) (let ((column (column-number mark))) (end-of-line mark) (handler-case (cond ((forward-object mark) (setf (column-number mark) column) t) (t nil)) (motion-after-end ())))) (defgeneric backward-one-line (mark syntax) (:documentation "Move MARK backward to the previous line, preserving column. Return T if successful, or NIL if the buffer limit was reached.")) (defmethod backward-one-line (mark syntax) (let ((column (column-number mark))) (beginning-of-line mark) (handler-case (cond ((backward-object mark) (setf (column-number mark) column) t) (t nil)) (motion-before-beginning ())))) (define-motion-fns line) ;; Faster version for special mark... I don't know whether it's ever ;; going to be used, but it was in the old motion code. (defmethod backward-line ((mark p-line-mark-mixin) syntax &optional (count 1) (limit-action #'error-limit-action)) (let* ((column (column-number mark)) (line (line-number mark)) (goto-line (- line count))) (handler-case (setf (offset mark) (+ column (buffer-line-offset (buffer mark) goto-line))) (invalid-motion () (funcall limit-action mark (offset mark) (- count line) "line" syntax))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Page motion (defgeneric forward-one-page (mark syntax) (:documentation "Move MARK forward over the next page. Return T if successful, or NIL if the buffer limit was reached.")) (defmethod forward-one-page (mark syntax) (unless (end-of-buffer-p mark) (forward-object mark 1) (if (search-forward mark (coerce (page-delimiter syntax) 'vector)) (progn (backward-object mark (length (page-delimiter syntax))) t) (progn (end-of-buffer mark) nil)))) (defgeneric backward-one-page (mark syntax) (:documentation "Move MARK backward to the previous page. Return T if successful, or NIL if the buffer limit was reached.")) (defmethod backward-one-page (mark syntax) (unless (beginning-of-buffer-p mark) (backward-object mark 1) (if (search-backward mark (coerce (page-delimiter syntax) 'vector)) (progn (forward-object mark (length (page-delimiter syntax))) t) (progn (beginning-of-buffer mark) t)))) (define-motion-fns page) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Expression motion (defgeneric forward-one-expression (mark syntax) (:documentation "Move MARK forward over the next expression. Return T if successful, or NIL if the buffer limit or the end of the enclosing expression was reached.")) (defmethod forward-one-expression (mark syntax) (declare (ignore mark syntax)) (error 'NO-SUCH-OPERATION)) (defgeneric backward-one-expression (mark syntax) (:documentation "Move MARK backward over the previous expression. Return T if successful, or NIL if the buffer limit or the start of the enclosing expression was reached.")) (defmethod backward-one-expression (mark syntax) (declare (ignore mark syntax)) (error 'NO-SUCH-OPERATION)) (defgeneric forward-one-definition (mark syntax) (:documentation "Move MARK forward over the next definition. Return T if successful, or NIL if the buffer limit was reached.")) (defmethod forward-one-definition (mark syntax) (declare (ignore mark syntax)) (error 'NO-SUCH-OPERATION)) (defgeneric backward-one-definition (mark syntax) (:documentation "Move MARK backward over the previous definition. Return T if successful, or NIL if the buffer limit was reached.")) (defmethod backward-one-definition (mark syntax) (declare (ignore mark syntax)) (error 'NO-SUCH-OPERATION)) (defgeneric forward-one-up (mark syntax) (:documentation "Move MARK forward by one nesting level up. Return T if successful, or NIL if the buffer limit was reached.")) (defmethod forward-one-up (mark syntax) (declare (ignore mark syntax)) (error 'NO-SUCH-OPERATION)) (defgeneric backward-one-up (mark syntax) (:documentation "Move MARK backward by one nesting level up. Return T if successful, or NIL if the buffer limit was reached.")) (defmethod backward-one-up (mark syntax) (declare (ignore mark syntax)) (error 'NO-SUCH-OPERATION)) (defgeneric forward-one-down (mark syntax) (:documentation "Move MARK forward by one nesting level down. Return T if successful, or NIL if the buffer limit was reached.")) (defmethod forward-one-down (mark syntax) (declare (ignore mark syntax)) (error 'NO-SUCH-OPERATION)) (defgeneric backward-one-down (mark syntax) (:documentation "Move MARK backward by one nesting level down. Return T if successful, or NIL if the buffer limit was reached.")) (defmethod backward-one-down (mark syntax) (declare (ignore mark syntax)) (error 'NO-SUCH-OPERATION)) (define-motion-fns expression) (define-motion-fns definition) (define-motion-fns up :plural "nesting levels up") (define-motion-fns down :plural "nesting levels down") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Paragraph motion (defgeneric backward-one-paragraph (mark syntax) (:documentation "Move MARK backward by one paragraph. Return T if successful, or NIL if the buffer limit was reached.")) (defmethod backward-one-paragraph (mark syntax) (unless (beginning-of-buffer-p mark) (backward-object mark 1) (if (search-backward mark (coerce (paragraph-delimiter syntax) 'vector)) (forward-object mark (length (paragraph-delimiter syntax))) (beginning-of-buffer mark)) t)) (defgeneric forward-one-paragraph (mark syntax) (:documentation "Move MARK forward by one paragraph. Return T if successful, or NIL if the buffer limit was reached.")) (defmethod forward-one-paragraph (mark syntax) (unless (end-of-buffer-p mark) (forward-object mark 1) (if (search-forward mark (coerce (paragraph-delimiter syntax) 'vector)) (backward-object mark (length (paragraph-delimiter syntax))) (end-of-buffer mark)) t)) (define-motion-fns paragraph) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; List motion (defgeneric backward-one-list (mark syntax) (:documentation "Move MARK backward by one list. Return T if successful, or NIL if the buffer limit was reached.") (:method (mark syntax) (error 'no-such-operation))) (defgeneric forward-one-list (mark syntax) (:documentation "Move MARK forward by one list. Return T if successful, or NIL if the buffer limit was reached.") (:method (mark syntax) (error 'no-such-operation))) (define-motion-fns list) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Sentence motion (defgeneric backward-one-sentence (mark syntax) (:documentation "Move MARK backward by one sentence. Return T if successful, or NIL if the buffer limit was reached.") (:method (mark syntax) (error 'no-such-operation))) (defgeneric forward-one-sentence (mark syntax) (:documentation "Move MARK forward by one sentence. Return T if successful, or NIL if the buffer limit was reached.") (:method (mark syntax) (error 'no-such-operation))) (define-motion-fns sentence) ;;; Paredit-like motion operations: move forward or backward across ;;; expressions, until the limits of the enclosing expression are ;;; reached; then move up a level. (declaim (ftype function forward-expression-or-up backward-expression-or-up)) (setf (fdefinition 'FORWARD-EXPRESSION-OR-UP) (make-diligent-motor #'forward-expression #'forward-up)) (setf (fdefinition 'BACKWARD-EXPRESSION-OR-UP) (make-diligent-motor #'backward-expression #'backward-up)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/delegating-buffer.lisp0000640000175000017500000001136310741375212022127 0ustar pdmpdm;;; -*- mode: lisp -*- ;;; ;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic@yahoo.com) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Buffer class that allows for specifying buffer implementation at run time. (in-package :drei-buffer) (defclass delegating-buffer (buffer) ((%implementation :reader implementation :initform (error "A delegating buffer must have an implementation") :initarg :implementation)) (:documentation "Buffer class that delegates the buffer protocol functionality to a buffer implementation object stored in the `implementation' slot.")) (defmethod size ((buffer delegating-buffer)) (size (implementation buffer))) (defmethod number-of-lines ((buffer delegating-buffer)) (number-of-lines (implementation buffer))) (defmethod insert-buffer-object ((buffer delegating-buffer) offset object) (insert-buffer-object (implementation buffer) offset object)) (defmethod insert-buffer-sequence ((buffer delegating-buffer) offset sequence) (insert-buffer-sequence (implementation buffer) offset sequence)) (defmethod delete-buffer-range ((buffer delegating-buffer) offset n) (delete-buffer-range (implementation buffer) offset n)) (defmethod buffer-object ((buffer delegating-buffer) offset) (buffer-object (implementation buffer) offset)) (defmethod (setf buffer-object) (object (buffer delegating-buffer) offset) (setf (buffer-object (implementation buffer) offset) object)) (defmethod buffer-sequence ((buffer delegating-buffer) offset1 offset2) (buffer-sequence (implementation buffer) offset1 offset2)) (defmethod buffer-line-number ((buffer delegating-buffer) offset) (buffer-line-number (implementation buffer) offset)) (defmethod buffer-column-number ((buffer delegating-buffer) offset) (buffer-column-number (implementation buffer) offset)) (defclass delegating-mark (mark-mixin) ((%implementation :reader implementation :initform (error "A delegating mark must have an implementation") :initarg :implementation)) (:documentation "Superclass for classes suitable for use in a `delegating-buffer'.")) (defmethod offset ((mark delegating-mark)) (offset (implementation mark))) (defmethod (setf offset) (new-value (mark delegating-mark)) (setf (offset (implementation mark)) new-value)) (defclass delegating-left-sticky-mark (left-sticky-mark delegating-mark) () (:documentation "A `left-sticky-mark' subclass suitable for use in a `delegating-buffer'.")) (defclass delegating-right-sticky-mark (right-sticky-mark delegating-mark) () (:documentation "A `right-sticky-mark' subclass suitable for use in a `delegating-buffer'.")) (defmethod clone-mark ((mark delegating-left-sticky-mark) &optional stick-to) (cond ((or (null stick-to) (eq stick-to :left)) (make-instance 'delegating-left-sticky-mark :implementation (clone-mark (implementation mark) :left) :buffer (buffer mark))) ((eq stick-to :right) (make-instance 'delegating-right-sticky-mark :implementation (clone-mark (implementation mark) :right) :buffer (buffer mark))) (t (error "invalid value for stick-to")))) (defmethod clone-mark ((mark delegating-right-sticky-mark) &optional stick-to) (cond ((or (null stick-to) (eq stick-to :right)) (make-instance 'delegating-right-sticky-mark :implementation (clone-mark (implementation mark) :right) :buffer (buffer mark))) ((eq stick-to :left) (make-instance 'delegating-left-sticky-mark :implementation (clone-mark (implementation mark) :left) :buffer (buffer mark))) (t (error "invalid value for stick-to")))) (defmethod make-buffer-mark ((buffer delegating-buffer) &optional (offset 0) (stick-to :left)) (make-instance (ecase stick-to (:left 'delegating-left-sticky-mark) (:right 'delegating-right-sticky-mark)) :implementation (make-buffer-mark (implementation buffer) offset stick-to) :buffer buffer)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/lisp-syntax-swank.lisp0000644000175000017500000001157111345155772022206 0ustar pdmpdm;;; -*- Mode: Lisp; Package: DREI-LISP-SYNTAX; -*- ;;; (c) copyright 2005-2007 by ;;; Robert Strandh (strandh@labri.fr) ;;; David Murray (splittist@yahoo.com) ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; An implementation of some of the editor-centric functionality of ;;; the Lisp syntax using calls to Swank functions. (in-package :drei-lisp-syntax) (defclass swank-local-image () ()) ;; We need these modules loaded. (eval-when (:compile-toplevel :load-toplevel :execute) ;; Oh my! This is so we "gracefully" handle older Swanks that do not ;; have `swank-require'. We just hope they have the symbols we need ;; anyway. (ignore-errors (swank::swank-require :swank-c-p-c) (swank::swank-require :swank-arglists))) ;; If this file is loaded, make local Swank the default way of ;; interacting with the image. (defmethod shared-initialize :after ((obj lisp-syntax) slot-names &key) (declare (ignore slot-names)) (setf (image obj) (make-instance 'swank-local-image))) (defmethod default-image () (make-instance 'swank-local-image)) (define-command (com-enable-swank-for-view :name t :command-table lisp-table) () (unless (find-package :swank) (let ((*standard-output* *terminal-io*)) (handler-case (asdf:oos 'asdf:load-op :swank) (asdf:missing-component () (esa:display-message "Swank not available."))))) (setf (image (current-syntax)) (make-instance 'swank-local-image))) (defmethod compile-string-for-drei ((image swank-local-image) (string string) package (view drei-buffer-view) (buffer-mark mark)) (let* ((view-name (name view)) (buffer-file-name (filepath (buffer view))) (swank::*buffer-package* package) (swank::*buffer-readtable* *readtable*)) (let* ((result (swank::compile-string-for-emacs string view-name (offset buffer-mark) (princ-to-string buffer-file-name) nil)) (notes (loop for note in (swank::compilation-result-notes result) collect (make-compiler-note note)))) (values (list (swank::compilation-result-successp result) (swank::compilation-result-duration result)) notes)))) (defmethod compile-file-for-drei ((image swank-local-image) filepath package &optional load-p) (declare (ignore image)) (let* ((swank::*buffer-package* package) (swank::*buffer-readtable* *readtable*) (*compile-verbose* nil) (result (swank::compile-file-for-emacs filepath load-p)) (notes (loop for note in (swank::compilation-result-notes result) collect (make-compiler-note note)))) (values (list (swank::compilation-result-successp result) (swank::compilation-result-duration result)) notes))) (defmethod find-definitions-for-drei ((image swank-local-image) symbol) (declare (ignore image)) (flet ((fully-qualified-symbol-name (symbol) (let ((*package* (find-package :keyword))) (format nil "~S" symbol)))) (let* ((name (fully-qualified-symbol-name symbol)) (swank::*buffer-package* *package*) (swank::*buffer-readtable* *readtable*)) (swank::find-definitions-for-emacs name)))) (defmethod get-class-keyword-parameters ((image swank-local-image) class) (declare (ignore image)) (loop for arg in (swank::extra-keywords/make-instance 'make-instance class) collect (list (list (swank::keyword-arg.keyword arg) (swank::keyword-arg.arg-name arg)) (swank::keyword-arg.default-arg arg)))) (defmethod arglist ((image swank-local-image) (symbol symbol)) (declare (ignore image)) (let ((arglist (swank::arglist symbol))) (unless (eq arglist :not-available) arglist))) (defmethod simple-completions ((image swank-local-image) string default-package) (declare (ignore image)) (swank::completions string (package-name default-package))) (defmethod fuzzy-completions ((image swank-local-image) symbol-name default-package &optional limit) (declare (ignore image)) (swank::fuzzy-completions symbol-name (package-name default-package) :limit limit)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/lisp-syntax-commands.lisp0000644000175000017500000002621411345155772022664 0ustar pdmpdm;;; -*- Mode: Lisp; Package: DREI-LISP-SYNTAX; -*- ;;; (c) copyright 2004-2005 by ;;; Robert Strandh (strandh@labri.fr) ;;; (c) copyright 2004-2005 by ;;; Elliott Johnson (ejohnson@fasl.info) ;;; (c) copyright 2005 by ;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr) ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Commands specific to the Lisp syntax for Drei. (in-package :drei-lisp-syntax) ;;; This command table is used when Drei runs as a pane. (make-command-table 'pane-lisp-table :errorp nil) (defmethod additional-command-tables append ((drei drei-pane) (command-table lisp-table)) '(pane-lisp-table)) ;; Movement commands. (drei-commands:define-motion-commands expression lisp-table) (drei-commands:define-motion-commands definition lisp-table) (drei-commands:define-motion-commands up lisp-table :noun "nesting level up" :plural "levels") (drei-commands:define-motion-commands down lisp-table :noun "nesting level down" :plural "levels") (drei-commands:define-motion-commands list lisp-table) (drei-commands:define-editing-commands expression lisp-table) (drei-commands:define-deletion-commands expression lisp-table) (define-command (com-fill-paragraph :name t :command-table lisp-table) () "Fill paragraph at point. Will have no effect unless there is a string at point." (let* ((token (form-around (current-syntax) (offset (point)))) (fill-column (auto-fill-column (current-view)))) (when (form-string-p token) (with-accessors ((offset1 start-offset) (offset2 end-offset)) token (fill-region (make-buffer-mark (current-buffer) offset1 :right) (make-buffer-mark (current-buffer) offset2 :right) #'(lambda (mark) (proper-line-indentation (current-view) mark)) fill-column (tab-space-count (current-view)) (current-syntax) t))))) (define-command (com-indent-expression :name t :command-table lisp-table) ((count 'integer :prompt "Number of expressions" :default 1)) (let ((mark (clone-mark (point)))) (if (plusp count) (loop repeat count do (forward-expression mark (current-syntax))) (loop repeat (- count) do (backward-expression mark (current-syntax)))) (indent-region (current-view) (point) mark))) (define-command (com-lookup-arglist-for-this-symbol :command-table lisp-table) () "Show argument list for symbol at point." (let* ((token (this-form (current-syntax) (point)))) (if (and token (form-token-p token)) (com-lookup-arglist (form-to-object (current-syntax) token)) (display-message "Could not find symbol at point.")))) (define-command (com-lookup-arglist :name t :command-table lisp-table) ((symbol 'symbol :prompt "Symbol")) "Show argument list for a given symbol." (show-arglist (current-syntax) symbol)) (define-command (com-self-insert-then-arglist :command-table lisp-table) () "Insert the gesture used to invoke this command and display argument hints in the minibuffer." (insert-character *current-gesture*) (show-arglist-for-form-at-mark (point) (current-syntax)) (clear-completions)) (define-command (com-newline-indent-then-arglist :command-table lisp-table) () "Inserts a newline, indents the new line, then displays argument hints in the minibuffer." (insert-object (point) #\Newline) (indent-current-line (current-view) (point)) (show-arglist-for-form-at-mark (point) (current-syntax))) (define-command (com-complete-symbol :name t :command-table lisp-table) () "Attempt to complete the symbol at mark. If successful, move point to end of symbol. If more than one completion is available, a list of possible completions will be displayed. If there is no symbol at mark, all relevant symbols accessible in the current package will be displayed." (complete-symbol-at-mark (current-syntax) (point))) (define-command (com-fuzzily-complete-symbol :name t :command-table lisp-table) () "Attempt to fuzzily complete the abbreviation at mark. Fuzzy completion tries to guess which symbol is abbreviated. If the abbreviation is ambiguous, a list of possible completions will be displayed. If there is no symbol at mark, all relevant symbols accessible in the current package will be displayed." (fuzzily-complete-symbol-at-mark (current-syntax) (point))) (define-command (com-indent-line-and-complete-symbol :name t :command-table lisp-table) () "Indents the current line and performs symbol completion. First indents the line. If the line was already indented, completes the symbol. If there's no symbol at the point, shows the arglist for the most recently enclosed operator." (let ((old-offset (offset (point)))) (indent-current-line (current-view) (point)) (when (= old-offset (offset (point))) (or (complete-symbol-at-mark (current-syntax) (point) nil) (show-arglist-for-form-at-mark (point) (current-syntax)))))) (define-presentation-to-command-translator lookup-symbol-arglist (symbol com-lookup-arglist lisp-table :gesture :describe :documentation "Lookup arglist") (object) (list object)) (define-command (com-eval-region :name t :command-table pane-lisp-table) () "Evaluate the current region." (let ((mark (mark)) (point (point))) (when (mark> mark point) (rotatef mark point)) (eval-region mark point (current-syntax)))) (define-command (com-eval-last-expression :name t :command-table pane-lisp-table) ((insertp 'boolean :prompt "Insert?" :default nil)) "Evaluate the expression before point in the local Lisp image." (let ((token (form-before (current-syntax) (offset (point))))) (if token (with-syntax-package ((current-syntax) (point)) (let ((*read-base* (base (current-syntax)))) (drei-commands::com-eval-expression (form-to-object (current-syntax) token :read t) insertp))) (display-message "Nothing to evaluate.")))) (define-command (com-eval-defun :name t :command-table pane-lisp-table) () (eval-defun (point) (current-syntax))) (define-command (com-remove-definition :name t :command-table lisp-table) () "Remove the definition point is in. The operator of the definition form will be used to determine what kind of definition it is. The user will be asked for confirmation before anything is actually done." (let ((definition-form (definition-at-mark (current-syntax) (point)))) (if (or (null definition-form) (mark> (point) (end-offset definition-form)) (mark< (point) (start-offset definition-form))) (display-message "No definition found at point.") (handler-case (let* ((definition-type (form-to-object (current-syntax) (form-operator definition-form))) (undefiner (get-undefiner definition-type))) (if (null undefiner) (display-message "Doesn't know how to undefine ~S." definition-type) (handler-case (when (accept 'boolean :prompt (format nil "Undefine the ~A ~S?" (undefiner-type undefiner) (definition-name undefiner (current-syntax) definition-form)) :default t :insert-default t) (undefine undefiner (current-syntax) definition-form)) (form-conversion-error (e) (display-message "Could not undefine ~S form: ~A" definition-type (problem e)))))) (form-conversion-error (e) (display-message "Couldn't turn \"~A\" into valid operator: ~A" (form-string (current-syntax) (form e)) (problem e))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Gesture bindings (set-key 'com-fill-paragraph 'lisp-table '((#\q :meta))) (set-key `(com-indent-expression ,*numeric-argument-marker*) 'lisp-table '((#\q :meta :control))) (set-key `(com-backward-up ,*numeric-argument-marker*) 'lisp-table '((#\u :control :meta))) (set-key `(com-forward-down ,*numeric-argument-marker*) 'lisp-table '((#\d :control :meta))) (set-key `(com-backward-expression ,*numeric-argument-marker*) 'lisp-table '((#\b :control :meta))) (set-key `(com-forward-expression ,*numeric-argument-marker*) 'lisp-table '((#\f :control :meta))) (set-key `(com-backward-definition ,*numeric-argument-marker*) 'lisp-table '((#\a :control :meta))) (set-key `(com-forward-definition ,*numeric-argument-marker*) 'lisp-table '((#\e :control :meta))) (set-key `(com-forward-list ,*numeric-argument-marker*) 'lisp-table '((#\n :control :meta))) (set-key `(com-backward-list ,*numeric-argument-marker*) 'lisp-table '((#\p :control :meta))) (set-key `(com-kill-expression ,*numeric-argument-marker*) 'lisp-table '((#\k :control :meta))) (set-key 'com-lookup-arglist-for-this-symbol 'lisp-table '((#\c :control) (#\d :control) (#\a))) (set-key 'com-self-insert-then-arglist 'lisp-table '((#\Space))) (set-key 'com-self-insert-then-arglist 'lisp-table '((#\)))) (set-key 'com-complete-symbol 'lisp-table '((#\Tab :meta))) (set-key 'com-fuzzily-complete-symbol 'lisp-table '((#\c :control) (#\i :meta))) (set-key 'com-indent-line-and-complete-symbol 'lisp-table '((#\Tab))) (set-key 'com-newline-indent-then-arglist 'lisp-table '(#\Newline)) (set-key 'com-eval-region 'pane-lisp-table '((#\c :control) (#\r :control))) (set-key `(com-eval-last-expression ,*numeric-argument-marker*) 'pane-lisp-table '((#\c :control) (#\e :control))) (set-key `(com-backward-kill-expression ,*numeric-argument-marker*) 'lisp-table '((#\Backspace :control :meta))) (set-key `(com-kill-expression ,*numeric-argument-marker*) 'lisp-table '((#\Delete :control :meta))) (set-key 'com-remove-definition 'lisp-table '((#\c :control) (#\u :control))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/packages.lisp0000644000175000017500000006043111345155772020347 0ustar pdmpdm;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2004-2005 by ;;; Robert Strandh (strandh@labri.fr) ;;; (c) copyright 2005 by ;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Package definitions for the DREI editing component. (in-package :cl-user) (defpackage :drei-buffer (:use :clim-lisp :flexichain :binseq :esa-utils) ;; Kludge to remove symbol conflicts. (:import-from :esa-io :buffer) (:export #:buffer #:standard-buffer #:mark #:left-sticky-mark #:right-sticky-mark #:standard-left-sticky-mark #:standard-right-sticky-mark #:make-buffer-mark #:clone-mark #:condition-offset #:no-such-offset #:offset-before-beginning #:offset-after-end #:invalid-motion #:motion-before-beginning #:motion-after-end #:size #:number-of-lines #:offset #:mark< #:mark<= #:mark= #:mark> #:mark>= #:forward-object #:backward-object #:forward-line-start #:backward-line-start #:forward-line-end #:backward-line-end #:beginning-of-buffer #:end-of-buffer #:beginning-of-buffer-p #:end-of-buffer-p #:beginning-of-line #:end-of-line #:beginning-of-line-p #:end-of-line-p #:buffer-line-number #:buffer-column-number #:line-number #:column-number #:insert-buffer-object #:insert-buffer-sequence #:buffer-substring #:insert-object #:insert-sequence #:delete-buffer-range #:delete-range #:delete-region #:buffer-object #:buffer-sequence #:object-before #:object-after #:region-to-sequence #:region-to-string #:observable-buffer-mixin #:binseq-buffer #:obinseq-buffer #:binseq2-buffer #:persistent-left-sticky-mark #:persistent-right-sticky-mark #:persistent-left-sticky-line-mark #:persistent-right-sticky-line-mark #:p-line-mark-mixin #:buffer-line-offset #:delegating-buffer #:implementation #:delegating-left-sticky-mark #:delegating-right-sticky-mark) (:documentation "An implementation of the buffer protocol. This package is quite low-level, not syntax-aware, not CLIM-aware and not user-oriented at all.")) (defpackage :drei-undo (:use :clim-lisp :drei-buffer :flexichain) (:export #:no-more-undo #:undo-tree #:standard-undo-tree #:undo-record #:standard-undo-record #:add-undo #:flip-undo-record #:undo #:redo)) (defpackage :drei-kill-ring (:use :clim-lisp :flexichain) (:export #:kill-ring #:kill-ring-chain #:kill-ring-cursor #:empty-kill-ring #:kill-ring-length #:kill-ring-max-size #:append-next-p #:reset-yank-position #:rotate-yank-position #:kill-ring-yank #:kill-ring-standard-push #:kill-ring-concatenating-push #:kill-ring-reverse-concatenating-push #:*kill-ring*) (:documentation "An implementation of a kill ring.")) (defpackage :drei-base (:use :clim-lisp :drei-buffer :drei-kill-ring :esa-buffer :esa-utils) (:export #:as-region #:as-full-region #:as-offsets #:do-buffer-region #:do-buffer-region-lines #:previous-line #:next-line #:open-line #:delete-line #:extract-line #:lines-in-region #:extract-lines-in-region #:empty-line-p #:line-indentation #:buffer-display-column #:number-of-lines-in-region #:constituentp #:just-n-spaces #:move-to-column #:kill-region #:in-place-buffer-substring #:fill-string-from-buffer #:buffer-find-nonchar #:offset-beginning-of-line-p #:offset-end-of-line-p #:end-of-line-offset #:extract-region #:buffer-whitespacep #:buffer-region-case #:buffer-looking-at #:looking-at #:buffer-search-forward #:buffer-search-backward #:buffer-re-search-forward #:buffer-re-search-backward #:search-forward #:search-backward #:re-search-forward #:re-search-backward #:buffer-search-word-forward #:search-word-forward #:buffer-search-word-backward #:search-word-backward #:downcase-buffer-region #:downcase-region #:upcase-buffer-region #:upcase-region #:capitalize-buffer-region #:capitalize-region #:tabify-region #:untabify-region #:narrowed-mark-mixin #:narrowed-left-sticky-mark #:narrowed-right-sticky-mark #:make-narrowed-mark #:make-backward-narrowed-mark #:make-forward-narrowed-mark #:narrow-mark #:unnarrow-mark) (:documentation "Basic functionality built on top of the buffer protocol. Here is where we define slightly higher level functions, that can be directly implemented in terms of the buffer protocol, but that are not, strictly speaking, part of that protocol. The functions in this package are not syntax-aware, and are thus limited in what they can do. They percieve the buffer as little more than a sequence of characters.")) (defpackage :drei-abbrev (:use :clim-lisp :clim :drei-buffer :drei-base) (:export #:abbrev-expander #:dictionary-abbrev-expander #:dictionary #:expand-abbrev #:abbrev-mixin #:possibly-expand-abbrev #:add-abbrev)) (defpackage :drei-syntax (:use :clim-lisp :clim :drei-buffer :drei-base :flexichain :esa-utils) (:export #:syntax #:syntax-command-tables #:updater-fns #:update-parse #:syntaxp #:define-syntax #:*default-syntax* #:syntax-command-table #:additional-command-tables #:define-syntax-command-table #:eval-option #:define-option-for-syntax #:current-attributes-for-syntax #:make-attribute-line #:syntax-from-name #:update-syntax #:grammar #:grammar-rule #:add-rule #:parser #:initial-state #:advance-parse #:parse-tree #:start-offset #:end-offset #:lexer #:nb-lexemes #:lexeme #:insert-lexeme #:incremental-lexer #:next-lexeme #:delete-invalid-lexemes #:inter-lexeme-object-p #:skip-inter-lexeme-objects #:update-lex #:parse-stack-top #:target-parse-tree #:parse-state-empty-p #:parse-stack-next #:parse-stack-symbol #:parse-stack-parse-trees #:map-over-parse-trees #:no-such-operation #:name-for-info-pane #:display-syntax-name #:syntax-line-indentation #:eval-defun #:syntax-line-comment-string #:line-comment-region #:comment-region #:line-uncomment-region #:uncomment-region #:word-constituentp #:whitespacep #:page-delimiter #:paragraph-delimiter) (:documentation "The syntax protocol. Contains functions that can be used to implement higher-level operations on buffer contents.")) (defpackage :drei (:use :clim-lisp :clim-sys :clim :drei-buffer :drei-base :drei-abbrev :drei-syntax :flexichain :drei-undo :esa-buffer :esa-io :esa :esa-utils :drei-kill-ring) (:export #:drei-buffer #:needs-saving #:filepath #:file-saved-p #:file-write-time #:read-only-p #:buffer-read-only #:display-drei #:display-drei-pane #:display-drei-area #:full-redisplay #:offset-to-screen-position #:page-down #:page-up #:isearch-state #:search-string #:search-mark #:search-forward-p #:search-success-p #:query-replace-state #:string1 #:string2 #:targets #:occurrences ;; Undo. #:undo-mixin #:undo-tree #:undo-accumulate #:performing-undo #:drei-undo-record #:simple-undo-record #:insert-record #:delete-record #:compound-record #:with-undo #:clear-undo-history #:drei-buffer ;; Signals and conditions. #:user-condition-mixin #:buffer-read-only #:buffer-single-line #:no-available-minibuffer ;; Views and their facilities. #:drei-view #:modified-p #:no-cursors #:drei-buffer-view #:buffer #:top #:bot #:buffer-view-p #:lines #:buffer-line #:start-mark #:end-mark #:line-length #:chunks #:line-containing-offset #:offset-in-line-p #:buffer-view-pump-state-for-offset #:buffer-view-stroke-pump #:drei-syntax-view #:syntax #:syntax-view-p #:pump-state-for-offset-with-syntax #:stroke-pump-with-syntax #:point-mark-view #:point-mark-view-p #:textual-drei-syntax-view #:tab-space-count #:space-width #:tab-width #:use-tabs #:auto-fill-mode #:auto-fill-column #:isearch-mode #:isearch-states #:isearch-previous-string #:query-replace-mode #:region-visible-p #:dabbrev-expansion-mark #:original-prefix #:prefix-start-offset #:overwrite-mode #:goal-column #:invalidate-strokes #:view-command-tables #:use-editor-commands-p #:synchronize-view #:create-view-cursors #:clear-redisplay-information #:clone-view #:make-syntax-for-view ;; DREI command tables. #:comment-table #:deletion-table #:editing-table #:fill-table #:indent-table #:marking-table #:case-table #:movement-table #:search-table #:info-table #:self-insert-table #:view-table #:editor-table #:exclusive-gadget-table #:exclusive-input-editor-table #:minibuffer #:drei #:editor-pane #:drei-pane #:drei-gadget-pane #:drei-area #:handling-drei-conditions #:handle-drei-condition #:execute-drei-command ;; Redisplay engine. #:display-drei-view-contents #:display-drei-view-cursor #:handle-redisplay #:face #:make-face #:face-ink #:face-style #:drawing-options #:make-drawing-options #:drawing-options-face #:drawing-options-function #:drawing-options-equal #:+default-drawing-options+ #:stroke-start-offset #:stroke-end-offset #:stroke-drawing-options #:pump-state-for-offset #:stroke-pump #:object-drawer #:*maximum-chunk-size* #:+roman-face+ #:+roman-face-drawing-options+ #:+italic-face+ #:+italic-face-drawing-options+ #:+bold-face+ #:+bold-face-drawing-options+ #:+bold-italic-face+ #:+bold-italic-drawing-options+ #:*keyword-drawing-options* #:*special-operator-drawing-options* #:*special-variable-drawing-options* #:*string-drawing-options* #:*comment-drawing-options* #:*error-drawing-options* #:*highlight-strokes* #:*stroke-boundary-ink* #:*stroke-baseline-ink* ;; DREI program interface stuff. #:with-drei-options #:performing-drei-operations #:invoke-performing-drei-operations #:with-bound-drei-special-variables #:accepting-from-user #:invoke-accepting-from-user #:require-minibuffer ;; Gadget interface stuff. #:handle-gesture ;; Input-editor interface stuff. #:drei-input-editing-mixin #:drei-instance #:object #:result-type ;; Drei cursors. #:drei-cursor #:mark-cursor #:active #:mark #:active-ink #:inactive-ink #:ink #:in-focus-p ;; Info functions. #:point #:point-of #:mark #:mark-of #:current-syntax #:current-view #:drei-instance #:drei-instance-of ;; Configuration. #:*foreground-color* #:*background-color* #:*show-mark* #:*use-tabs-for-indentation* #:view-mode #:syntax-mode #:applicable-modes #:define-mode #:define-view-mode #:define-syntax-mode #:define-mode-toggle-commands)) (defpackage :drei-motion (:use :clim-lisp :drei-base :drei-buffer :drei-syntax) (:export #:forward-to-word-boundary #:backward-to-word-boundary #:define-motion-fns #:beep-limit-action #:revert-limit-action #:error-limit-action #:motion-limit-error #:make-diligent-motor ;; Lines #:forward-one-line #:backward-one-line #:forward-line #:backward-line ;; Words #:forward-one-word #:backward-one-word #:forward-word #:backward-word ;; Pages #:forward-one-page #:backward-one-page #:forward-page #:backward-page ;; Expressions #:forward-one-expression #:backward-one-expression #:forward-expression #:backward-expression ;; Definitions #:forward-one-definition #:backward-one-definition #:forward-definition #:backward-definition ;; Up #:forward-one-up #:backward-one-up #:forward-up #:backward-up ;; Down #:forward-one-down #:backward-one-down #:forward-down #:backward-down ;; Paragraphs #:forward-one-paragraph #:backward-one-paragraph #:forward-paragraph #:backward-paragraph ;; Sentences #:forward-one-sentence #:backward-one-sentence #:forward-sentence #:backward-sentence ;; Lists #:forward-one-list #:backward-one-list #:forward-list #:backward-list) (:documentation "Functions and facilities for moving a mark around by syntactical elements. The functions in this package are syntax-aware, and their behavior is based on the semantics defined by the syntax of the buffer, that the mark they are manipulating belong to. These functions are also directly used to implement the motion commands.")) (defpackage :drei-editing (:use :clim-lisp :drei-base :drei-buffer :drei-syntax :drei-motion :drei :drei-kill-ring) (:export #:forward-delete-object #:backward-delete-object #:forward-kill-object #:backward-kill-object #:transpose-objects ;; Lines #:forward-delete-line #:backward-delete-line #:forward-kill-line #:backward-kill-line #:transpose-lines #:forward-delete-line-start #:backward-delete-line-start #:forward-kill-line-start #:backward-kill-line-start #:transpose-line-starts ;; Words #:forward-delete-word #:backward-delete-word #:forward-kill-word #:backward-kill-word #:transpose-words ;; Pages #:forward-delete-page #:backward-delete-page #:forward-kill-page #:backward-kill-page #:transpose-pages ;; Expressions #:forward-delete-expression #:backward-delete-expression #:forward-kill-expression #:backward-kill-expression #:transpose-expressions ;; Definitions #:forward-delete-definition #:backward-delete-definition #:forward-kill-definition #:backward-kill-definition #:transpose-definitions ;; Paragraphs #:forward-delete-paragraph #:backward-delete-paragraph #:forward-kill-paragraph #:backward-kill-paragraph #:transpose-paragraphs ;; Sentences #:forward-delete-sentence #:backward-delete-sentence #:forward-kill-sentence #:backward-kill-sentence #:transpose-sentences ;; Lists #:forward-delete-list #:backward-delete-list #:forward-kill-list #:backward-kill-list #:transpose-list) (:documentation "Functions and facilities for changing the buffer contents by syntactical elements. The functions in this package are syntax-aware, and their behavior is based on the semantics defined by the syntax of the buffer, that the mark they are manipulating belong to. These functions are also directly used to implement the editing commands.")) (defpackage :drei-core (:use :clim-lisp :drei-base :drei-buffer :drei-syntax :drei-motion :drei :drei-kill-ring :drei-editing :clim :drei-abbrev :esa :esa-buffer :esa-io :esa-utils :drei-undo) (:export #:proper-line-indentation #:goto-position #:goto-line #:replace-one-string #:possibly-fill-line #:back-to-indentation #:insert-character #:delete-horizontal-space #:indent-current-line #:insert-pair #:move-past-close-and-reindent #:downcase-word #:upcase-word #:capitalize-word #:indent-region #:fill-line #:fill-region #:indent-line #:delete-indentation #:join-line #:set-syntax #:*killed-rectangle* #:map-rectangle-lines #:extract-and-delete-rectangle-line #:insert-rectangle-at-mark #:clear-rectangle-line #:open-rectangle-line #:replace-rectangle-line #:insert-in-rectangle-line #:delete-rectangle-line-whitespace #:with-narrowed-buffer #:start-mark #:end-mark #:make-buffer-stream #:target-specification #:activate-target-specification #:deactivate-target-specification #:subsequent-targets-p #:preceding-targets-p #:next-target #:previous-target #:previous-target #:no-more-targets #:*default-target-creator* #:view-list-target-specification #:views) (:documentation "Implementation of much syntax-aware, yet no syntax-specific, core functionality of Drei.")) (defpackage :drei-fundamental-syntax (:use :clim-lisp :clim :drei-buffer :drei-base :drei-syntax :flexichain :drei :drei-core :esa-utils) (:export #:fundamental-syntax) (:documentation "Implementation of the basic syntax module for editing plain text.")) (defpackage :drei-lr-syntax (:use :clim-lisp :clim :clim-extensions :drei-buffer :drei-base :drei-syntax :drei :drei-core :drei-fundamental-syntax :esa-utils) (:export #:lr-syntax-mixin #:stack-top #:initial-state #:skip-inter #:lex #:define-lexer-state #:lexer-toplevel-state #:lexer-error-state #:parser-symbol #:parent #:children #:start-offset #:end-offset #:parser-state #:preceding-parse-tree #:literal-object-mixin #:define-parser-state #:lexeme #:nonterminal #:action #:new-state #:done #:reduce-fixed-number #:reduce-until-type #:reduce-all #:error-state #:error-reduce-state #:do-parse-symbols-forward #:parser-symbol-containing-offset #:define-syntax-highlighting-rules #:syntax-highlighting-rules) (:documentation "Underlying LR parsing functionality.")) (defpackage :drei-lisp-syntax (:use :clim-lisp :clim :clim-extensions :drei-buffer :drei-base :drei-syntax :drei-fundamental-syntax :flexichain :drei :drei-motion :drei-editing :esa-utils :esa :drei-core :esa-io :drei-lr-syntax :drei-kill-ring) (:export #:lisp-syntax #:lisp-table #:lisp-string #:edit-definition #:form #:form-to-object #:form-equal ;; Selecting forms based on mark #:form-around #:form-before #:form-after #:find-list-parent #:expression-at-mark #:definition-at-mark #:form-of-type-at-mark #:list-at-mark #:symbol-at-mark #:fully-quoted-form #:fully-unquoted-form #:this-form ;; Querying forms #:formp #:form-list-p #:form-incomplete-p #:form-complete-p #:form-token-p #:form-string-p #:form-quoted-p #:form-comma-p #:form-comma-at-p #:form-comma-dot-p #:form-character-p #:form-simple-vector-p #:comment-p #:line-comment-p #:long-comment-p #:form-at-top-level-p ;; Querying form data #:form-children #:form-operator #:form-operands #:form-toplevel #:form-operator-p ;; Querying about state at mark #:in-string-p #:in-comment-p #:in-line-comment-p #:in-long-comment-p #:in-character-p #:location-at-beginning-of-form #:location-at-end-of-form #:at-beginning-of-list-p #:at-end-of-list-p #:at-beginning-of-string-p #:at-end-of-string-p #:at-beginning-of-children-p #:at-end-of-children-p #:comment-at-mark ;; Lambda list classes. #:lambda-list #:semiordinary-lambda-list #:ordinary-lambda-list #:macro-lambda-list #:destructuring-lambda-list ;; Lambda list constructors. #:make-lambda-list #:make-required-parameter #:make-&optional-parameter #:make-&key-parameter #:make-&body-parameter #:make-&rest-parameter #:parse-lambda-list ;; Lambda list readers. #:required-parameters #:optional-parameters #:keyword-parameters #:allow-other-keys-p #:rest-parameter #:body-parameter ;; Parameter classes. #:parameter #:named-parameter #:destructuring-parameter #:required-parameter #:destructuring-required-parameter #:named-required-parameter #:optional-parameter #:destructuring-optional-parameter #:named-optional-parameter #:keyword-parameter #:destructuring-keyword-parameter #:rest-parameter #:body-parameter ;; Parameter object readers. #:min-arg-index #:name #:inner-lambda-list #:init-form #:keyword-name ;; Conditions. #:form-conversion-error #:invalid-lambda-list ;; Configuration #:*syntax-highlighting-rules* #:emacs-style-highlighting #:retro-highlighting) (:shadow clim:form) (:documentation "Implementation of the syntax module used for editing Common Lisp code.")) (defpackage :drei-commands (:use :clim-lisp :drei-base :drei-buffer :drei-syntax :drei-motion :drei :drei-kill-ring :drei-editing :clim :drei-abbrev :esa :esa-buffer :esa-io :esa-utils :drei-core :drei-undo) (:export #:define-motion-commands #:define-deletion-commands #:define-editing-commands) (:documentation "Command definitions that are not tied to specific syntaxes.")) (defpackage :drei-user (:use :clim-lisp :clim :clim-extensions :drei-buffer :drei-base :drei-syntax :drei-fundamental-syntax :flexichain :drei :drei-motion :drei-editing :esa-utils :esa :drei-core :esa-io :drei-commands) (:documentation "The package intended for user-made customizations and extensions.")) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/kill-ring.lisp0000644000175000017500000001575211345155772020467 0ustar pdmpdm;;; -*- Mode: Lisp; Package: DREI-KILL-RING -*- ;;; (c) copyright 2004 by ;;; Robert Strandh (strandh@labri.fr) ;;; (c) copyright 2004 by ;;; Elliott Johnson (ejohnson@fasl.info) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; kill ring system (in-package :drei-kill-ring) (defgeneric kill-ring-chain (ring) (:documentation "Return the cursorchain associated with the kill ring `ring'.")) (defgeneric kill-ring-cursor (ring) (:documentation "Return the flexicursor associated with the kill ring.")) (defclass kill-ring () ((max-size :type (integer 5 *) ;5 element minimum from flexichain protocol :initarg :max-size :documentation "The limitation placed upon the number of elements held by the kill ring. Once the maximum size has been reached, older entries must first be removed before new ones can be added. When altered, any surplus elements will be silently dropped.") (cursorchain :type standard-cursorchain :accessor kill-ring-chain :initform (make-instance 'standard-cursorchain) :documentation "The cursorchain associated with the kill ring.") (yankpoint :type left-sticky-flexicursor :accessor kill-ring-cursor :documentation "The flexicursor associated with the kill ring.") (append-next-p :type boolean :initform nil :accessor append-next-p)) (:documentation "A class for all kill rings")) (define-condition empty-kill-ring (simple-error) () (:report (lambda (condition stream) (declare (ignore condition)) (format stream "The kill ring is empty"))) (:documentation "This condition is signaled whenever a yank operation is performed on an empty kill ring.")) (defmethod initialize-instance :after ((kr kill-ring) &rest args) "Adds in the yankpoint" (declare (ignore args)) (with-slots (cursorchain yankpoint) kr (setf yankpoint (make-instance 'left-sticky-flexicursor :chain cursorchain)))) (defgeneric kill-ring-length (kr) (:documentation "Returns the current length of the kill-ring. Note this is different than `kill-ring-max-size'.")) (defgeneric kill-ring-max-size (kr) (:documentation "Returns the value of the kill ring's maximum size")) (defgeneric (setf kill-ring-max-size) (kr size) (:documentation "Alters the maximum size of the kill ring, even if it means dropping elements to do so.")) (defgeneric reset-yank-position (kr) (:documentation "Moves the current yank point back to the start of of kill ring position")) (defgeneric rotate-yank-position (kr &optional times) (:documentation "Moves the yank point associated with a kill-ring one or times many positions away from the start of ring position. If times is greater than the current length then the cursor will wrap to the start of ring position and continue rotating.")) (defgeneric kill-ring-standard-push (kr vector) (:documentation "Pushes a vector of objects onto the kill ring creating a new start of ring position. This function is much like an everyday Lisp push with size considerations. If the length of the kill ring is greater than the maximum size, then \"older\" elements will be removed from the ring until the maximum size is reached.")) (defgeneric kill-ring-concatenating-push (kr vector) (:documentation "Concatenates the contents of vector onto the end of the current contents of the top of the kill ring. If the kill ring is empty the a new entry is pushed.")) (defgeneric kill-ring-reverse-concatenating-push (kr vector) (:documentation "Concatenates the contents of vector onto the front of the current contents of the top of the kill ring. If the kill ring is empty a new entry is pushed.")) (defgeneric kill-ring-yank (kr &optional reset) (:documentation "Returns the vector of objects currently pointed to by the cursor. If `reset' is T, a call to `reset-yank-position' is called before the object is yanked. The default for reset is NIL. If the kill ring is empty, a condition of type `empty-kill-ring' is signalled.")) (defmethod kill-ring-length ((kr kill-ring)) (nb-elements (kill-ring-chain kr))) (defmethod kill-ring-max-size ((kr kill-ring)) (with-slots (max-size) kr max-size)) (defmethod (setf kill-ring-max-size) (size (kr kill-ring)) (unless (typep size 'integer) (error "Error, ~S, is not an integer value" size)) (if (< size 5) (setf (slot-value kr 'max-size) 5) (setf (slot-value kr 'max-size) size)) (let ((len (kill-ring-length kr))) (if (> len size) (loop for n from 1 to (- len size) do (pop-end (kill-ring-chain kr)))))) (defmethod reset-yank-position ((kr kill-ring)) (setf (cursor-pos (kill-ring-cursor kr)) 0) t) (defmethod rotate-yank-position ((kr kill-ring) &optional (times 1)) (if (> (kill-ring-length kr) 0) (let* ((curs (kill-ring-cursor kr)) (pos (mod (+ times (cursor-pos curs)) (kill-ring-length kr)))) (setf (cursor-pos curs) pos)))) (defmethod kill-ring-standard-push ((kr kill-ring) vector) (check-type vector vector) (cond ((append-next-p kr) (kill-ring-concatenating-push kr vector) (setf (append-next-p kr) nil)) (t (let ((chain (kill-ring-chain kr))) (if (>= (kill-ring-length kr) (kill-ring-max-size kr)) (progn (pop-end chain) (push-start chain vector)) (push-start chain vector))) (reset-yank-position kr)))) (defmethod kill-ring-concatenating-push ((kr kill-ring) vector) (check-type vector vector) (let ((chain (kill-ring-chain kr))) (if (zerop (kill-ring-length kr)) (push-start chain vector) (push-start chain (concatenate 'vector (pop-start chain) vector))) (reset-yank-position kr))) (defmethod kill-ring-reverse-concatenating-push ((kr kill-ring) vector) (check-type vector vector) (let ((chain (kill-ring-chain kr))) (if (zerop (kill-ring-length kr)) (push-start chain vector) (push-start chain (concatenate 'vector vector (pop-start chain)))) (reset-yank-position kr))) (defmethod kill-ring-yank ((kr kill-ring) &optional (reset nil)) (assert (plusp (kill-ring-length kr)) () (make-condition 'empty-kill-ring)) (if reset (reset-yank-position kr)) (element> (kill-ring-cursor kr))) (defparameter *kill-ring* (make-instance 'kill-ring :max-size 7) "This special variable is bound to the kill ring of the running application or Drei instance whenever a command is executed.") cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/lisp-syntax.lisp0000644000175000017500000056422011345155772021071 0ustar pdmpdm;;; -*- Mode: Lisp; Package: DREI-LISP-SYNTAX -*- ;;; (c) copyright 2005 by ;;; Robert Strandh (strandh@labri.fr) ;;; (c) copyright 2006-2007 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; A syntax module for analysing Common Lisp using an LR based ;;; parser. (in-package :drei-lisp-syntax) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Convenience functions and macros. (defun usable-package (package-designator) "Return a usable package based on `package-designator'." (or (find-package package-designator) *package*)) (defmacro evaluating-interactively (&body body) `(handler-case (progn ,@body) (end-of-file () (esa:display-message "Unbalanced parentheses in form.")))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; The command table. (define-syntax-command-table lisp-table :errorp nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; the syntax object (define-syntax lisp-syntax (lr-syntax-mixin fundamental-syntax) ((%package-list :accessor package-list :documentation "An alist mapping the end offset of (in-package) forms to a string of the package designator in the form. The list is sorted with the earliest (in-package) forms last (descending offset).") (%base :initform nil :documentation "The base which numbers in the buffer are expected to be in. If the provided value is NIL, the value of `*read-base*' will be used." :type (or null (integer 2 36))) (%option-specified-package :accessor option-specified-package :initform nil :documentation "The package specified in the attribute line (may be overridden by (in-package) forms). This may be either a string (the name of the intended package) or a package object.") (%image :accessor image :initform nil :documentation "An image object (or NIL) that determines where and how Lisp code in the buffer of the syntax should be run.") (%form-before-cache :accessor form-before-cache :initform (make-hash-table :test #'equal)) (%form-after-cache :accessor form-after-cache :initform (make-hash-table :test #'equal)) (%form-around-cache :accessor form-around-cache :initform (make-hash-table :test #'equal))) (:name "Lisp") (:pathname-types "lisp" "lsp" "cl") (:command-table lisp-table) (:default-initargs :initial-state |initial-state |)) (defgeneric base (syntax) (:documentation "Get the base `syntax' should interpret numbers in.") (:method ((syntax lisp-syntax)) (or (slot-value syntax '%base) *read-base*))) (defmethod (setf base) (base (syntax lisp-syntax)) (setf (slot-value syntax '%base) base)) (define-option-for-syntax lisp-syntax "Package" (syntax package-name) (let ((specified-package (find-package package-name))) (setf (option-specified-package syntax) (or specified-package package-name)))) (define-option-for-syntax lisp-syntax "Base" (syntax base) (let ((integer-base (parse-integer base :junk-allowed t))) (when integer-base (if (typep integer-base '(integer 2 36)) (setf (base syntax) integer-base) (esa:display-message "Invalid base specified: outside the interval 2 to 36."))))) (defmethod current-attributes-for-syntax append ((syntax lisp-syntax)) (list (cons :package (or (if (packagep (option-specified-package syntax)) (package-name (option-specified-package syntax)) (option-specified-package syntax)) (package-name (package-at-mark syntax (or (caar (last (package-list syntax))) 0))))) (cons :base (format nil "~A" (base syntax))))) (defmethod name-for-info-pane ((syntax lisp-syntax) &key view) (format nil "Lisp~@[:~(~A~)~]" (provided-package-name-at-mark syntax (if (typep view 'point-mark-view) (point view) 0)))) (defmethod display-syntax-name ((syntax lisp-syntax) (stream extended-output-stream) &key view) (princ "Lisp:" stream) ; FIXME: should be `present'ed ; as something. (let ((package-name (provided-package-name-at-mark syntax (if (typep view 'point-mark-view) (point view) 0)))) (if (find-package package-name) (with-output-as-presentation (stream (find-package package-name) 'expression) (princ package-name stream)) (with-text-face (stream :italic) (princ package-name stream))))) (defgeneric default-image () (:documentation "The default image for when the current syntax does not mandate anything itself (for example if it is not a Lisp syntax).") (:method () t)) (defgeneric get-usable-image (syntax) (:documentation "Get usable image object from `syntax'.") (:method (syntax) (default-image)) (:method ((syntax lisp-syntax)) (or (image syntax) (default-image)))) (defconstant +keyword-package+ (find-package :keyword) "The KEYWORD package.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Swank interface functions. (defgeneric eval-string-for-drei (image string package) (:documentation "Evaluate `string' in `package'. A single value is returned: The result of evaluating `string'.") (:method (image string package) (let ((*package* package)) (eval-form-for-drei image (read-from-string string))))) (defgeneric eval-form-for-drei (image form) (:documentation "Evaluate `string' in `package'. A single value is returned: The result of evaluating `string'.") (:method (image form) (declare (ignore image)) (eval form))) (defgeneric compile-string-for-drei (image string package view buffer-mark) (:documentation "Compile and evaluate `string' in `package'. Two values are returned: The result of evaluating `string' and a list of compiler notes. `Buffer' and `buffer-mark' will be used for hyperlinking the compiler notes to the source code.") (:method (image (string string) package (view drei-buffer-view) (buffer-mark mark)) (error "Backend insufficient for this operation"))) (defgeneric compile-form-for-drei (image form view buffer-mark) (:documentation "Compile and evaluate `form', which must be a valid Lisp form. Two values are returned: The result of evaluating `string' and a list of compiler notes. `Buffer' and `buffer-mark' will be used for hyperlinking the compiler notes to the source code.") (:method (image form (view drei-syntax-view) (buffer-mark mark)) (compile-string-for-drei image (let ((*print-base* (base (syntax view)))) (write-to-string form)) *package* view buffer-mark))) (defgeneric compile-file-for-drei (image filepath package &optional load-p) (:documentation "Compile the file at `filepath' in `package'. If `load-p' is non-NIL, also load the file at `filepath'. Two values will be returned: the result of compiling the file and a list of compiler notes.") (:method (image filepath package &optional load-p) (declare (ignore image filepath package load-p)) (error "Backend insufficient for this operation"))) (defgeneric macroexpand-for-drei (image form &optional full-p) (:documentation "Macroexpand `form' and return result.") (:method (image form &optional full-p) (declare (ignore image)) (funcall (if full-p #'macroexpand #'macroexpand-1) form))) (defgeneric find-definitions-for-drei (image symbol) (:documentation "Return list of definitions for `symbol'.") (:method (image symbol) (declare (ignore image symbol)))) (defgeneric get-class-keyword-parameters (image class) (:documentation "Get a list of keyword parameters (possibly along with any default values) that can be used in a `make-instance' form for `class'.") (:method (image class) (declare (ignore image class)))) (defgeneric arglist (image symbol) (:documentation "Get plain arglist for symbol.") (:method (image symbol) (declare (ignore image symbol)))) (defgeneric simple-completions (image string default-package) (:documentation "Return a list of simple symbol-completions for `string' in `default-package'.") (:method (image string default-package) (declare (ignore image string default-package)))) (defgeneric fuzzy-completions (image symbol-name default-package &optional limit) (:documentation "Return a list of fuzzy completions for `symbol-name'.") (:method (image symbol-name default-package &optional limit) (declare (ignore image symbol-name default-package limit)))) ;;; Lexing (define-lexer-state lexer-list-state (lexer-toplevel-state) () (:documentation "In this state, the lexer assumes it can skip whitespace and should recognize ordinary lexemes of the language")) (define-lexer-state lexer-string-state () () (:documentation "In this state, the lexer is working inside a string delimited by double quote characters.")) (define-lexer-state lexer-line-comment-state () () (:documentation "In this state, the lexer is working inside a line comment (starting with a semicolon.")) (define-lexer-state lexer-long-comment-state () () (:documentation "In this state, the lexer is working inside a long comment delimited by #| and |#.")) (define-lexer-state lexer-escaped-token-state () () (:documentation "In this state, the lexer is accumulating a token and an odd number of multiple escapes have been seen.")) (defclass lisp-nonterminal (nonterminal) ()) (defclass form (lisp-nonterminal) ()) (defclass complete-form-mixin () ()) (defclass incomplete-form-mixin () ()) (defclass comment (lisp-nonterminal) ()) (defclass lisp-lexeme (lexeme) ()) (defclass error-lexeme (lisp-lexeme) ()) (defclass literal-object-lexeme (lisp-lexeme literal-object-mixin) ()) (defclass literal-object-error-lexeme (lisp-lexeme literal-object-mixin) ()) (defclass parenthesis-lexeme (lisp-lexeme) ()) (defclass left-parenthesis-lexeme (parenthesis-lexeme) ()) (defclass simple-vector-start-lexeme (lisp-lexeme) ()) (defclass right-parenthesis-lexeme (parenthesis-lexeme) ()) (defclass quote-lexeme (lisp-lexeme) ()) (defclass backquote-lexeme (lisp-lexeme) ()) (defclass comma-lexeme (lisp-lexeme) ()) (defclass comma-at-lexeme (lisp-lexeme) ()) (defclass comma-dot-lexeme (lisp-lexeme) ()) (defclass dot-lexeme (lisp-lexeme) ()) (defclass form-lexeme (form lisp-lexeme) ()) (defclass incomplete-character-lexeme (form-lexeme incomplete-form-mixin) ()) (defclass complete-character-lexeme (form-lexeme complete-form-mixin) ()) (defclass function-lexeme (lisp-lexeme) ()) (defclass line-comment-start-lexeme (lisp-lexeme) ()) (defclass long-comment-start-lexeme (lisp-lexeme) ()) (defclass comment-end-lexeme (lisp-lexeme) ()) (defclass string-start-lexeme (lisp-lexeme) ()) (defclass string-end-lexeme (lisp-lexeme) ()) (defclass word-lexeme (lisp-lexeme) ()) (defclass delimiter-lexeme (lisp-lexeme) ()) (defclass literal-object-delimiter-lexeme (delimiter-lexeme literal-object-lexeme) ()) (defclass text-lexeme (lisp-lexeme) ()) (defclass sharpsign-equals-lexeme (lisp-lexeme) ()) (defclass sharpsign-sharpsign-form (form-lexeme complete-form-mixin) ()) (defclass reader-conditional-positive-lexeme (lisp-lexeme) ()) (defclass reader-conditional-negative-lexeme (lisp-lexeme) ()) (defclass uninterned-symbol-lexeme (lisp-lexeme) ()) (defclass readtime-evaluation-lexeme (lisp-lexeme) ()) (defclass array-start-lexeme (lisp-lexeme) ()) (defclass structure-start-lexeme (lisp-lexeme) ()) (defclass pathname-start-lexeme (lisp-lexeme) ()) (defclass undefined-reader-macro-lexeme (lisp-lexeme) ()) (defclass bit-vector-form (form-lexeme complete-form-mixin) ()) (defclass token-mixin () ()) (defclass number-lexeme (token-mixin form-lexeme complete-form-mixin) ()) (defclass literal-object-form (form-lexeme complete-form-mixin literal-object-mixin) ()) (defclass complete-token-lexeme (token-mixin lisp-lexeme) ()) (defclass multiple-escape-start-lexeme (lisp-lexeme) ()) (defclass multiple-escape-end-lexeme (lisp-lexeme) ()) (defclass incomplete-lexeme (lisp-lexeme incomplete-form-mixin) ()) (defclass unmatched-right-parenthesis-lexeme (lisp-lexeme) ()) (defmethod skip-inter ((syntax lisp-syntax) state scan) (macrolet ((fo () `(forward-object scan))) (loop when (end-of-buffer-p scan) do (return nil) until (not (whitespacep syntax (object-after scan))) do (fo) finally (return t)))) (defmethod lex ((syntax lisp-syntax) (state lexer-toplevel-state) scan) (macrolet ((fo () `(forward-object scan))) (let ((object (object-after scan))) (case object (#\( (fo) (make-instance 'left-parenthesis-lexeme)) (#\) (fo) (make-instance 'unmatched-right-parenthesis-lexeme)) (#\' (fo) (make-instance 'quote-lexeme)) (#\; (fo) (loop until (or (end-of-buffer-p scan) (end-of-line-p scan) (not (eql (object-after scan) #\;))) do (fo)) (make-instance 'line-comment-start-lexeme)) (#\" (fo) (make-instance 'string-start-lexeme)) (#\` (fo) (make-instance 'backquote-lexeme)) (#\, (fo) (cond ((end-of-buffer-p scan) (make-instance 'incomplete-lexeme)) (t (case (object-after scan) (#\@ (fo) (make-instance 'comma-at-lexeme)) (#\. (fo) (make-instance 'comma-dot-lexeme)) (t (make-instance 'comma-lexeme)))))) (#\# (fo) (cond ((end-of-buffer-p scan) (make-instance 'incomplete-lexeme)) (t (let ((prefix 0)) (loop until (end-of-buffer-p scan) while (and (characterp (object-after scan)) (digit-char-p (object-after scan))) do (setf prefix (+ (* 10 prefix) (digit-char-p (object-after scan)))) (fo)) (if (or (end-of-buffer-p scan) (not (characterp (object-after scan)))) (make-instance 'incomplete-lexeme) (case (object-after scan) ((#\Backspace #\Tab #\Newline #\Linefeed #\Page #\Return #\Space #\)) (fo) (make-instance 'error-lexeme)) (#\\ (fo) (cond ((or (end-of-buffer-p scan) (not (characterp (object-after scan)))) (make-instance 'incomplete-character-lexeme)) ((not (constituentp (object-after scan))) (fo) (make-instance 'complete-character-lexeme)) (t (loop until (end-of-buffer-p scan) while (constituentp (object-after scan)) do (fo)) (make-instance 'complete-character-lexeme)))) (#\' (fo) (make-instance 'function-lexeme)) (#\( (fo) (make-instance 'simple-vector-start-lexeme)) (#\* (fo) (loop until (end-of-buffer-p scan) while (or (eql (object-after scan) #\1) (eql (object-after scan) #\0)) do (fo)) (if (and (not (end-of-buffer-p scan)) (constituentp (object-after scan))) (make-instance 'error-lexeme) (make-instance 'bit-vector-form))) (#\: (fo) (make-instance 'uninterned-symbol-lexeme)) (#\. (fo) (make-instance 'readtime-evaluation-lexeme)) ((#\B #\b #\O #\o #\X #\x) (let ((radix (ecase (object-after scan) ((#\B #\b) 2) ((#\O #\o) 8) ((#\X #\x) 16)))) (fo) (when (and (not (end-of-buffer-p scan)) (char= (object-after scan) #\-)) (fo)) (loop until (end-of-buffer-p scan) while (digit-char-p (object-after scan) radix) do (fo))) (if (and (not (end-of-buffer-p scan)) (constituentp (object-after scan))) (make-instance 'error-lexeme) (make-instance 'number-lexeme))) ((#\R #\r) (fo) (cond ((<= 2 prefix 36) (loop until (end-of-buffer-p scan) while (and (characterp (object-after scan)) (digit-char-p (object-after scan) prefix)) do (fo)) (if (and (not (end-of-buffer-p scan)) (constituentp (object-after scan))) (make-instance 'error-lexeme) (make-instance 'number-lexeme))) (t (make-instance 'error-lexeme)))) ;((#\C #\c) ) ((#\A #\a) (fo) (make-instance 'array-start-lexeme)) ((#\S #\s) (fo) (cond ((and (not (end-of-buffer-p scan)) (eql (object-after scan) #\()) (fo) (make-instance 'structure-start-lexeme)) ((end-of-buffer-p scan) (make-instance 'incomplete-lexeme)) (t (make-instance 'error-lexeme)))) ((#\P #\p) (fo) (make-instance 'pathname-start-lexeme)) (#\= (fo) (make-instance 'sharpsign-equals-lexeme)) (#\# (fo) (make-instance 'sharpsign-sharpsign-form)) (#\+ (fo) (make-instance 'reader-conditional-positive-lexeme)) (#\- (fo) (make-instance 'reader-conditional-negative-lexeme)) (#\| (fo) (make-instance 'long-comment-start-lexeme)) (#\< (fo) (make-instance 'error-lexeme)) (t (fo) (make-instance 'undefined-reader-macro-lexeme)))))))) (#\| (fo) (make-instance 'multiple-escape-start-lexeme)) (t (cond ((or (constituentp object) (eql object #\\)) (lex-token syntax scan)) (t (fo) (make-instance 'literal-object-form)))))))) (defmethod lex ((syntax lisp-syntax) (state lexer-list-state) scan) (macrolet ((fo () `(forward-object scan))) (let ((object (object-after scan))) (case object (#\) (fo) (make-instance 'right-parenthesis-lexeme)) (t (call-next-method)))))) (defmethod lex ((syntax lisp-syntax) (state lexer-string-state) scan) (macrolet ((fo () `(forward-object scan))) (let ((object (object-after scan))) (cond ((eql object #\") (fo) (make-instance 'string-end-lexeme)) ((eql object #\\) (fo) (unless (end-of-buffer-p scan) (fo)) (make-instance 'delimiter-lexeme)) ((constituentp object) (loop until (or (end-of-buffer-p scan) (not (constituentp (object-after scan)))) do (fo)) (make-instance 'word-lexeme)) (t (fo) (make-instance (if (characterp object) 'delimiter-lexeme 'literal-object-delimiter-lexeme))))))) (defmethod lex ((syntax lisp-syntax) (state lexer-long-comment-state) scan) (flet ((fo () (forward-object scan))) (let ((object (object-after scan))) (cond ((eql object #\|) (fo) (cond ((or (end-of-buffer-p scan) (not (eql (object-after scan) #\#))) (make-instance 'delimiter-lexeme)) (t (fo) (make-instance 'comment-end-lexeme)))) ((eql object #\#) (fo) (cond ((or (end-of-buffer-p scan) (not (eql (object-after scan) #\|))) (make-instance 'delimiter-lexeme)) (t (fo) (make-instance 'long-comment-start-lexeme)))) ((constituentp object) (loop until (or (end-of-buffer-p scan) (not (constituentp (object-after scan)))) do (fo)) (make-instance 'word-lexeme)) (t (fo) (make-instance (if (characterp object) 'delimiter-lexeme 'literal-object-delimiter-lexeme))))))) (defmethod skip-inter ((syntax lisp-syntax) (state lexer-line-comment-state) scan) (macrolet ((fo () `(forward-object scan))) (loop until (or (end-of-line-p scan) (not (whitespacep syntax (object-after scan)))) do (fo) finally (return t)))) (defmethod lex ((syntax lisp-syntax) (state lexer-line-comment-state) scan) (macrolet ((fo () `(forward-object scan))) (cond ((end-of-line-p scan) (make-instance 'comment-end-lexeme)) ((constituentp (object-after scan)) (loop until (or (end-of-buffer-p scan) (not (constituentp (object-after scan)))) do (fo)) (make-instance 'word-lexeme)) (t (fo) (make-instance (if (characterp (object-before scan)) 'delimiter-lexeme 'literal-object-delimiter-lexeme)))))) (defun lex-token (syntax scan) ;; May need more work. Can recognize symbols and numbers. This can ;; get very ugly and complicated (out of necessity I believe). (let ((could-be-number t) sign-seen dot-seen slash-seen nondot-seen number-seen exponent-seen) (flet ((fo () (forward-object scan)) (return-token-or-number-lexeme () (return-from lex-token (if (and could-be-number (if exponent-seen nondot-seen t)) (if nondot-seen (make-instance 'number-lexeme) (make-instance 'dot-lexeme)) (make-instance 'complete-token-lexeme)))) (this-object () (object-after scan))) (tagbody START (when (end-of-buffer-p scan) (return-token-or-number-lexeme)) (when (constituentp (object-after scan)) (when (not (eql (this-object) #\.)) (setf nondot-seen t)) (cond ((or (eql (this-object) #\+) (eql (this-object) #\-)) (when (or sign-seen number-seen slash-seen) (setf could-be-number nil)) (setf sign-seen t)) ((eql (this-object) #\.) (when (or dot-seen exponent-seen) (setf could-be-number nil)) (setf dot-seen t)) ((member (this-object) '(#\e #\f #\l #\s #\d) :test #'equalp) (when exponent-seen (setf could-be-number nil)) (setf exponent-seen t) (setf number-seen nil) (setf sign-seen nil)) ((eql (this-object) #\/) (when (or slash-seen dot-seen exponent-seen) (setf could-be-number nil)) (setf slash-seen t)) ((not (digit-char-p (this-object) (base syntax))) (setf could-be-number nil)) (t (setf number-seen t))) (fo) (go START)) (when (eql (object-after scan) #\\) (fo) (when (end-of-buffer-p scan) (return-from lex-token (make-instance 'incomplete-lexeme))) (fo) (go START)) (when (eql (object-after scan) #\|) (fo) (return-from lex-token (make-instance 'multiple-escape-start-lexeme))) (return-token-or-number-lexeme))))) (defmethod lex ((syntax lisp-syntax) (state lexer-escaped-token-state) scan) (let ((bars-seen 0)) (macrolet ((fo () `(forward-object scan))) (flet ((end () (return-from lex (if (oddp bars-seen) (make-instance 'multiple-escape-end-lexeme) (make-instance 'text-lexeme))))) (tagbody start (when (end-of-buffer-p scan) (end)) (when (eql (object-after scan) #\\) (fo) (when (end-of-buffer-p scan) (return-from lex (make-instance 'incomplete-lexeme))) (fo) (go start)) (when (eql (object-after scan) #\|) (incf bars-seen) (fo) (go start)) (if (evenp bars-seen) (unless (whitespacep syntax (object-after scan)) (fo) (go start)) (when (constituentp (object-after scan)) (fo) (go start))) (end)))))) (defmethod lex ((syntax lisp-syntax) (state lexer-error-state) scan) (macrolet ((fo () `(forward-object scan))) (cond ((not (or (end-of-buffer-p scan) (characterp (object-after scan)))) (fo) (make-instance 'literal-object-error-lexeme)) (t (loop until (end-of-line-p scan) do (fo)) (make-instance 'error-lexeme))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; nonterminals (defclass line-comment (lisp-nonterminal) ()) (defclass long-comment (lisp-nonterminal) ()) (defclass error-symbol (lisp-nonterminal) ()) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; parser (defmacro define-lisp-action ((state lexeme) &body body) `(defmethod action ((syntax lisp-syntax) (state ,state) (lexeme ,lexeme)) ,@body)) (defmacro define-new-lisp-state ((state parser-symbol) &body body) `(defmethod new-state ((syntax lisp-syntax) (state ,state) (tree ,parser-symbol)) ,@body)) (define-lisp-action (error-reduce-state (eql nil)) (throw 'done nil)) ;;; the default action for any lexeme is shift (define-lisp-action (t lisp-lexeme) lexeme) ;;; the action on end-of-buffer is to reduce to the error symbol (define-lisp-action (t (eql nil)) (reduce-all error-symbol)) ;;; the default new state is the error state (define-new-lisp-state (t parser-symbol) error-state) ;;; the new state when an error-state (define-new-lisp-state (t error-symbol) error-reduce-state) ;;;;;;;;;;;;;;;; Top-level #| rules form* -> form* -> form* form |# ;;; parse trees (defclass form* (lisp-nonterminal) ()) (define-parser-state |form* | (lexer-toplevel-state parser-state) ()) (define-parser-state form-may-follow (lexer-toplevel-state parser-state) ()) (define-parser-state |initial-state | (form-may-follow) ()) (define-new-lisp-state (|initial-state | form) |initial-state |) (define-new-lisp-state (|initial-state | comment) |initial-state |) ;; skip over unmatched right parentheses (define-new-lisp-state (|initial-state | unmatched-right-parenthesis-lexeme) |initial-state |) (define-lisp-action (|initial-state | (eql nil)) (reduce-all form*)) (define-new-lisp-state (|initial-state | form*) |form* | ) (define-lisp-action (|form* | (eql nil)) (throw 'done nil)) ;;;;;;;;;;;;;;;; List #| rules form -> ( form* ) |# ;;; parse trees (defclass list-form (form) ()) (defclass complete-list-form (list-form complete-form-mixin) ()) (defclass incomplete-list-form (list-form incomplete-form-mixin) ()) (define-parser-state |( form* | (lexer-list-state form-may-follow) ()) (define-parser-state |( form* ) | (lexer-toplevel-state parser-state) ()) (define-new-lisp-state (form-may-follow left-parenthesis-lexeme) |( form* |) (define-new-lisp-state (|( form* | form) |( form* |) (define-new-lisp-state (|( form* | comment) |( form* |) (define-new-lisp-state (|( form* | right-parenthesis-lexeme) |( form* ) |) ;;; reduce according to the rule form -> ( form* ) (define-lisp-action (|( form* ) | t) (reduce-until-type complete-list-form left-parenthesis-lexeme)) ;;; reduce at the end of the buffer (define-lisp-action (|( form* | (eql nil)) (reduce-until-type incomplete-list-form left-parenthesis-lexeme t)) ;;;;;;;;;;;;;;;; Cons cell ;; Also (foo bar baz . quux) constructs. ;; (foo bar . baz quux) flagged as an error (too aggressively?). ;;; parse trees (defclass cons-cell-form (form) ()) (defclass complete-cons-cell-form (cons-cell-form complete-list-form) ()) (defclass incomplete-cons-cell-form (cons-cell-form incomplete-list-form) ()) (define-parser-state |( form* dot-lexeme | (lexer-list-state form-may-follow) ()) (define-parser-state |( form* dot-lexeme form | (lexer-list-state form-may-follow) ()) (define-parser-state |( form* dot-lexeme form ) | (lexer-toplevel-state parser-state) ()) (define-new-lisp-state (|( form* | dot-lexeme) |( form* dot-lexeme |) (define-new-lisp-state (|( form* dot-lexeme | form) |( form* dot-lexeme form |) (define-new-lisp-state (|( form* dot-lexeme | comment) |( form* dot-lexeme |) (define-new-lisp-state (|( form* dot-lexeme form | right-parenthesis-lexeme) |( form* dot-lexeme form ) |) (define-new-lisp-state (|( form* dot-lexeme form | comment) |( form* dot-lexeme form |) (define-lisp-action (|( form* dot-lexeme form ) | t) (reduce-until-type complete-cons-cell-form left-parenthesis-lexeme)) ;;; Reduce at end of buffer. (define-lisp-action (|( form* dot-lexeme | (eql nil)) (reduce-until-type incomplete-cons-cell-form left-parenthesis-lexeme t)) (define-lisp-action (|( form* dot-lexeme form | (eql nil)) (reduce-until-type incomplete-cons-cell-form left-parenthesis-lexeme t)) ;;;;;;;;;;;;;;;; Simple Vector ;;; parse trees (defclass simple-vector-form (list-form) ()) (defclass complete-simple-vector-form (complete-list-form simple-vector-form) ()) (defclass incomplete-simple-vector-form (incomplete-list-form simple-vector-form) ()) (define-parser-state |#( form* | (lexer-list-state form-may-follow) ()) (define-parser-state |#( form* ) | (lexer-toplevel-state parser-state) ()) (define-new-lisp-state (form-may-follow simple-vector-start-lexeme) |#( form* |) (define-new-lisp-state (|#( form* | form) |#( form* |) (define-new-lisp-state (|#( form* | comment) |#( form* |) (define-new-lisp-state (|#( form* | right-parenthesis-lexeme) |#( form* ) |) ;;; reduce according to the rule form -> #( form* ) (define-lisp-action (|#( form* ) | t) (reduce-until-type complete-simple-vector-form simple-vector-start-lexeme)) ;;; reduce at the end of the buffer (define-lisp-action (|#( form* | (eql nil)) (reduce-until-type incomplete-simple-vector-form simple-vector-start-lexeme t)) ;;;;;;;;;;;;;;;; String ;;; parse trees (defclass string-form (form) ()) (defclass complete-string-form (string-form complete-form-mixin) ()) (defclass incomplete-string-form (string-form incomplete-form-mixin) ()) (define-parser-state |" word* | (lexer-string-state parser-state) ()) (define-parser-state |" word* " | (lexer-toplevel-state parser-state) ()) (define-new-lisp-state (|" word* | word-lexeme) |" word* |) (define-new-lisp-state (|" word* | delimiter-lexeme) |" word* |) (define-new-lisp-state (form-may-follow string-start-lexeme) |" word* |) (define-new-lisp-state (|" word* | string-end-lexeme) |" word* " |) ;;; reduce according to the rule form -> " word* " (define-lisp-action (|" word* " | t) (reduce-until-type complete-string-form string-start-lexeme)) ;;; reduce at the end of the buffer (define-lisp-action (|" word* | (eql nil)) (reduce-until-type incomplete-string-form string-start-lexeme t)) ;;;;;;;;;;;;;;;; Line comment ;;; parse trees (defclass line-comment-form (comment) ()) (define-parser-state |; word* | (lexer-line-comment-state parser-state) ()) (define-parser-state |; word* NL | (lexer-toplevel-state parser-state) ()) (define-new-lisp-state (form-may-follow line-comment-start-lexeme) |; word* |) (define-new-lisp-state (|; word* | word-lexeme) |; word* |) (define-new-lisp-state (|; word* | delimiter-lexeme) |; word* |) (define-new-lisp-state (|; word* | comment-end-lexeme) |; word* NL |) ;;; reduce according to the rule form -> ; word* NL (define-lisp-action (|; word* NL | t) (reduce-until-type line-comment-form line-comment-start-lexeme)) ;;;;;;;;;;;;;;;; Long comment ;;; parse trees (defclass long-comment-form (comment) ()) (defclass complete-long-comment-form (long-comment-form complete-form-mixin) ()) (defclass incomplete-long-comment-form (long-comment-form incomplete-form-mixin) ()) (define-parser-state |#\| word* | (lexer-long-comment-state parser-state) ()) (define-parser-state |#\| word* \|# | (lexer-toplevel-state parser-state) ()) (define-new-lisp-state (|#\| word* | word-lexeme) |#\| word* |) (define-new-lisp-state (|#\| word* | delimiter-lexeme) |#\| word* |) (define-new-lisp-state (|#\| word* | long-comment-start-lexeme) |#\| word* |) (define-new-lisp-state (|#\| word* | long-comment-form) |#\| word* |) (define-new-lisp-state (form-may-follow long-comment-start-lexeme) |#\| word* |) (define-new-lisp-state (|#\| word* | comment-end-lexeme) |#\| word* \|# |) ;;; reduce according to the rule form -> #| word* |# (define-lisp-action (|#\| word* \|# | t) (reduce-until-type complete-long-comment-form long-comment-start-lexeme)) ;;; reduce at the end of the buffer (define-lisp-action (|#\| word* | (eql nil)) (reduce-until-type incomplete-long-comment-form long-comment-start-lexeme t)) ;;;;;;;;;;;;;;;; Token (number or symbol) ;;; parse trees (defclass token-form (form token-mixin) ()) (defclass complete-token-form (token-form complete-form-mixin) ((%keyword-symbol-p :accessor keyword-symbol-p) (%macroboundp :accessor macroboundp) (%global-boundp :accessor global-boundp))) (defclass incomplete-token-form (token-form incomplete-form-mixin) ()) (define-parser-state | complete-lexeme | (lexer-list-state parser-state) ()) (define-parser-state | m-e-start text* | (lexer-escaped-token-state parser-state) ()) (define-parser-state | m-e-start text* m-e-end | (lexer-toplevel-state parser-state) ()) (define-new-lisp-state (form-may-follow complete-token-lexeme) | complete-lexeme |) (define-new-lisp-state (form-may-follow multiple-escape-start-lexeme) | m-e-start text* |) (define-new-lisp-state (| m-e-start text* | text-lexeme) | m-e-start text* |) (define-new-lisp-state (| m-e-start text* | multiple-escape-end-lexeme) | m-e-start text* m-e-end |) ;;; reduce according to the rule form -> complete-lexeme (define-lisp-action (| complete-lexeme | t) (reduce-until-type complete-token-form complete-token-lexeme)) ;;; reduce according to the rule form -> m-e-start text* m-e-end (define-lisp-action (| m-e-start text* m-e-end | t) (reduce-until-type complete-token-form multiple-escape-start-lexeme)) ;;; reduce at the end of the buffer (define-lisp-action (| m-e-start text* | (eql nil)) (reduce-until-type incomplete-token-form multiple-escape-start-lexeme t)) ;;;;;;;;;;;;;;;; Quote ;;; parse trees (defclass quote-form (form) ()) (defclass complete-quote-form (quote-form complete-form-mixin) ()) (defclass incomplete-quote-form (quote-form incomplete-form-mixin) ()) (define-parser-state |' | (form-may-follow) ()) (define-parser-state |' form | (lexer-toplevel-state parser-state) ()) (define-parser-state |' incomplete-form | (lexer-toplevel-state parser-state) ()) (define-new-lisp-state (form-may-follow quote-lexeme) |' |) (define-new-lisp-state (|' | complete-form-mixin) |' form |) (define-new-lisp-state (|' | incomplete-form-mixin) |' incomplete-form |) (define-new-lisp-state (|' | comment) |' |) (define-new-lisp-state (|' | unmatched-right-parenthesis-lexeme) |( form* ) |) ;;; reduce according to the rule form -> ' form (define-lisp-action (|' form | t) (reduce-until-type complete-quote-form quote-lexeme)) (define-lisp-action (|' incomplete-form | t) (reduce-until-type incomplete-quote-form quote-lexeme)) (define-lisp-action (|' | right-parenthesis-lexeme) (reduce-until-type incomplete-quote-form quote-lexeme)) (define-lisp-action (|' | unmatched-right-parenthesis-lexeme) (reduce-until-type incomplete-quote-form quote-lexeme)) (define-lisp-action (|' | (eql nil)) (reduce-until-type incomplete-quote-form quote-lexeme t)) ;;;;;;;;;;;;;;;; Backquote ;;; parse trees (defclass backquote-form (form) ()) (defclass complete-backquote-form (backquote-form complete-form-mixin) ()) (defclass incomplete-backquote-form (backquote-form incomplete-form-mixin) ()) (define-parser-state |` | (form-may-follow) ()) (define-parser-state |` form | (lexer-toplevel-state parser-state) ()) (define-new-lisp-state (form-may-follow backquote-lexeme) |` |) (define-new-lisp-state (|` | complete-form-mixin) |` form |) (define-new-lisp-state (|` | comment) |` |) (define-new-lisp-state (|` | unmatched-right-parenthesis-lexeme) |( form* ) |) ;;; reduce according to the rule form -> ` form (define-lisp-action (|` form | t) (reduce-until-type complete-backquote-form backquote-lexeme)) (define-lisp-action (|` | right-parenthesis-lexeme) (reduce-until-type incomplete-backquote-form backquote-lexeme)) (define-lisp-action (|` | unmatched-right-parenthesis-lexeme) (reduce-until-type incomplete-backquote-form backquote-lexeme)) (define-lisp-action (|` | (eql nil)) (reduce-until-type incomplete-backquote-form backquote-lexeme t)) ;;;;;;;;;;;;;;;; Comma ;;; parse trees (defclass comma-form (form complete-form-mixin) ()) (defclass comma-at-form (form complete-form-mixin) ()) (defclass comma-dot-form (form complete-form-mixin) ()) (define-parser-state |, | (form-may-follow) ()) (define-parser-state |, form | (lexer-toplevel-state parser-state) ()) (define-parser-state |,@ | (form-may-follow) ()) (define-parser-state |,@ form | (lexer-toplevel-state parser-state) ()) (define-parser-state |,. | (form-may-follow) ()) (define-parser-state |,. form | (lexer-toplevel-state parser-state) ()) (define-new-lisp-state (form-may-follow comma-lexeme) |, |) (define-new-lisp-state (form-may-follow comma-at-lexeme) |,@ |) (define-new-lisp-state (form-may-follow comma-dot-lexeme) |,. |) (define-new-lisp-state (|, | form) |, form |) (define-new-lisp-state (|, | comment) |, |) (define-new-lisp-state (|,@ | form) |,@ form |) (define-new-lisp-state (|,@ | comment) |,@ |) (define-new-lisp-state (|,. | form) |,. form |) (define-new-lisp-state (|,. | comment) |,. |) ;;; reduce according to the rule form -> , form (define-lisp-action (|, form | t) (reduce-until-type comma-form comma-lexeme)) (define-lisp-action (|,@ form | t) (reduce-until-type comma-at-form comma-at-lexeme)) (define-lisp-action (|,. form | t) (reduce-until-type comma-dot-form comma-dot-lexeme)) ;;;;;;;;;;;;;;;; Function ;;; parse trees (defclass function-form (form) ()) (defclass complete-function-form (function-form complete-form-mixin) ()) (defclass incomplete-function-form (function-form incomplete-form-mixin) ()) (define-parser-state |#' | (form-may-follow) ()) (define-parser-state |#' form | (lexer-toplevel-state parser-state) ()) (define-new-lisp-state (form-may-follow function-lexeme) |#' |) (define-new-lisp-state (|#' | complete-form-mixin) |#' form |) (define-new-lisp-state (|#' | comment) |#' |) ;;; reduce according to the rule form -> #' form (define-lisp-action (|#' form | t) (reduce-until-type complete-function-form function-lexeme)) (define-lisp-action (|#' | unmatched-right-parenthesis-lexeme) (reduce-until-type incomplete-function-form function-lexeme)) (define-lisp-action (|#' | (eql nil)) (reduce-until-type incomplete-function-form function-lexeme t)) ;;;;;;;;;;;;;;;; Reader conditionals ;;; parse trees (defclass reader-conditional-form (form) ((%conditional-true-p :accessor conditional-true-p))) (defclass reader-conditional-positive-form (reader-conditional-form) ()) (defclass reader-conditional-negative-form (reader-conditional-form) ()) (define-parser-state |#+ | (form-may-follow) ()) (define-parser-state |#+ form | (form-may-follow) ()) (define-parser-state |#+ form form | (lexer-toplevel-state parser-state) ()) (define-parser-state |#- | (form-may-follow) ()) (define-parser-state |#- form | (form-may-follow) ()) (define-parser-state |#- form form | (lexer-toplevel-state parser-state) ()) (define-new-lisp-state (form-may-follow reader-conditional-positive-lexeme) |#+ |) (define-new-lisp-state (|#+ | form) |#+ form |) (define-new-lisp-state (|#+ form | form) |#+ form form |) (define-new-lisp-state (|#+ | comment) |#+ |) (define-new-lisp-state (|#+ form | comment) |#+ form |) (define-new-lisp-state (form-may-follow reader-conditional-negative-lexeme) |#- |) (define-new-lisp-state (|#- | form) |#- form |) (define-new-lisp-state (|#- form | form) |#- form form |) (define-new-lisp-state (|#- | comment) |#- |) (define-new-lisp-state (|#- form | comment) |#- form |) (define-lisp-action (|#+ form form | t) (reduce-until-type reader-conditional-positive-form reader-conditional-positive-lexeme)) (define-lisp-action (|#- form form | t) (reduce-until-type reader-conditional-negative-form reader-conditional-negative-lexeme)) ;;;;;;;;;;;;;;;; uninterned symbol ;;; parse trees (defclass uninterned-symbol-form (complete-token-form) ()) (define-parser-state |#: | (form-may-follow) ()) (define-parser-state |#: form | (lexer-toplevel-state parser-state) ()) (define-new-lisp-state (form-may-follow uninterned-symbol-lexeme) |#: |) (define-new-lisp-state (|#: | form) |#: form |) ;;; reduce according to the rule form -> #: form (define-lisp-action (|#: form | t) (reduce-fixed-number uninterned-symbol-form 2)) ;;;;;;;;;;;;;;;; readtime evaluation ;;; parse trees (defclass readtime-evaluation-form (form complete-form-mixin) ()) (define-parser-state |#. | (form-may-follow) ()) (define-parser-state |#. form | (lexer-toplevel-state parser-state) ()) (define-new-lisp-state (form-may-follow readtime-evaluation-lexeme) |#. |) (define-new-lisp-state (|#. | form) |#. form |) (define-new-lisp-state (|#. | comment) |#. |) ;;; reduce according to the rule form -> #. form (define-lisp-action (|#. form | t) (reduce-until-type readtime-evaluation-form readtime-evaluation-lexeme)) ;;;;;;;;;;;;;;;; sharpsign equals ;;; parse trees (defclass sharpsign-equals-form (form complete-form-mixin) ()) (define-parser-state |#= | (form-may-follow) ()) (define-parser-state |#= form | (lexer-toplevel-state parser-state) ()) (define-new-lisp-state (form-may-follow sharpsign-equals-lexeme) |#= |) (define-new-lisp-state (|#= | form) |#= form |) (define-new-lisp-state (|#= | comment) |#= |) ;;; reduce according to the rule form -> #= form (define-lisp-action (|#= form | t) (reduce-until-type sharpsign-equals-form sharpsign-equals-lexeme)) ;;;;;;;;;;;;;;;; array ;;; parse trees (defclass array-form (form complete-form-mixin) ()) (define-parser-state |#A | (form-may-follow) ()) (define-parser-state |#A form | (lexer-toplevel-state parser-state) ()) (define-new-lisp-state (form-may-follow array-start-lexeme) |#A |) (define-new-lisp-state (|#A | form) |#A form |) (define-new-lisp-state (|#A | comment) |#A |) ;;; reduce according to the rule form -> #A form (define-lisp-action (|#A form | t) (reduce-until-type array-form array-start-lexeme)) ;;;;;;;;;;;;;;;; structure ;;; parse trees (defclass structure-form (list-form) ()) (defclass complete-structure-form (complete-list-form) ()) (defclass incomplete-structure-form (incomplete-list-form) ()) (define-parser-state |#S( form* | (lexer-list-state form-may-follow) ()) (define-parser-state |#S( form* ) | (lexer-toplevel-state parser-state) ()) (define-new-lisp-state (form-may-follow structure-start-lexeme) |#S( form* |) (define-new-lisp-state (|#S( form* | form) |#S( form* |) (define-new-lisp-state (|#S( form* | right-parenthesis-lexeme) |#S( form* ) |) ;;; reduce according to the rule form -> #S( form* ) (define-lisp-action (|#S( form* ) | t) (reduce-until-type complete-structure-form structure-start-lexeme)) ;;; reduce at the end of the buffer (define-lisp-action (|#S( form* | (eql nil)) (reduce-until-type incomplete-structure-form structure-start-lexeme t)) ;;;;;;;;;;;;;;;; pathname ;;; NB: #P need not be followed by a string, ;;; as it could be followed by a #. construct instead (or some other reader macro) ;;; parse trees (defclass pathname-form (form) ()) (defclass complete-pathname-form (pathname-form complete-form-mixin) ()) (defclass incomplete-pathname-form (pathname-form incomplete-form-mixin) ()) (define-parser-state |#P | (form-may-follow) ()) (define-parser-state |#P form | (lexer-toplevel-state parser-state) ()) (define-parser-state |#P incomplete-form | (lexer-toplevel-state parser-state) ()) (define-new-lisp-state (form-may-follow pathname-start-lexeme) |#P |) (define-new-lisp-state (|#P | complete-form-mixin) |#P form |) (define-new-lisp-state (|#P | incomplete-form-mixin) |#P incomplete-form |) (define-new-lisp-state (|#P | comment) |#P |) ;;; reduce according to the rule form -> #P form (define-lisp-action (|#P form | t) (reduce-until-type complete-pathname-form pathname-start-lexeme)) (define-lisp-action (|#P incomplete-form | t) (reduce-until-type incomplete-pathname-form pathname-start-lexeme)) (define-lisp-action (|#P | (eql nil)) (reduce-until-type incomplete-pathname-form pathname-start-lexeme t)) ;;;;;;;;;;;;;;;; undefined reader macro ;;; parse trees (defclass undefined-reader-macro-form (form complete-form-mixin) ()) (define-parser-state |# | (form-may-follow) ()) (define-parser-state |# form | (lexer-toplevel-state parser-state) ()) (define-new-lisp-state (form-may-follow undefined-reader-macro-lexeme) |# |) (define-new-lisp-state (|# | form) |# form |) ;;; reduce according to the rule form -> # form (define-lisp-action (|# form | t) (reduce-fixed-number undefined-reader-macro-form 2)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; update syntax (defun package-at-mark (syntax mark-or-offset) "Get the specified Lisp package for the syntax. First, an attempt will be made to find the package specified in the (in-package) preceding `mark-or-offset'. If none can be found, return the package specified in the attribute list. If no package can be found at all, or the otherwise found packages are invalid, return the value of `*package*'." (as-offsets ((offset mark-or-offset)) (update-parse syntax) (let* ((designator (rest (find offset (package-list syntax) :key #'first :test #'>=)))) (or (handler-case (find-package designator) (type-error () nil)) (let ((osp (option-specified-package syntax))) (typecase osp (package osp) (string (find-package osp)))) (find-package (option-specified-package syntax)) *package*)))) (defun provided-package-name-at-mark (syntax mark-or-offset) "Get the name of the specified Lisp package for the syntax. This will return a normalised version of whatever (in-package) form precedes `mark-or-offset', even if the package specified in that form does not exist. If no (in-package) form can be found, return the package specified in the attribute list. If no such package is specified, return \"CLIM-USER\"." (as-offsets ((offset mark-or-offset)) (update-parse syntax) (flet ((normalise (designator) (typecase designator (symbol (symbol-name designator)) (string designator) (package (package-name designator))))) (let* ((designator (rest (find offset (package-list syntax) :key #'first :test #'>=)))) (normalise (or designator (option-specified-package syntax) :clim-user)))))) (defmacro with-syntax-package ((syntax offset) &body body) "Evaluate `body' with `*package*' bound to a valid package, preferably taken from `syntax' based on `offset'." `(let ((*package* (package-at-mark ,syntax ,offset))) ,@body)) (defun need-to-update-package-list-p (prefix-size suffix-size syntax) (let ((low-mark-offset prefix-size) (high-mark-offset (- (size (buffer syntax)) suffix-size))) (flet ((test (x) (let ((start-offset (start-offset x)) (end-offset (end-offset x))) (when (and (or (<= start-offset low-mark-offset end-offset high-mark-offset) (<= low-mark-offset start-offset high-mark-offset end-offset) (<= low-mark-offset start-offset end-offset high-mark-offset) (<= start-offset low-mark-offset high-mark-offset end-offset)) (typep x 'complete-list-form)) (let ((candidate (first-form (children x)))) (and (form-token-p candidate) (eq (form-to-object syntax candidate :no-error t) 'cl:in-package))))))) (with-slots (stack-top) syntax (or (not (slot-boundp syntax '%package-list)) (loop for child in (children stack-top) when (test child) do (return t)) (loop for (offset . nil) in (package-list syntax) unless (and (>= (size (buffer syntax)) offset) (form-list-p (form-around syntax offset))) do (return t))))))) (defun update-package-list (syntax) (setf (package-list syntax) nil) (flet ((test (x) (when (form-list-p x) (let ((candidate (first-form (children x)))) (and (form-token-p candidate) (eq (form-to-object syntax candidate :no-error t) 'cl:in-package) (second-form (children x)))))) (extract (x) (let ((designator (second-form (children x)))) (form-to-object syntax designator :no-error t)))) (with-slots (stack-top) syntax (loop for child in (children stack-top) when (test child) do (push (cons (end-offset child) (extract child)) (package-list syntax)))))) (defmethod update-syntax :after ((syntax lisp-syntax) prefix-size suffix-size &optional begin end) (declare (ignore begin end)) (setf (form-before-cache syntax) (make-hash-table :test #'equal) (form-after-cache syntax) (make-hash-table :test #'equal) (form-around-cache syntax) (make-hash-table :test #'equal)) (when (need-to-update-package-list-p prefix-size suffix-size syntax) (update-package-list syntax))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; accessing parser forms (defun first-noncomment (list) "Returns the first non-comment in list." (find-if-not #'comment-p list)) (defun rest-noncomments (list) "Returns the remainder of the list after the first non-comment, stripping leading comments." (loop for rest on list count (not (comment-p (car rest))) into forms until (= forms 2) finally (return rest))) (defun nth-noncomment (n list) "Returns the nth non-comment in list." (loop for item in list count (not (comment-p item)) into forms until (> forms n) finally (return item))) (defun elt-noncomment (list n) "Returns the nth non-comment in list." (nth-noncomment n list)) (defun second-noncomment (list) "Returns the second non-comment in list." (nth-noncomment 1 list)) (defun third-noncomment (list) "Returns the third non-comment in list." (nth-noncomment 2 list)) (defun rest-forms (list) "Returns the remainder of the list after the first form, stripping leading non-forms." (loop for rest on list count (formp (car rest)) into forms until (= forms 2) finally (return rest))) (defun nth-form (n list) "Returns the nth form in list or `nil'." (loop for item in list count (formp item) into forms until (> forms n) finally (when (> forms n) (return item)))) (defun elt-form (list n) "Returns the nth form in list or `nil'." (nth-form n list)) (defun first-form (list) "Returns the first form in list." (nth-form 0 list)) (defun second-form (list) "Returns the second form in list." (nth-form 1 list)) (defun third-form (list) "Returns the third formw in list." (nth-form 2 list)) (defun form-children (form) "Return the children of `form' that are themselves forms." (remove-if-not #'formp (children form))) (defgeneric form-operator (form) (:documentation "Return the operator of `form' as a token. Returns nil if none can be found.") (:method (form) nil)) (defmethod form-operator ((form list-form)) (first-form (rest (children form)))) (defmethod form-operator ((form complete-quote-form)) (first-form (rest (children (second (children form)))))) (defmethod form-operator ((form complete-backquote-form)) (first-form (rest (children (second (children form)))))) (defgeneric form-operands (form) (:documentation "Returns the operands of `form' as a list of tokens. Returns nil if none can be found.") (:method (syntax) nil)) (defmethod form-operands ((form list-form)) (remove-if-not #'formp (rest-forms (children form)))) (defun form-toplevel (syntax form) "Return the top-level form of `form'." (if (null (parent (parent form))) form (form-toplevel syntax (parent form)))) (defgeneric form-operator-p (syntax token) (:documentation "Return true if `token' is the operator of its form. Otherwise, return nil.") (:method ((syntax lisp-syntax) (token lisp-lexeme)) (with-accessors ((pre-token preceding-parse-tree)) token (cond ((typep pre-token 'left-parenthesis-lexeme) t) ((comment-p pre-token) (form-operator-p syntax pre-token)) (t nil))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Useful functions for selecting forms based on the mark. (defun expression-at-mark (syntax mark-or-offset) "Return the form closest to `mark-or-offset'." (as-offsets ((offset mark-or-offset)) (flet ((distance (form) (min (abs (- (start-offset form) offset)) (abs (- (end-offset form) offset))))) (reduce #'(lambda (form1 form2) (cond ((null form1) form2) ((null form2) form1) ((> (distance form1) (distance form2)) form2) (t form1))) (list (form-around syntax offset) (form-after syntax offset) (form-before syntax offset)))))) (defun definition-at-mark (syntax mark-or-offset) "Return the top-level form at `mark-or-offset'. If `mark-or-offset' is just after, or inside, a top-level-form, or if there are no forms after `mark-or-offset', the top-level-form preceding `mark-or-offset' is returned. Otherwise, the top-level-form following `mark-or-offset' is returned." (form-toplevel syntax (expression-at-mark syntax mark-or-offset))) (defun form-of-type-at-mark (syntax mark-or-offset test) "Return the form that `mark-or-offset' is inside and for which `test' returns true, or NIL if no such form exists." (as-offsets ((offset mark-or-offset)) (update-parse syntax) (let ((form-around (form-around syntax offset))) (when form-around (if (and (funcall test form-around) (> offset (start-offset form-around))) form-around (find-list-parent form-around)))))) (defun list-at-mark (syntax mark-or-offset) "Return the list form that `mark-or-offset' is inside, or NIL if no such form exists." (form-of-type-at-mark syntax mark-or-offset #'form-list-p)) (defun symbol-at-mark (syntax mark-or-offset &optional (form-fetcher 'expression-at-mark)) "Return a symbol token at `mark-or-offset'. This function will \"unwrap\" quote-forms in order to return the symbol token. If no symbol token can be found, NIL will be returned. `Form-fetcher' must be a function with the same signature as `expression-at-mark', and will be used to retrieve the initial form at `mark'." (as-offsets (mark-or-offset) (let ((unwrapped-form (fully-unquoted-form (funcall form-fetcher syntax mark-or-offset)))) (when (form-token-p unwrapped-form) unwrapped-form)))) (defun fully-quoted-form (token) "Return the top token object for `token', return `token' or the top quote-form that `token' is buried in. " (labels ((ascend (form) (cond ((form-quoted-p (parent form)) (ascend (parent form))) (t form)))) (ascend token))) (defun fully-unquoted-form (token) "Return the bottom token object for `token', return `token' or the form that `token' quotes, peeling away all quote forms." (labels ((descend (form) (cond ((and (form-quoted-p form) (rest (children form))) (descend (first-form (children form)))) (t form)))) (descend token))) (defun this-form (syntax mark-or-offset) "Return a form at `mark-or-offset'. This function defines which forms the COM-FOO-this commands affect." (as-offsets ((offset mark-or-offset)) (or (form-around syntax offset) (form-before syntax offset)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Querying forms for data (defmacro define-form-predicate (name (&rest t-classes) &optional documentation) "Define a generic function named `name', taking a single argument. A default method that returns NIL will be defined, and methods returning T will be defined for all classes in `t-classes'." `(progn (defgeneric ,name (form) (:documentation ,(or documentation "Check `form' for something.")) (:method (form) nil)) ,@(loop for class in t-classes collecting `(defmethod ,name ((form ,class)) t)))) (define-form-predicate formp (form)) (define-form-predicate form-list-p (complete-list-form incomplete-list-form)) (define-form-predicate form-incomplete-p (incomplete-form-mixin)) (define-form-predicate form-complete-p (complete-form-mixin)) (define-form-predicate form-token-p (token-mixin)) (define-form-predicate form-string-p (string-form)) (define-form-predicate form-quoted-p (quote-form backquote-form)) (define-form-predicate form-comma-p (comma-form)) (define-form-predicate form-comma-at-p (comma-at-form)) (define-form-predicate form-comma-dot-p (comma-dot-form)) (define-form-predicate form-character-p (complete-character-lexeme incomplete-character-lexeme)) (define-form-predicate form-simple-vector-p (simple-vector-form)) (define-form-predicate comment-p (comment)) (define-form-predicate line-comment-p (line-comment-form)) (define-form-predicate long-comment-p (long-comment-form)) (defgeneric form-at-top-level-p (form) (:documentation "Return NIL if `form' is not a top-level-form, T otherwise.") (:method ((form parser-symbol)) (or (typep (parent form) 'form*) (null (parent form))))) (defgeneric eval-feature-conditional (conditional-form syntax)) (defmethod eval-feature-conditional (conditional-form (syntax lisp-syntax)) nil) ;; Adapted from slime.el (defmethod eval-feature-conditional ((conditional token-mixin) (syntax lisp-syntax)) (let* ((string (form-string syntax conditional)) (symbol (parse-symbol string :package +keyword-package+))) (member symbol *features*))) (defmethod eval-feature-conditional ((conditional list-form) (syntax lisp-syntax)) (let ((children (children conditional))) (when (third-noncomment children) (flet ((eval-fc (conditional) (funcall #'eval-feature-conditional conditional syntax))) (let* ((type (second-noncomment children)) (conditionals (butlast (nthcdr 2 (remove-if #'comment-p children)))) (type-string (form-string syntax type)) (type-symbol (parse-symbol type-string :package +keyword-package+))) (case type-symbol (:and (funcall #'every #'eval-fc conditionals)) (:or (funcall #'some #'eval-fc conditionals)) (:not (when conditionals (funcall #'(lambda (f l) (not (apply f l))) #'eval-fc conditionals))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Asking about parse state at some point (defun in-type-p-in-children (children offset type) (loop for child in children do (cond ((<= (start-offset child) offset (end-offset child)) (return (if (typep child type) child (in-type-p-in-children (children child) offset type)))) ((<= offset (start-offset child)) (return nil)) (t nil)))) (defun in-type-p (syntax mark-or-offset type) (as-offsets ((offset mark-or-offset)) (update-parse syntax) (with-slots (stack-top) syntax (if (or (null (start-offset stack-top)) (> offset (end-offset stack-top)) (< offset (start-offset stack-top))) nil (in-type-p-in-children (children stack-top) offset type))))) (defun in-string-p (syntax mark-or-offset) "Return true if `mark-or-offset' is inside a Lisp string." (as-offsets ((offset mark-or-offset)) (let ((string (in-type-p syntax offset 'string-form))) (and string (< (start-offset string) offset) (< offset (end-offset string)))))) (defun in-comment-p (syntax mark-or-offset) "Return true if `mark-or-offset' is inside a Lisp comment (line-based or long form)." (as-offsets ((offset mark-or-offset)) (let ((comment (in-type-p syntax mark-or-offset 'comment))) (and comment (or (when (typep comment 'line-comment-form) (< (start-offset comment) offset)) (when (typep comment 'complete-long-comment-form) (< (1+ (start-offset comment) ) offset (1- (end-offset comment)))) (when (typep comment 'incomplete-long-comment-form) (< (1+ (start-offset comment)) offset))))))) (defun in-line-comment-p (syntax mark-or-offset) "Return true if `mark-or-offset' is inside a Lisp line comment." (as-offsets ((offset mark-or-offset)) (let ((comment (in-type-p syntax mark-or-offset 'line-comment-form))) (when comment (< (start-offset comment) offset))))) (defun in-long-comment-p (syntax mark-or-offset) "Return true if `mark-or-offset' is inside a Lisp long comment." (as-offsets ((offset mark-or-offset)) (let ((comment (in-type-p syntax mark-or-offset 'long-comment-form))) (and comment (or (if (typep comment 'complete-long-comment-form) (< (1+ (start-offset comment)) offset (1- (end-offset comment))) (< (1+ (start-offset comment)) offset))))))) (defun in-character-p (syntax mark-or-offset) "Return true if `mark-or-offset' is inside a Lisp character lexeme." (as-offsets ((offset mark-or-offset)) (let ((form (form-around syntax offset))) (typecase form (complete-character-lexeme (> (end-offset form) offset (+ (start-offset form) 1))) (incomplete-character-lexeme (= offset (end-offset form))))))) (defgeneric at-beginning-of-form-p (syntax form offset) (:documentation "Return true if `offset' is at the beginning of the list-like `form', false otherwise. \"Beginning\" is defined at the earliest point the contents could be entered, for example right after the opening parenthesis for a list.") (:method ((syntax lisp-syntax) (form form) (offset integer)) nil) (:method :before ((syntax lisp-syntax) (form form) (offset integer)) (update-parse syntax))) (defgeneric at-end-of-form-p (syntax form offset) (:documentation "Return true if `offset' is at the end of the list-like `form', false otherwise.") (:method ((syntax lisp-syntax) (form form) (offset integer)) nil) (:method :before ((syntax lisp-syntax) (form form) (offset integer)) (update-parse syntax))) (defmethod at-beginning-of-form-p ((syntax lisp-syntax) (form list-form) (offset integer)) (= offset (1+ (start-offset form)))) (defmethod at-end-of-form-p ((syntax lisp-syntax) (form list-form) (offset integer)) (= offset (1- (end-offset form)))) (defmethod at-beginning-of-form-p ((syntax lisp-syntax) (form string-form) (offset integer)) (= offset (1+ (start-offset form)))) (defmethod at-end-of-form-p ((syntax lisp-syntax) (form string-form) (offset integer)) (= offset (1- (end-offset form)))) (defmethod at-beginning-of-form-p ((syntax lisp-syntax) (form simple-vector-form) (offset integer)) (= offset (+ 2 (start-offset form)))) (defmethod at-end-of-form-p ((syntax lisp-syntax) (form simple-vector-form) (offset integer)) (= offset (1- (end-offset form)))) (defun location-at-beginning-of-form (syntax mark-or-offset) "Return true if the position `mark-or-offset' is at the beginning of some structural form, false otherwise. \"Beginning\" is defined by what type of form is at `mark-or-offset', but for a list form, it would be right after the opening parenthesis." (as-offsets ((offset mark-or-offset)) (update-parse syntax) (let ((form-around (form-around syntax offset))) (when form-around (labels ((recurse (form) (or (at-beginning-of-form-p syntax form offset) (unless (form-at-top-level-p form) (recurse (parent form)))))) (recurse form-around)))))) (defun location-at-end-of-form (syntax mark-or-offset) "Return true if the position `mark-or-offset' is at the end of some structural form, false otherwise. \"End\" is defined by what type of form is at `mark-or-offset', but for a list form, it would be right before the closing parenthesis." (as-offsets ((offset mark-or-offset)) (update-parse syntax) (let ((form-around (form-around syntax offset))) (when form-around (labels ((recurse (form) (or (at-end-of-form-p syntax form offset) (unless (form-at-top-level-p form) (recurse (parent form)))))) (recurse form-around)))))) (defun at-beginning-of-list-p (syntax mark-or-offset) "Return true if the position `mark-or-offset' is at the beginning of a list-like form, false otherwise. \"Beginning\" is defined as the earliest point the contents could be entered, for example right after the opening parenthesis for a list." (as-offsets ((offset mark-or-offset)) (update-parse syntax) (let ((form-around (form-around syntax offset))) (when (form-list-p form-around) (at-beginning-of-form-p syntax form-around offset))))) (defun at-end-of-list-p (syntax mark-or-offset) "Return true if the position `mark-or-offset' is at the end of a list-like form, false otherwise. \"End\" is defined as the latest point the contents could be entered, for example right before the closing parenthesis for a list." (as-offsets ((offset mark-or-offset)) (update-parse syntax) (let ((form-around (form-around syntax offset))) (when (form-list-p form-around) (at-end-of-form-p syntax (form-around syntax offset) offset))))) (defun at-beginning-of-string-p (syntax mark-or-offset) "Return true if the position `mark-or-offset' is at the beginning of a string form, false otherwise. \"Beginning\" is right after the opening double-quote." (as-offsets ((offset mark-or-offset)) (update-parse syntax) (let ((form-around (form-around syntax offset))) (when (form-string-p form-around) (at-beginning-of-form-p syntax form-around offset))))) (defun at-end-of-string-p (syntax mark-or-offset) "Return true if the position `mark-or-offset' is at the end of a list-like form, false otherwise. \"End\" is right before the ending double-quote." (as-offsets ((offset mark-or-offset)) (update-parse syntax) (let ((form-around (form-around syntax offset))) (when (form-string-p form-around) (at-end-of-form-p syntax form-around offset))))) (defun at-beginning-of-children-p (form mark-or-offset) "Return true if `mark-or-offset' structurally is at the beginning of (precedes) the children of `form'. True if `form' has no children." (as-offsets ((offset mark-or-offset)) (let ((first-child (first (form-children form)))) (and (null first-child) (>= (start-offset first-child) offset))))) (defun at-end-of-children-p (form mark-or-offset) "Return true if `mark-or-offset' structurally is at the end of (is preceded by) the children of `form'. True if `form' has no children." (as-offsets ((offset mark-or-offset)) (let ((last-child (first (last (form-children form))))) (or (null last-child) (>= offset (end-offset last-child)))))) (defun structurally-at-beginning-of-list-p (syntax mark-or-offset) "Return true if `mark-or-offset' structurally is at the beginning of (precedes) the children of the enclosing list. False if there is no enclosing list. True if the list has no children." (as-offsets ((offset mark-or-offset)) (let ((enclosing-list (list-at-mark syntax offset))) (and enclosing-list (at-beginning-of-children-p enclosing-list offset))))) (defun structurally-at-end-of-list-p (syntax mark-or-offset) "Return true if `mark-or-offset' structurally is at the end of (is preceded by) the children of the enclosing list. False if there is no enclosing list. True of the list has no children." (as-offsets ((offset mark-or-offset)) (let ((enclosing-list (list-at-mark syntax offset))) (and enclosing-list (at-end-of-children-p enclosing-list offset))))) (defun comment-at-mark (syntax mark-or-offset) "Return the comment at `mark-or-offset'." (in-type-p syntax mark-or-offset 'comment)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Useful functions for modifying forms based on the mark. (defgeneric replace-symbol-at-mark (syntax mark string) (:documentation "Replace the symbol around `mark' with `string' and move `mark' to after `string'. If there is no symbol at `mark', insert `string' and move `mark' anyway.")) (defmethod replace-symbol-at-mark ((syntax lisp-syntax) (mark mark) (string string)) (let ((token (symbol-at-mark syntax mark))) (when token (setf (offset mark) (start-offset token)) (forward-delete-expression mark syntax)) (insert-sequence mark string))) (defmethod replace-symbol-at-mark :after ((syntax lisp-syntax) (mark left-sticky-mark) (string string)) (forward-object mark (length string))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; display (defun cache-symbol-info (syntax symbol-form) "Cache information about the symbol `symbol-form' represents, so that it can be quickly looked up later." ;; We don't use `form-to-object' as we want to retrieve information ;; even about symbol that are not interned. (multiple-value-bind (symbol package) (parse-symbol (form-string syntax symbol-form) :package (package-at-mark syntax (start-offset symbol-form))) (setf (keyword-symbol-p symbol-form) (eq package +keyword-package+) (macroboundp symbol-form) (when (eq (first-form (children (parent symbol-form))) symbol-form) (or (special-operator-p symbol) (macro-function symbol))) (global-boundp symbol-form) (and (boundp symbol) (not (constantp symbol)))))) (defun symbol-form-is-keyword-p (syntax symbol-form) "Return true if `symbol-form' represents a keyword symbol." (if (slot-boundp symbol-form '%keyword-symbol-p) (keyword-symbol-p symbol-form) (progn (cache-symbol-info syntax symbol-form) (keyword-symbol-p symbol-form)))) (defun symbol-form-is-macrobound-p (syntax symbol-form) "Return true if `symbol-form' represents a symbol bound to a macro or special form." (if (slot-boundp symbol-form '%macroboundp) (macroboundp symbol-form) (progn (cache-symbol-info syntax symbol-form) (macroboundp symbol-form)))) (defun symbol-form-is-boundp (syntax symbol-form) "Return true if `symbol-form' represents a symbol that is `boundp' and is not a constant." (if (slot-boundp symbol-form '%global-boundp) (global-boundp symbol-form) (progn (cache-symbol-info syntax symbol-form) (global-boundp symbol-form)))) (defun cache-conditional-info (syntax form) "Cache information about the reader conditional `symbol-form' represents, so that it can be quickly looked up later." (setf (conditional-true-p form) (eval-feature-conditional (second-noncomment (children form)) syntax))) (defun reader-conditional-true (syntax form) "Return true if the reader conditional `form' has a true condition." (if (slot-boundp form '%conditional-true-p) (conditional-true-p form) (progn (cache-conditional-info syntax form) (conditional-true-p form)))) (defun parenthesis-highlighter (view form) "Return the drawing style with which the parenthesis lexeme `form' should be highlighted." (if (and (typep view 'point-mark-view) (active view) (or (mark= (point view) (start-offset (parent form))) (mark= (point view) (end-offset (parent form)))) (form-complete-p (parent form))) +bold-face-drawing-options+ +default-drawing-options+)) (defun reader-conditional-rule-fn (positive comment-options) "Return a function for use as a syntax highlighting rule-generator for reader conditionals. If `positive', the function will be for positive reader-conditionals. `Comment-options' is the drawing options object that will be returned when the conditional is not fulfilled." (if positive #'(lambda (view form) (if (reader-conditional-true (syntax view) form) +default-drawing-options+ (values comment-options t))) #'(lambda (view form) (if (not (reader-conditional-true (syntax view) form)) +default-drawing-options+ (values comment-options t))))) (define-syntax-highlighting-rules emacs-style-highlighting (error-lexeme (*error-drawing-options*)) (string-form (*string-drawing-options*)) (comment (*comment-drawing-options*)) (literal-object-form (:options :function (object-drawer))) (complete-token-form (:function #'(lambda (view form) (cond ((symbol-form-is-keyword-p (syntax view) form) *keyword-drawing-options*) ((symbol-form-is-macrobound-p (syntax view) form) *special-operator-drawing-options*) ((symbol-form-is-boundp (syntax view) form) *special-variable-drawing-options*) (t +default-drawing-options+))))) (parenthesis-lexeme (:function #'parenthesis-highlighter)) (reader-conditional-positive-form (:function (reader-conditional-rule-fn t *comment-drawing-options*))) (reader-conditional-negative-form (:function (reader-conditional-rule-fn nil *comment-drawing-options*)))) (defvar *retro-comment-drawing-options* (make-drawing-options :face (make-face :ink +dimgray+)) "The drawing options used for retro-highlighting in Lisp syntax.") (define-syntax-highlighting-rules retro-highlighting (error-symbol (*error-drawing-options*)) (string-form (:options :face +italic-face+)) (comment (*retro-comment-drawing-options*)) (literal-object-form (:options :function (object-drawer))) (complete-token-form (:function #'(lambda (view form) (cond ((symbol-form-is-macrobound-p (syntax view) form) +bold-face-drawing-options+) (t +default-drawing-options+))))) (reader-conditional-positive-form (:function (reader-conditional-rule-fn t *retro-comment-drawing-options*))) (reader-conditional-negative-form (:function (reader-conditional-rule-fn nil *retro-comment-drawing-options*))) (parenthesis-lexeme (:function #'parenthesis-highlighter))) (defparameter *syntax-highlighting-rules* 'emacs-style-highlighting "The syntax highlighting rules used for highlighting Lisp syntax.") (defmethod syntax-highlighting-rules ((syntax lisp-syntax)) *syntax-highlighting-rules*) (defmethod invalidate-strokes ((view textual-drei-syntax-view) (syntax lisp-syntax)) ;; Invalidate the area touched by parenthesis highlighting, if ;; applicable. Cheap test to do coarse elimination... (when (or (and (not (end-of-buffer-p (point view))) (equal (object-after (point view)) #\()) (and (not (beginning-of-buffer-p (point view))) (equal (object-before (point view)) #\)))) ;; Might still be a fake match, so do the semiexpensive proper test. (let ((form (form-around syntax (offset (point view))))) (when form (let ((start-offset (start-offset form)) (end-offset (end-offset form))) (when (or (mark= start-offset (point view)) (mark= end-offset (point view))) ;; We actually have parenthesis highlighting. (list (cons start-offset (1+ start-offset)) (cons (1- end-offset) end-offset)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; exploit the parse (defun form-before-in-children (syntax children offset) (update-parse syntax) (loop for (first . rest) on children if (formp first) do (cond ((< (start-offset first) offset (end-offset first)) (return (if (null (children first)) nil (form-before-in-children syntax (children first) offset)))) ((and (>= offset (end-offset first)) (or (null (first-form rest)) (<= offset (start-offset (first-form rest))))) (return (let ((potential-form (form-before-in-children syntax (children (fully-unquoted-form first)) offset))) (if (not (null potential-form)) (if (or (<= (end-offset first) (end-offset potential-form)) (form-incomplete-p (fully-unquoted-form first))) potential-form first) (when (formp first) first))))) (t nil)))) (defun form-before (syntax offset) (assert (>= (size (buffer syntax)) offset) nil "Offset past buffer end") (assert (>= offset 0) nil "Offset before buffer start") (update-parse syntax) (or (gethash offset (form-before-cache syntax)) (setf (gethash offset (form-before-cache syntax)) (with-slots (stack-top) syntax (if (or (null (start-offset stack-top)) (<= offset (start-offset stack-top))) nil (form-before-in-children syntax (children stack-top) offset)))))) (defun form-after-in-children (syntax children offset) (update-parse syntax) (loop for child in children if (formp child) do (cond ((< (start-offset child) offset (end-offset child)) (return (if (null (children child)) nil (form-after-in-children syntax (children child) offset)))) ((<= offset (start-offset child)) (return (let ((potential-form (form-after-in-children syntax (children child) offset))) (if (not (null potential-form)) (if (<= (start-offset child) (start-offset potential-form)) child potential-form) (when (formp child) child))))) (t nil)))) (defun form-after (syntax offset) (assert (>= (size (buffer syntax)) offset) nil "Offset past buffer end") (assert (>= offset 0) nil "Offset before buffer start") (update-parse syntax) (or (gethash offset (form-after-cache syntax)) (setf (gethash offset (form-after-cache syntax)) (with-slots (stack-top) syntax (if (or (null (start-offset stack-top)) (>= offset (end-offset stack-top))) nil (form-after-in-children syntax (children stack-top) offset)))))) (defun form-around-in-children (syntax children offset) (update-parse syntax) (loop for child in children if (formp child) do (cond ((or (<= (start-offset child) offset (end-offset child)) (= offset (end-offset child)) (= offset (start-offset child))) (return (if (null (first-form (children child))) child (or (form-around-in-children syntax (children child) offset) child)))) ((< offset (start-offset child)) (return nil)) (t nil)))) (defun form-around (syntax offset) (assert (>= (size (buffer syntax)) offset) nil "Offset past buffer end") (assert (>= offset 0) nil "Offset before buffer start") (update-parse syntax) (or (gethash offset (form-around-cache syntax)) (setf (gethash offset (form-around-cache syntax)) (with-slots (stack-top) syntax (if (or (null (start-offset stack-top)) (> offset (end-offset stack-top)) (< offset (start-offset stack-top))) nil (form-around-in-children syntax (children stack-top) offset)))))) (defun find-parent-of-type (form test) "Find a parent of `form' for which the function `test' is true and return it. If a such a parent cannot be found, return nil." (let ((parent (parent form))) (cond ((null parent) nil) ((funcall test parent) parent) (t (find-parent-of-type parent test))))) (defun find-parent-of-type-offset (form test fn) "Find a parent of `form' for which the function `test' is true and return `fn' applied to this parent form. `Fn' should be a function that returns an offset when applied to a form (eg. `start-offset' or `end-offset'). If such a parent cannot be found, return nil" (let ((parent (find-parent-of-type form test))) (when parent (funcall fn parent)))) (defun find-child-of-type (form test) "Find the first child of `form' for which the function `test' is true and return it. If such a child cannot be found, return nil." (find-if #'(lambda (child) (cond ((funcall test child) child) ((formp child) (find-child-of-type child test)))) (children form))) (defun find-child-of-type-offset (form test fn) "Find the first child of `form' for which the function `test' is true and return `fn' applied to this child. `Fn' should be a function that returns an offset when applied to a form (eg. `start-offset' or `end-offset'). If such a child cannot be found, return nil." (let ((child (find-child-of-type form test))) (when child (funcall fn child)))) (defun find-list-parent (form) "Find a list parent of `form' and return it. If a list parent cannot be found, return nil." (find-parent-of-type form #'form-list-p)) (defun find-list-parent-offset (form fn) "Find a list parent of `form' and return `fn' applied to this parent token. `Fn' should be a function that returns an offset when applied to a token (eg. `start-offset' or `end-offset'). If a list parent cannot be found, return nil" (find-parent-of-type-offset form #'form-list-p fn)) (defun find-list-child (form) "Find the first list child of `form' and return it. If a list child cannot be found, return nil." (find-child-of-type form #'form-list-p)) (defun find-list-child-offset (form fn) "Find a list child of `form' and return `fn' applied to this child. `Fn' should be a function that returns an offset when applied to a form (eg. `start-offset' or `end-offset'). If a list child cannot be found, return nil." (find-child-of-type-offset form #'form-list-p fn)) (defmethod backward-one-expression (mark (syntax lisp-syntax)) (update-parse syntax 0 (offset mark)) (let ((potential-form (or (form-before syntax (offset mark)) (form-around syntax (offset mark))))) (loop until (null potential-form) do (cond ((= (offset mark) (start-offset potential-form)) (setf potential-form (unless (form-at-top-level-p potential-form) (parent potential-form)))) (t (setf (offset mark) (start-offset potential-form)) (return t)))))) (defmethod forward-one-expression (mark (syntax lisp-syntax)) (update-parse syntax 0 (offset mark)) (let ((potential-form (or (form-after syntax (offset mark)) (form-around syntax (offset mark))))) (when (not (null potential-form)) (when (and (not (form-at-top-level-p potential-form)) (= (offset mark) (end-offset potential-form))) (setf potential-form (parent potential-form))) (when (and (not (null potential-form)) (not (= (offset mark) (end-offset potential-form)))) (typecase potential-form (reader-conditional-form (setf (offset mark) (or (start-offset (first-form (children potential-form))) (end-offset potential-form)))) (t (setf (offset mark) (end-offset potential-form)))))))) (defmethod forward-delete-expression (mark (syntax lisp-syntax) &optional (count 1) (limit-action #'error-limit-action)) (let ((mark2 (clone-mark mark))) (when (and (not (structurally-at-end-of-list-p (current-syntax) mark)) (forward-expression mark2 syntax count limit-action)) (delete-region mark mark2) t))) (defmethod backward-delete-expression (mark (syntax lisp-syntax) &optional (count 1) (limit-action #'error-limit-action)) (let ((mark2 (clone-mark mark))) (when (and (not (structurally-at-end-of-list-p (current-syntax) mark)) (backward-expression mark2 syntax count limit-action)) (delete-region mark mark2) t))) (defmethod forward-kill-expression (mark (syntax lisp-syntax) &optional (count 1) concatenate-p (limit-action #'error-limit-action)) (let ((start (offset mark))) (forward-expression mark syntax count limit-action) (unless (mark= mark start) (if concatenate-p (if (plusp count) (kill-ring-concatenating-push *kill-ring* (region-to-sequence start mark)) (kill-ring-reverse-concatenating-push *kill-ring* (region-to-sequence start mark))) (kill-ring-standard-push *kill-ring* (region-to-sequence start mark))) (delete-region start mark) t))) (defmethod backward-kill-expression (mark (syntax lisp-syntax) &optional (count 1) concatenate-p (limit-action #'error-limit-action)) (let ((start (offset mark))) (backward-expression mark syntax count limit-action) (unless (mark= mark start) (if concatenate-p (if (plusp count) (kill-ring-concatenating-push *kill-ring* (region-to-sequence start mark)) (kill-ring-reverse-concatenating-push *kill-ring* (region-to-sequence start mark))) (kill-ring-standard-push *kill-ring* (region-to-sequence start mark))) (delete-region start mark) t))) (defgeneric forward-one-list (mark syntax) (:documentation "Move `mark' forward by one list. Return T if successful, or NIL if the buffer limit was reached.")) (defmethod forward-one-list (mark (syntax lisp-syntax)) (update-parse syntax 0 (offset mark)) (loop for start = (offset mark) then (end-offset potential-form) for potential-form = (or (form-after syntax start) (form-around syntax start)) until (or (null potential-form) (and (= start (end-offset potential-form)) (null (form-after syntax start)))) when (form-list-p potential-form) do (setf (offset mark) (end-offset potential-form)) (return t))) (defgeneric backward-one-list (mark syntax) (:documentation "Move `mark' backward by one list. Return T if successful, or NIL if the buffer limit was reached.")) (defmethod backward-one-list (mark (syntax lisp-syntax)) (update-parse syntax 0 (offset mark)) (loop for start = (offset mark) then (start-offset potential-form) for potential-form = (or (form-before syntax start) (form-around syntax start)) until (or (null potential-form) (and (= start (start-offset potential-form)) (null (form-before syntax start)))) when (form-list-p potential-form) do (setf (offset mark) (start-offset potential-form)) (return t))) (defun down-list (mark syntax selector next-offset-fn target-offset-fn) (update-parse syntax 0 (offset mark)) (labels ((next (continue-from) (find-offset (funcall selector syntax (funcall next-offset-fn continue-from)))) (find-offset (potential-form) (typecase potential-form (list-form (funcall target-offset-fn potential-form)) (form (or (find-list-child-offset potential-form target-offset-fn) (next potential-form))) (null nil) (t (next potential-form))))) (let ((new-offset (find-offset (funcall selector syntax (offset mark))))) (when new-offset (setf (offset mark) new-offset) t)))) (defmethod forward-one-down ((mark mark) (syntax lisp-syntax)) (update-parse syntax 0 (offset mark)) (when (down-list mark syntax #'form-after #'end-offset #'start-offset) (forward-object mark))) (defmethod backward-one-down ((mark mark) (syntax lisp-syntax)) (update-parse syntax 0 (offset mark)) (when (down-list mark syntax #'form-before #'start-offset #'end-offset) (backward-object mark))) (defun up-list (mark syntax fn) (update-parse syntax 0 (offset mark)) (let ((form (form-around syntax (offset mark)))) (when (if (and (form-list-p form) (/= (start-offset form) (offset mark)) (/= (end-offset form) (offset mark))) (setf (offset mark) (funcall fn form)) (let ((new-offset (find-list-parent-offset form fn))) (when new-offset (setf (offset mark) new-offset)))) t))) (defmethod backward-one-up (mark (syntax lisp-syntax)) (update-parse syntax 0 (offset mark)) (up-list mark syntax #'start-offset)) (defmethod forward-one-up (mark (syntax lisp-syntax)) (update-parse syntax 0 (offset mark)) (up-list mark syntax #'end-offset)) (defmethod backward-one-definition ((mark mark) (syntax lisp-syntax)) (update-parse syntax 0 (offset mark)) (with-slots (stack-top) syntax ;; FIXME? This conses! I'm over it already. I don't think it ;; matters much, but if someone is bored, please profile it. (loop for form in (reverse (children stack-top)) when (and (formp form) (mark> mark (start-offset form))) do (setf (offset mark) (start-offset form)) and do (return t)))) (defmethod forward-one-definition ((mark mark) (syntax lisp-syntax)) (update-parse syntax 0 (offset mark)) (with-slots (stack-top) syntax (loop for form in (children stack-top) when (and (formp form) (mark< mark (end-offset form))) do (setf (offset mark) (end-offset form)) and do (return t)))) (defmethod eval-defun ((mark mark) (syntax lisp-syntax)) (update-parse syntax 0 (offset mark)) (with-slots (stack-top) syntax (loop for form in (children stack-top) when (and (mark<= (start-offset form) mark) (mark<= mark (end-offset form))) do (return (eval-form-for-drei (get-usable-image syntax) (form-to-object syntax form :read t)))))) ;;; shamelessly replacing SWANK code ;; We first work through the string removing the characters and noting ;; which ones are escaped. We then replace each character with the ;; appropriate case version, according to the readtable. ;; Finally, we extract the package and symbol names. ;; Being in an editor, we are waaay more lenient than the reader. (defun parse-escapes (string) "Return a string and a list of escaped character positions. Uses part of the READ algorithm in CLTL2 22.1.1." (let ((length (length string)) (index 0) irreplaceables chars) (tagbody step-8 (unless (< index length) (go end)) (cond ((char/= (char string index) #\\ #\|) (push (char string index) chars) (incf index) (go step-8)) ((char= (char string index) #\\) (push (length chars) irreplaceables) (incf index) (unless (< index length) (go end)) (push (char string index) chars) (incf index) (go step-8)) ((char= (char string index) #\|) (incf index) (go step-9))) step-9 (unless (< index length) (go end)) (cond ((char/= (char string index) #\\ #\|) (push (length chars) irreplaceables) (push (char string index) chars) (incf index) (go step-9)) ((char= (char string index) #\\) (push (length chars) irreplaceables) (incf index) (unless (< index length) (go end)) (push (char string index) chars) (incf index) (go step-9)) ((char= (char string index) #\|) (incf index) (go step-8))) end (return-from parse-escapes (values (coerce (nreverse chars) 'string) (nreverse irreplaceables)))))) (defun invert-cases (string &optional (irreplaceables nil)) "Returns two flags: unescaped upper-case and lower-case chars in STRING." (loop for index below (length string) with upper = nil with lower = nil when (not (member index irreplaceables)) if (upper-case-p (char string index)) do (setf upper t) end if (lower-case-p (char string index)) do (setf lower t) end finally (return (values upper lower)))) (defun replace-case (string &optional (case (readtable-case *readtable*)) (irreplaceables nil)) "Convert string according to readtable-case." (multiple-value-bind (upper lower) (invert-cases string irreplaceables) (loop for index below (length string) as char = (char string index) then (char string index) if (member index irreplaceables) collect char into chars else collect (ecase case (:preserve char) (:upcase (char-upcase char)) (:downcase (char-downcase char)) (:invert (cond ((and lower upper) char) (lower (char-upcase char)) (upper (char-downcase char)) (t char)))) into chars finally (return (coerce chars 'string))))) (defun parse-token (string &optional (case (readtable-case *readtable*))) "Extracts the symbol-name and package name from STRING and whether the symbol-name was separated from the package by a double colon." (multiple-value-bind (string irreplaceables) (parse-escapes string) (let ((string (replace-case string case irreplaceables)) package-name symbol-name internalp) (loop for index below (length string) with symbol-start = 0 when (and (char= (char string index) #\:) (not (member index irreplaceables))) do (setf package-name (subseq string 0 index)) (if (and (< (incf index) (length string)) (char= (char string index) #\:) (not (member index irreplaceables))) (setf symbol-start (1+ index) internalp t) (setf symbol-start index)) (loop-finish) finally (setf symbol-name (subseq string symbol-start))) (values symbol-name package-name internalp)))) #| ;;; Compare CLHS 23.1.2.1 (defun test-parse-token () (let ((*readtable* (copy-readtable nil))) (format t "READTABLE-CASE Input Symbol-name Token-name~ ~%------------------------------------------------------~ ~%") (dolist (readtable-case '(:upcase :downcase :preserve :invert)) (dolist (input '("ZEBRA" "Zebra" "zebra" "\\zebra" "\\Zebra" "z|ebr|a" "|ZE\\bRA|" "ze\\|bra")) (format t "~&:~A~16T~A~30T~A~44T~A" (string-upcase readtable-case) input (progn (setf (readtable-case *readtable*) readtable-case) (symbol-name (read-from-string input))) (parse-token input readtable-case)))))) |# (defun form-string (syntax form) "Return the string that correspond to `form' in the buffer of `syntax'." (buffer-substring (buffer syntax) (start-offset form) (end-offset form))) (defun parse-symbol (string &key (package *package*) (case (readtable-case *readtable*))) "Find the symbol named STRING. Return the symbol, the package of the symbol and a flag indicating whether the symbol was found in the package. Note that a symbol and a package may be returned even if it was not found in a package, for example if you do `foo-pkg::bar', where `foo-pkg' is an existing package but `bar' isn't interned in it. If the package cannot be found, its name as a string will be returned in its place." (multiple-value-bind (symbol-name package-name) (parse-token string case) (let ((package (cond ((string= package-name "") +keyword-package+) (package-name (or (find-package package-name) package-name)) (t package)))) (multiple-value-bind (symbol status) (when (packagep package) (find-symbol symbol-name package)) (if (or symbol status) (values symbol package status) (values (make-symbol symbol-name) package nil)))))) ;;; The following algorithm for reading backquote forms was originally ;;; taken from the example reader macro in Common LISP the Language ;;; 2nd. Ed, and was subsequently optimized and cleaned with some ;;; ideas taken from SBCL's backquote implementation. ;;; Define synonyms for the lisp functions we use, so that we can ;;; eventually recognize them and print them in a pretty-printer-style ;;; way. (macrolet ((def (b-name name) (let ((args (gensym "ARGS"))) `(defun ,b-name (&rest ,args) (declare (dynamic-extent ,args)) (apply #',name ,args))))) (def backquote-list list) (def backquote-list* list*) (def backquote-append append) (def backquote-nconc nconc) (def backquote-cons cons)) (defun backquote-vector (list) (declare (list list)) (coerce list 'simple-vector)) (defconstant +comma-marker+ (gensym "COMMA") "The marker used for identifying commas.") (defconstant +comma-at-marker+ (gensym "COMMA-AT") "The marker used for identifying ,@ contructs.") (defconstant +comma-dot-marker+ (gensym "COMMA-DOT") "The marker used for identifying ,. contructs.") (defconstant +clobberable-marker+ (gensym "CLOBBERABLE") "Marker for a constant that we can safely modify destructively.") (defconstant +quote-marker+ 'quote "The marker used for identifying quote forms in backquoted forms.") (defconstant +quote-nil-marker+ (list +quote-marker+ nil)) (defconstant +list-marker+ 'backquote-list) (defconstant +append-marker+ 'backquote-append) (defconstant +list*-marker+ 'backquote-list*) (defconstant +nconc-marker+ 'backquote-nconc) (defconstant +vector-marker+ 'backquote-vector) (defun completely-process-backquote (expression) "Considering `expression' a list (or tree) containing comma, comma-at and comma-dot markers, return an expression constructed so that it, when evaluated, will behave like a backquoted form is expected to. `Expression' is treated as being implicitly preceded by a backquote." (remove-backquote-tokens (simplify-backquote (process-backquote expression)))) (defun process-backquote (x) (cond ((vectorp x) ;; FIXME? Is there a faster way to handle this? (list +vector-marker+ (process-backquote (loop for elt across x collecting elt)))) ((atom x) (list +quote-marker+ x)) ((eq (car x) +comma-marker+) (cadr x)) ((eq (car x) +comma-at-marker+) (error ",@~S after `" (cadr x))) ((eq (car x) +comma-dot-marker+) (error ",.~S after `" (cadr x))) (t (do ((p x (cdr p)) (q '() (cons (bracket (car p)) q))) ((atom p) (cons +append-marker+ (nreconc q (list (list +quote-marker+ p))))) (when (eq (car p) +comma-marker+) (unless (null (cddr p)) (error "Malformed ,~S" p)) (return (cons +append-marker+ (nreconc q (list (cadr p)))))) (when (eq (car p) +comma-at-marker+) (error "Dotted ,@~S" p)) (when (eq (car p) +comma-dot-marker+) (error "Dotted ,.~S" p)))))) (defun bracket (x) (cond ((atom x) (list +list-marker+ (process-backquote x))) ((eq (car x) +comma-marker+) (list +list-marker+ (cadr x))) ((eq (car x) +comma-at-marker+) (cadr x)) ((eq (car x) +comma-dot-marker+) (list +clobberable-marker+ (cadr x))) (t (list +list-marker+ (process-backquote x))))) (defun remove-backquote-tokens (x) (cond ((atom x) x) ((eq (car x) +clobberable-marker+) (remove-backquote-tokens (cadr x))) ((and (eq (car x) +list*-marker+) (consp (cddr x)) (null (cdddr x))) (cons 'cons (maptree #'remove-backquote-tokens (cdr x)))) (t (maptree #'remove-backquote-tokens x)))) (defun splicing-comma-marker-p (x) "True for forms that textually looks like ,@foo or ,.foo." (and (consp x) (or (eq (car x) +comma-at-marker+) (eq (car x) +comma-dot-marker+)))) (defun comma-marker-p (x) "This predicate is true of a form that textually looks like ,@foo or ,.foo or just plain ,foo." (and (consp x) (or (eq (car x) +comma-marker+) (eq (car x) +comma-at-marker+) (eq (car x) +comma-dot-marker+)))) (defun simplify-backquote (x) (if (atom x) x (let ((x (if (eq (car x) +quote-marker+) x (maptree #'simplify-backquote x)))) (if (not (eq (car x) +append-marker+)) x (simplify-backquote-args x))))) (defun simplify-backquote-args (x) (do ((args (reverse (cdr x)) (cdr args)) (result nil (cond ((atom (car args)) (attach-backquote-append +append-marker+ (car args) result)) ((and (eq (caar args) +list-marker+) (notany #'splicing-comma-marker-p (cdar args))) (attach-backquote-conses (cdar args) result)) ((and (eq (caar args) +list-marker+) (notany #'splicing-comma-marker-p (cdar args))) (attach-backquote-conses (reverse (cdr (reverse (cdar args)))) (attach-backquote-append +append-marker+ (car (last (car args))) result))) ((and (eq (caar args) +quote-marker+) (consp (cadar args)) (not (comma-marker-p (cadar args))) (null (cddar args))) (attach-backquote-conses (list (list +quote-marker+ (caadar args))) result)) ((eq (caar args) +clobberable-marker+) (attach-backquote-append +nconc-marker+ (cadar args) result)) (t (attach-backquote-append +append-marker+ (car args) result))))) ((null args) result))) (defun attach-backquote-conses (items result) "The effect of `attach-backquote-conses' is to produce a form as if by `(list* ,@items ,result) but some simplifications are done on the fly. (LIST* 'a 'b 'c 'd) => '(a b c . d) (LIST* a b c 'nil) => (LIST a b c) (LIST* a b c (LIST* d e f g)) => (LIST* a b c d e f g) (LIST* a b c (LIST d e f g)) => (LIST a b c d e f g)" (cond ((and (every #'null-or-quoted items) (null-or-quoted result)) (list +quote-marker+ (append (mapcar #'cadr items) (cadr result)))) ((or (null result) (equal result +quote-marker+)) (cons +list-marker+ items)) ((and (consp result) (or (eq (car result) +list-marker+) (eq (car result) +list*-marker+))) (cons (car result) (append items (cdr result)))) (t (cons +list*-marker+ (append items (list result)))))) (defun null-or-quoted (x) (or (null x) (and (consp x) (eq (car x) +quote-marker+)))) (defun attach-backquote-append (op item result) "When `attach-backquote-append' is called, the OP should be `+append-marker+' or `+nconc-marker' This produces a form (op item result) but some simplifications are done on the fly: (op '(a b c) '(d e f g)) => '(a b c d e f g) (op item 'nil) => item, provided item is not a splicable frob (op item 'nil) => (op item), if item is a splicable frob (op item (op a b c)) => (op item a b c)" (cond ((and (null-or-quoted item) (null-or-quoted result) (listp (cadr item))) (list +nconc-marker+ (append (cadr item) (cadr result)))) ((or (null result) (equal result +quote-nil-marker+)) (if (splicing-comma-marker-p item) (list op item) item)) ((and (consp result) (eq (car result) op)) (list* (car result) item (cdr result))) (t (list op item result)))) (define-condition reader-invoked (condition) ((%end-mark :reader end-mark :initarg :end-mark :initform (error "You must provide an ending-mark for the condition") :documentation "The position at which the reader stopped reading, form-to-object conversion should be resumed from this point.") (%object :reader object :initarg :object :initform (error "You must provide the object that was returned by the reader") :documentation "The object that was returned by the reader.")) (:documentation "Signal that the reader has been directly invoked on the buffer contents, that the object of this condition should be assumed as the result of the form-conversion.")) (defun invoke-reader (syntax form) "Use the system reader to handle `form' and signal a `reader-invoked' condition with the resulting data." (let* ((start-mark (make-buffer-mark (buffer syntax) (start-offset form)))) (let* ((stream (make-buffer-stream :buffer (buffer syntax) :start-mark start-mark)) (object (read-preserving-whitespace stream))) (signal 'reader-invoked :end-mark (point stream) :object object)))) (define-condition form-conversion-error (simple-error user-condition-mixin) ((syntax :reader syntax :initarg :syntax :initform (error "You must provide the syntax the erroneous form is in.")) (form :reader form :initarg :form :initform (error "You must provide the erroneous form.")) (problem :reader problem :initarg :problem :initform "invalid form")) (:report (lambda (condition stream) (format stream "Syntax problem: ~A" (problem condition)))) (:documentation "This condition (or a subclass) is signalled by `form-to-object' when a form cannot be converted to a proper Lisp object.")) (defun form-conversion-error (syntax form problem &rest args) "Signal a `form-conversion-error' for the `form' in `syntax'. `Problem' should be a succint description of why `form' is invalid and cannot be converted to an object. `Problem' is a format string, in which case `args' is used as format parameters." (error 'form-conversion-error :syntax syntax :form form :problem (apply #'format nil problem args))) (defmethod handle-drei-condition (drei (condition form-conversion-error)) (with-minibuffer-stream (minibuffer) (let ((*print-escape* nil)) (princ condition minibuffer))) (when (point-mark-view-p (view drei)) (setf (offset (point (view drei))) (start-offset (form condition))))) ;;; Handling labels (#n= and #n#) takes a fair bit of machinery, most ;;; of which is located here. We follow an approach similar to that ;;; found in the SBCL reader, where we replace instances of #n# with a ;;; special unique marker symbol that we replace before returning the ;;; final object. We maintain two tables, one that maps labels to ;;; placerholder symbols and one that maps placeholder symbols to the ;;; concrete objects. (defvar *labels->placeholders* nil "This variable holds an alist mapping labels (as integers) to a placeholder symbol. It is used for implementing the label reader macros (#n=foo #n#).") (defvar *label-placeholders->objects* nil "This variable holds an alist mapping placeholder symbols to the object. It is used for implementing the label reader macros (#n=foo #n#).") (defgeneric extract-label (syntax form) (:documentation "Get the label of `form' as an integer.")) (defmethod extract-label ((syntax lisp-syntax) (form sharpsign-equals-form)) (let ((string (form-string syntax (first (children form))))) (parse-integer string :start 1 :end (1- (length string)) :radix 10))) (defmethod extract-label ((syntax lisp-syntax) (form sharpsign-sharpsign-form)) (let ((string (form-string syntax form))) (parse-integer string :start 1 :end (1- (length string)) :radix 10))) (defun register-form-label (syntax form &rest args) "Register the label of `form' and the corresponding placeholder symbol. `Form' must be a sharpsign-equals form (#n=), and if the label has already been registered, an error of type `form-conversion-error' will be signalled. Args will be passed to `form-to-object' for the creation of the object referred to by the label. Returns `form' converted to an object." (let* ((label (extract-label syntax form)) (placeholder-symbol (gensym))) (when (assoc label *labels->placeholders*) (form-conversion-error syntax form "multiply defined label: ~A" label)) (push (list label placeholder-symbol) *labels->placeholders*) (let ((object (apply #'form-to-object syntax (second (children form)) args))) (push (list placeholder-symbol object) *label-placeholders->objects*) object))) (defgeneric find-and-register-label (syntax form label limit &rest args) (:documentation "Find the object referred to by the integer value `label' in children of `form' or `form' itself. `Args' will be passed to `form-to-object' for the creation of the object. `Limit' is a buffer offset delimiting where not to search past.")) (defmethod find-and-register-label ((syntax lisp-syntax) (form form) (label integer) (limit integer) &rest args) (find-if #'(lambda (child) (when (and (formp child) (< (start-offset form) limit)) (apply #'find-and-register-label syntax child label limit args))) (children form))) (defmethod find-and-register-label ((syntax lisp-syntax) (form sharpsign-equals-form) (label integer) (limit integer) &rest args) (when (and (= (extract-label syntax form) label) (< (start-offset form) limit)) (apply #'register-form-label syntax form args))) (defun ensure-label (syntax form label &rest args) "Ensure as best as possible that `label' exist. `Form' is the form that needs the value of the label, limiting where to end the search. `Args' will be passed to `form-to-object' if it is necessary to create a new object for the label." (unless (assoc label *labels->placeholders*) (apply #'find-and-register-label syntax (form-toplevel syntax form) label (start-offset form) args))) (defun label-placeholder (syntax form label &optional search-whole-form &rest args) "Get the placeholder for `label' (which must be an integer). If the placeholder symbol cannot be found, the label is undefined, and an error of type `form-conversion-error' will be signalled. If `search-whole-form' is true, the entire top-level-form will be searched for the label reference if it has not already been seen, upwards from `form', but not past `form'. `Args' will be passed as arguments to `form-to-object' to create the labelled object." (when search-whole-form (apply #'ensure-label syntax form label args)) (let ((pair (assoc label *labels->placeholders*))) (second pair))) ;;; The `circle-subst' function is cribbed from SBCL. (defvar *sharp-equal-circle-table* nil "Objects already seen by `circle-subst'.") (defun circle-subst (old-new-alist tree) "This function is kind of like NSUBLIS, but checks for circularities and substitutes in arrays and structures as well as lists. The first arg is an alist of the things to be replaced assoc'd with the things to replace them." (cond ((not (typep tree '(or cons (array t) structure-object standard-object))) (let ((entry (find tree old-new-alist :key #'first))) (if entry (second entry) tree))) ((null (gethash tree *sharp-equal-circle-table*)) (setf (gethash tree *sharp-equal-circle-table*) t) (cond ((typep tree '(or structure-object standard-object)) ;; I am time and again saved by the MOP as I code ;; myself into a corner. (let ((class (class-of tree))) (dolist (slotd (clim-mop:class-slots class)) (when (clim-mop:slot-boundp-using-class class tree slotd) (let* ((old (clim-mop:slot-value-using-class class tree slotd)) (new (circle-subst old-new-alist old))) (unless (eq old new) (setf (clim-mop:slot-value-using-class class tree slotd) new))))))) ((vectorp tree) (loop for i from 0 below (length tree) do (let* ((old (aref tree i)) (new (circle-subst old-new-alist old))) (unless (eq old new) (setf (aref tree i) new))))) ((arrayp tree) (loop with array-size = (array-total-size tree) for i from 0 below array-size do (let* ((old (row-major-aref tree i)) (new (circle-subst old-new-alist old))) (unless (eq old new) (setf (row-major-aref tree i) new))))) (t (let ((a (circle-subst old-new-alist (car tree))) (d (circle-subst old-new-alist (cdr tree)))) (unless (eq a (car tree)) (rplaca tree a)) (unless (eq d (cdr tree)) (rplacd tree d))))) tree) (t tree))) (defun replace-placeholders (&rest values) "Replace the placeholder symbols in `values' with the real objects as determined by `*label-placeholders->objects*' and return the modified `values' as multiple return values." (values-list (if *label-placeholders->objects* (mapcar #'(lambda (value) (let ((*sharp-equal-circle-table* (make-hash-table :test #'eq :size 20))) (circle-subst *label-placeholders->objects* value))) values) values))) (defvar *form-to-object-depth* 0 "This variable is used to keep track of how deeply nested calls to `form-to-object' are.") (defgeneric form-to-object (syntax form &key no-error package read backquote-level case) (:documentation "Return the Lisp object `form' would become if read. An attempt will be made to construct objects from incomplete tokens. Some forms (such as negative readtime-conditional-forms) may return no values. This function may signal an error of type `form-conversion-error' if `no-error' is false and `token' cannot be converted to a Lisp object. Otherwise, NIL will be returned. Also, if `read' is true and `no-error' is false, an error of type `form-conversion-error' will be signalled for incomplete forms.") (:method :around ((syntax lisp-syntax) (form form) &key package no-error &allow-other-keys) ;; Ensure that every symbol that is READ will be looked up ;; in the correct package. (flet ((act () (handler-case (multiple-value-call #'replace-placeholders (call-next-method)) (reader-invoked (c) (if (> (offset (end-mark c)) (end-offset form)) (signal c) (object c))) (form-conversion-error (e) (unless no-error (error e)))))) (let ((*form-to-object-depth* (1+ *form-to-object-depth*)) (*package* (or package (package-at-mark syntax (start-offset form))))) (if (= *form-to-object-depth* 1) (let ((*labels->placeholders* nil) (*label-placeholders->objects* nil)) (act)) (act))))) (:method ((syntax lisp-syntax) (form form) &rest args &key no-error &allow-other-keys) (unless no-error (apply #'no-applicable-method #'form-to-object syntax form args))) (:method :before ((syntax lisp-syntax) (form incomplete-form-mixin) &key read no-error &allow-other-keys) (when (and read (null no-error)) (form-conversion-error syntax form "form is incomplete")))) (defmethod form-to-object ((syntax lisp-syntax) (form error-lexeme) &key &allow-other-keys) (form-conversion-error syntax form "invalid syntax")) ;;; The complicated primary structure forms. (defmethod form-to-object ((syntax lisp-syntax) (form list-form) &rest args &key &allow-other-keys) (labels ((recurse (elements) (unless (null elements) (handler-case (nconc (multiple-value-list (apply #'form-to-object syntax (first elements) args)) (recurse (rest elements))) (reader-invoked (c) (let ((remaining-elements (remove (offset (end-mark c)) elements :key #'start-offset :test #'>))) (if (and (not (null (rest elements))) (null remaining-elements)) (signal c) (cons (object c) (recurse remaining-elements))))))))) (recurse (remove-if-not #'formp (children form))))) (defmethod form-to-object ((syntax lisp-syntax) (form complete-quote-form) &rest args &key (backquote-level 0) &allow-other-keys) (if (plusp backquote-level) (list +quote-marker+ (apply #'form-to-object syntax (second (children form)) args)) `',(apply #'form-to-object syntax (second (children form)) args))) (defmethod form-to-object ((syntax lisp-syntax) (form incomplete-quote-form) &rest args) (declare (ignore args)) ;; Utterly arbitrary, but reasonable in my opinion. '(quote)) (defmethod form-to-object ((syntax lisp-syntax) (form backquote-form) &rest args &key (backquote-level 0) &allow-other-keys) (let ((backquoted-form (first-form (children form)))) (when (or (form-comma-p backquoted-form) (form-comma-at-p backquoted-form) (form-comma-dot-p backquoted-form)) (form-conversion-error syntax form "comma form cannot follow backquote")) (let ((backquoted-obj (apply #'form-to-object syntax backquoted-form :backquote-level (1+ backquote-level) args))) (completely-process-backquote backquoted-obj)))) (defmethod form-to-object ((syntax lisp-syntax) (form comma-form) &rest args &key read (backquote-level 0 backquote-active-p) &allow-other-keys) (when (and read (or (null backquote-active-p) (zerop backquote-level))) (form-conversion-error syntax form "comma form found outside backquote")) (let ((obj (apply #'form-to-object syntax (first-form (children form)) :backquote-level (max (1- backquote-level) 0) args))) (if (plusp backquote-level) (list +comma-marker+ obj) obj))) (defmethod form-to-object ((syntax lisp-syntax) (form comma-at-form) &rest args &key read (backquote-level 0 backquote-active-p) &allow-other-keys) (when (and read (or (null backquote-active-p) (zerop backquote-level))) (form-conversion-error syntax form "comma-at form found outside backquote")) (let ((obj (apply #'form-to-object syntax (first-form (children form)) :backquote-level (max (1- backquote-level) 0) args))) (if (plusp backquote-level) (list +comma-at-marker+ obj) obj))) (defmethod form-to-object ((syntax lisp-syntax) (form comma-dot-form) &rest args &key read (backquote-level 0 backquote-active-p) &allow-other-keys) (when (and read (or (null backquote-active-p) (zerop backquote-level))) (form-conversion-error syntax form "comma-dot form found outside backquote")) (let ((obj (apply #'form-to-object syntax (first-form (children form)) :backquote-level (max (1- backquote-level) 0) args))) (if (plusp backquote-level) (list +comma-dot-marker+ obj) obj))) ;;; The atom(-ish) forms. (defmethod form-to-object ((syntax lisp-syntax) (form complete-token-form) &key read (case (readtable-case *readtable*)) &allow-other-keys) (multiple-value-bind (symbol package status) (parse-symbol (form-string syntax form) :package *package* :case case) (values (cond ((and read (null status) (packagep package)) (intern (symbol-name symbol) package)) (t symbol))))) (defmethod form-to-object ((syntax lisp-syntax) (form number-lexeme) &key &allow-other-keys) (let ((*read-base* (base syntax))) (invoke-reader syntax form))) (defmethod form-to-object ((syntax lisp-syntax) (form simple-vector-form) &key &allow-other-keys) (let* ((contents (call-next-method)) (lexeme-string (form-string syntax (first (children form)))) (size (parse-integer lexeme-string :start 1 :end (1- (length lexeme-string)) :junk-allowed t)) (vector (make-array (or size (length contents))))) (loop for cons = contents then (or rest cons) for element = (first cons) for rest = (rest cons) for i below (length vector) do (setf (aref vector i) element) finally (return vector)))) (defmethod form-to-object ((syntax lisp-syntax) (form incomplete-string-form) &key &allow-other-keys) (values (read-from-string (concatenate 'string (form-string syntax form) "\"")))) (defmethod form-to-object ((syntax lisp-syntax) (form complete-string-form) &key &allow-other-keys) (invoke-reader syntax form)) (defmethod form-to-object ((syntax lisp-syntax) (form function-form) &rest args) (list 'cl:function (apply #'form-to-object syntax (second (children form)) args))) (defmethod form-to-object ((syntax lisp-syntax) (form complete-character-lexeme) &key &allow-other-keys) (or (ignore-errors (values (read-from-string (form-string syntax form)))) (form-conversion-error syntax form "character ~A not recognized" (form-string syntax form)))) (defmethod form-to-object ((syntax lisp-syntax) (form cons-cell-form) &rest args &key &allow-other-keys) (apply #'list* (mapcar #'(lambda (form) (apply #'form-to-object syntax form args)) (remove-if-not #'formp (children form))))) (defmethod form-to-object ((syntax lisp-syntax) (form reader-conditional-positive-form) &key &allow-other-keys) (let ((conditional (second-noncomment (children form)))) (if (eval-feature-conditional conditional syntax) (form-to-object syntax (third-noncomment (children form))) (values)))) (defmethod form-to-object ((syntax lisp-syntax) (form reader-conditional-negative-form) &key &allow-other-keys) (let ((conditional (second-noncomment (children form)))) (if (not (eval-feature-conditional conditional syntax)) (form-to-object syntax (third-noncomment (children form))) (values)))) (defmethod form-to-object ((syntax lisp-syntax) (form uninterned-symbol-form) &key (case (readtable-case *readtable*)) &allow-other-keys) (make-symbol (parse-token (form-string syntax form) case))) (defmethod form-to-object ((syntax lisp-syntax) (form undefined-reader-macro-form) &key read &allow-other-keys) ;; This is likely to malfunction for some really evil reader macros, ;; in that case, you need to extend the parser to understand them. (when read (invoke-reader syntax form))) (defmethod form-to-object ((syntax lisp-syntax) (form literal-object-form) &key &allow-other-keys) (buffer-object (buffer syntax) (start-offset form))) (defmethod form-to-object ((syntax lisp-syntax) (form pathname-form) &key &allow-other-keys) (values (read-from-string (form-string syntax form)))) (defmethod form-to-object ((syntax lisp-syntax) (form incomplete-pathname-form) &rest args &key read &allow-other-keys) (if read ;; Will cause a reader error (which is what we want). (call-next-method) ;; Try to create a pathname as much as possible. (let ((pathspec-form (second (children form)))) (pathname (if pathspec-form (apply #'form-to-object syntax pathspec-form ;; Since `pathspec-form' will be ;; incomplete, `read'ing from it is ;; probably bad. :read nil args) ""))))) (defmethod form-to-object ((syntax lisp-syntax) (form complete-function-form) &rest args &key &allow-other-keys) (list 'function (apply #'form-to-object syntax (second (children form)) args))) (defmethod form-to-object ((syntax lisp-syntax) (form bit-vector-form) &key &allow-other-keys) (values (read-from-string (form-string syntax form)))) (defmethod form-to-object ((syntax lisp-syntax) (form readtime-evaluation-form) &rest args &key read &allow-other-keys) (when read (values (eval (apply #'form-to-object syntax (first-form (children form)) args))))) (defmethod form-to-object ((syntax lisp-syntax) (form sharpsign-equals-form) &rest args) (apply #'register-form-label syntax form args)) (defmethod form-to-object ((syntax lisp-syntax) (form sharpsign-sharpsign-form) &rest args) (apply #'label-placeholder syntax form (extract-label syntax form) t args)) (defmethod form-to-object ((syntax lisp-syntax) (form array-form) &rest args) (let* ((rank-string (form-string syntax (first (children form)))) (rank (parse-integer rank-string :start 1 :end (1- (length rank-string)))) (array-contents (apply #'form-to-object syntax (second (children form)) args))) (labels ((dimensions (rank contents) (cond ((= rank 0) nil) ((= rank 1) (list (length contents))) (t (let ((goal (dimensions (1- rank) (first contents)))) (dolist (element (rest contents)) (unless (equal goal (dimensions (1- rank) element)) (form-conversion-error syntax form "jagged multidimensional array"))) (cons (length contents) goal)))))) (make-array (dimensions rank array-contents) :initial-contents array-contents)))) (defgeneric form-equal (syntax form1 form2) (:documentation "Compare the objects that `form1' and `form2' represent, which must be forms of `syntax', for equality under the same rules as `equal'. This function does not have side-effects. The semantics of this function are thus equivalent to a side-effect-less version of (equal (form-to-object syntax form1 :read t) (form-to-object syntax form2 :read t)). `Form1' and `form2' may also be strings, in which case they are taken to be a readable representation of some object.") (:method ((syntax lisp-syntax) (form1 string) (form2 string)) ;; Not strictly correct, but good enough for now. (string= form1 form2)) (:method ((syntax lisp-syntax) (form1 string) (form2 form)) (form-equal syntax form2 form1)) (:method ((syntax lisp-syntax) (form1 form) (form2 form)) nil) (:method ((syntax lisp-syntax) (form1 form) (form2 string)) nil)) (defmethod form-equal ((syntax lisp-syntax) (form1 complete-token-form) (form2 complete-token-form)) (multiple-value-bind (symbol1 package1 status1) (parse-symbol (form-string syntax form1) :package (package-at-mark syntax (start-offset form1))) (declare (ignore status1)) (multiple-value-bind (symbol2 package2 status2) (parse-symbol (form-string syntax form2) :package (package-at-mark syntax (start-offset form2))) (declare (ignore status2)) (and (string= symbol1 symbol2) (equal package1 package2))))) (defmethod form-equal ((syntax lisp-syntax) (form1 complete-token-form) (form2 string)) (multiple-value-bind (symbol1 package1 status1) (parse-symbol (form-string syntax form1) :package (package-at-mark syntax (start-offset form1))) (declare (ignore status1)) (multiple-value-bind (symbol2 package2 status2) (parse-symbol form2 :package (package-at-mark syntax (start-offset form1))) (declare (ignore status2)) (and (string= symbol1 symbol2) (equal package1 package2))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Lambda-list handling. ;;; ;;; Just the infrastructure. The fun processing and analysis stuff is ;;; found in lisp-syntax-swine.lisp. The lambda-list interface is ;;; based on the simplicity of CL pathnames. (defparameter +cl-lambda-list-keywords+ lambda-list-keywords) (defparameter +cl-garbage-keywords+ '(&whole &environment)) (defun lambda-list-keyword-p (arg) "Return true if `arg' is a lambda list keyword, false otherwise." (member arg +cl-lambda-list-keywords+)) (defgeneric arglist-for-form (syntax operator &optional arguments) (:documentation "Return an arglist for `operator'.") (:method ((syntax lisp-syntax) (operator symbol) &optional arguments) (declare (ignore arguments)) (parse-lambda-list (cleanup-arglist (arglist (get-usable-image syntax) operator))))) (defmethod arglist-for-form ((syntax lisp-syntax) (operator list) &optional arguments) (declare (ignore arguments)) (case (first operator) ('cl:lambda (parse-lambda-list (cleanup-arglist (second operator)))))) ;; SBCL, and some other implementations I would guess, provides us ;; with an arglist that is too simple, confusing the code ;; analysers. We fix that here. (defmethod arglist-for-form ((syntax lisp-syntax) (operator (eql 'clim-lisp:defclass)) &optional arguments) (declare (ignore arguments)) (parse-lambda-list '(name (&rest superclasses) (&rest slots) &rest options))) (defmethod arglist-for-form ((syntax lisp-syntax) (operator (eql 'cl:defclass)) &optional arguments) (declare (ignore arguments)) (parse-lambda-list '(name (&rest superclasses) (&rest slots) &rest options))) (defun cleanup-arglist (arglist) "Remove elements of `arglist' that we are not interested in, including implementation-specific lambda list keywords." (loop for arg in arglist with in-&aux ; If non-NIL, we are in the ; &aux parameters that should ; not be displayed. with in-garbage ; If non-NIL, the next ; argument is a garbage ; parameter that should not be ; displayed. if in-garbage do (setf in-garbage nil) else if (not in-&aux) if (eq arg '&aux) do (setf in-&aux t) else if (member arg +cl-garbage-keywords+ :test #'eq) do (setf in-garbage t) else if (listp arg) collect (cleanup-arglist arg) else collect arg)) ;; Arglist classes. Some arglist elements are not represented (&env, ;; &aux), because they are not interesting. (defclass lambda-list () ((%original-lambda-list :initarg :original-lambda-list :reader original-lambda-list)) (:documentation "The superclass of all lambda list classes.")) (defmethod print-object ((ll lambda-list) stream) (print-unreadable-object (ll stream :type t :identity t) (when (compute-applicable-methods #'lambda-list-as-list `(,ll)) (let ((*print-length* (or *print-length* 10))) ;; PRINC because the names of KEYWORD-PARAMETERs are keywords. (princ (lambda-list-as-list ll) stream))))) (defgeneric required-parameters (lambda-list) (:documentation "Return a list containing objects representing the required parameters of `lambda-list'.") (:method ((lambda-list lambda-list)) nil)) (defgeneric optional-parameters (lambda-list) (:documentation "Return a list containing objects representing the optional parameters of `lambda-list'.") (:method ((lambda-list lambda-list)) nil)) (defgeneric keyword-parameters (lambda-list) (:documentation "Return a list containing objects representing the keyword parameters of `lambda-list'.") (:method ((lambda-list lambda-list)) nil)) (defgeneric rest-parameter (lambda-list) (:documentation "Return an object representing the rest parameter of `lambda-list'. If `lambda-list' does not have a rest parameter, this function will return NIL.") (:method ((lambda-list lambda-list)) nil)) (defgeneric body-parameter (lambda-list) (:documentation "Return an object representing the body parameter of `lambda-list'. If `lambda-list' does not have a body parameter, this function will return NIL.") (:method ((lambda-list lambda-list)) nil)) (defgeneric all-parameters (lambda-list) (:documentation "Return a list of all the parameters in `lambda-list'.") (:method-combination append)) (defun clone-lambda-list-element (object &rest additional-initargs) "Create a clone (cloned as much as available initargs permit) of the `lambda-list' object." (apply #'make-instance (class-of object) (append additional-initargs ;; Find initargs and values from class. This only ;; works because we know the lambda-list and ;; parameter slots all have initargs. (loop for slot in (clim-mop:class-slots (class-of object)) for slot-initarg = (first (clim-mop:slot-definition-initargs slot)) for slot-name = (clim-mop:slot-definition-name slot) for slot-boundp = (slot-boundp object slot-name) when (and slot-initarg slot-boundp) nconc (list slot-initarg (slot-value object slot-name)))))) (defgeneric merge-parameters-of-type (lambda-list type parameters) (:documentation "Return a new `lambda-list' object based on `lambda-list' with `parameters' added to the list of parameters of `type', which must be a keyword symbol naming a parameter type.") (:method :around ((lambda-list lambda-list) type parameters) (let* ((result (call-next-method)) (minimum-classes (mapcar #'minimum-lambda-list-class (all-parameters result))) (optimal-subclass (if (null minimum-classes) (class-of result) (first (sort minimum-classes #'subtypep))))) (if (subtype-compatible-p minimum-classes) (change-class result (if (subtypep (class-of result) optimal-subclass) (class-of result) optimal-subclass)) (error "Lambda list has incompatible parameters"))))) (defun set-parameter-minimums (parameters start-value incrementer) "Return a list of clones of the parameters in `parameters' with new \"minimum arg offset\" values. `Start-value' is used for the initial offset, `incrementer' will be called with the previously used offset to calculate a new offset." (loop for parameter in parameters for index = start-value then (funcall incrementer index) collecting (clone-lambda-list-element parameter :min-arg-index index))) (defun increment-parameter-minimums (parameters start-value incrementer) "Return a list of clones of the parameters in `parameters' with new \"minimum arg offset\" values, calculated by adding values to the old ones. `Start-value' is used for the initial offset, `incrementer' will be called with the previously used offset to calculate a new offset to add to the old offset." (when parameters (loop for parameter in parameters for index = start-value then (funcall incrementer index) collecting (clone-lambda-list-element parameter :min-arg-index (+ (min-arg-index parameter) index))))) (defun make-lambda-list (&rest args &key (defaults (make-instance 'ordinary-lambda-list)) &allow-other-keys) "Makes a new lambda-list object from the component arguments, using `defaults' for the default values. The resulting object will be of the same class as `defaults'. `Defaults' defaults to an `ordinary-lambda-list' object containing no parameters." (let ((result defaults)) (loop for (type args) on args by #'cddr unless (eq type :defaults) do (setf result (merge-parameters-of-type result type args)) finally (return result)))) (defclass semiordinary-lambda-list (lambda-list) ((%required-parameters :initarg :required-parameters :initform nil :reader required-parameters) (%optional-parameters :initarg :optional-parameters :initform nil :reader optional-parameters) (%keyword-parameters :initarg :keyword-parameters :initform nil :reader keyword-parameters) (%allow-other-keys :initarg :allow-other-keys :initform nil :reader allow-other-keys-p) (%rest-parameter :initarg :rest-parameter :initform nil :reader rest-parameter)) (:documentation "The class for lambda lists that are approximately ordinary (as found in `defun' and simple `defmacro's).")) (defun positional-parameter-count (lambda-list) "Return the number of positional parameters in `lambda-list'." (+ (length (required-parameters lambda-list)) (length (optional-parameters lambda-list)))) (defmethod merge-parameters-of-type ((lambda-list semiordinary-lambda-list) (type (eql :required-parameters)) (parameters list)) (clone-lambda-list-element lambda-list :required-parameters parameters)) (defmethod merge-parameters-of-type :around ((lambda-list semiordinary-lambda-list) (type (eql :required-parameters)) (parameters list)) (let ((parameter-delta (- (length parameters) (length (required-parameters lambda-list)))) (new-lambda-list (call-next-method))) (clone-lambda-list-element new-lambda-list :required-parameters (set-parameter-minimums (required-parameters new-lambda-list) 0 #'1+) :optional-parameters (increment-parameter-minimums (optional-parameters new-lambda-list) parameter-delta #'identity) :keyword-parameters (increment-parameter-minimums (keyword-parameters new-lambda-list) parameter-delta #'identity) :rest-parameter (first (increment-parameter-minimums (listed (rest-parameter new-lambda-list)) parameter-delta (constantly 0)))))) (defmethod merge-parameters-of-type ((lambda-list semiordinary-lambda-list) (type (eql :optional-parameters)) (parameters list)) (clone-lambda-list-element lambda-list :optional-parameters parameters)) (defmethod merge-parameters-of-type :around ((lambda-list semiordinary-lambda-list) (type (eql :optional-parameters)) (parameters list)) (let ((parameter-delta (- (length parameters) (length (optional-parameters lambda-list)))) (new-lambda-list (call-next-method))) (clone-lambda-list-element new-lambda-list :optional-parameters (set-parameter-minimums (optional-parameters new-lambda-list) (length (required-parameters new-lambda-list)) #'1+) :keyword-parameters (increment-parameter-minimums (keyword-parameters new-lambda-list) parameter-delta #'identity) :rest-parameter (first (increment-parameter-minimums (listed (rest-parameter new-lambda-list)) parameter-delta (constantly 0)))))) (defmethod merge-parameters-of-type ((lambda-list semiordinary-lambda-list) (type (eql :keyword-parameters)) (parameters list)) (clone-lambda-list-element lambda-list :keyword-parameters (set-parameter-minimums parameters (positional-parameter-count lambda-list) #'identity))) (defmethod merge-parameters-of-type ((lambda-list semiordinary-lambda-list) (type (eql :allow-other-keys)) parameter) (check-type parameter boolean) (clone-lambda-list-element lambda-list :allow-other-keys parameter)) (defmethod merge-parameters-of-type ((lambda-list semiordinary-lambda-list) (type (eql :rest-parameter)) parameter) (check-type parameter (or null rest-parameter)) (clone-lambda-list-element lambda-list :rest-parameter (clone-lambda-list-element parameter :min-arg-index (positional-parameter-count lambda-list)))) (defmethod all-parameters append ((lambda-list semiordinary-lambda-list)) (append (required-parameters lambda-list) (optional-parameters lambda-list) (keyword-parameters lambda-list) (when (rest-parameter lambda-list) (list (rest-parameter lambda-list))))) (defclass ordinary-lambda-list (semiordinary-lambda-list) () (:documentation "The class for ordinary lambda lists (as found in `defun').")) (defclass macro-lambda-list (semiordinary-lambda-list) ((%body-parameter :initarg :body-parameter :initform nil :reader body-parameter)) (:documentation "The class for macro lambda lists.")) (defmethod initialize-instance :after ((object macro-lambda-list) &key) (assert (null (and (rest-parameter object) (body-parameter object))) nil "It is not permitted to have both a &rest and a &body argument in a lambda list.")) (defmethod merge-parameters-of-type :around ((lambda-list macro-lambda-list) (type (eql :required-parameters)) (parameters list)) (let ((parameter-delta (- (length parameters) (length (required-parameters lambda-list)))) (new-lambda-list (call-next-method))) (clone-lambda-list-element new-lambda-list :body-parameter (first (increment-parameter-minimums (listed (body-parameter new-lambda-list)) parameter-delta (constantly 0)))))) (defmethod merge-parameters-of-type :around ((lambda-list macro-lambda-list) (type (eql :optional-parameters)) (parameters list)) (let ((parameter-delta (- (length parameters) (length (optional-parameters lambda-list)))) (new-lambda-list (call-next-method))) (clone-lambda-list-element new-lambda-list :body-parameter (first (increment-parameter-minimums (listed (body-parameter new-lambda-list)) parameter-delta (constantly 0)))))) (defmethod merge-parameters-of-type ((lambda-list macro-lambda-list) (type (eql :rest-parameter)) parameter) (check-type parameter (or null rest-parameter)) (clone-lambda-list-element lambda-list :rest-parameter (clone-lambda-list-element parameter :min-arg-index (positional-parameter-count lambda-list)) :body-parameter nil)) (defmethod merge-parameters-of-type ((lambda-list macro-lambda-list) (type (eql :body-parameter)) parameter) (check-type parameter (or null rest-parameter)) (clone-lambda-list-element lambda-list :body-parameter (clone-lambda-list-element parameter :min-arg-index (positional-parameter-count lambda-list)) :rest-parameter nil)) (defmethod all-parameters append ((lambda-list macro-lambda-list)) (when (body-parameter lambda-list) (list (body-parameter lambda-list)))) (defclass destructuring-lambda-list (macro-lambda-list) () (:documentation "The class for nested inner lambda lists (as in macros) and `destructuring-bind' (though it's not used for that here).")) (defgeneric minimum-lambda-list-class (parameter) (:documentation "Return the least specific subclass of `lambda-list' `parameter' should be in.")) (defclass parameter () ((%min-arg-index :initarg :min-arg-index :initform (error "Must provide a minimum argument index for parameter") :reader min-arg-index :documentation "The minimum index an argument must have in its (possibly inner) argument list in order to affect the value of this parameter.")) (:documentation "The base class for lambda list parameters.")) (defmethod minimum-lambda-list-class ((parameter parameter)) 'lambda-list) (defclass named-parameter (parameter) ((%name :initarg :name :initform (error "A name must be provided for a named parameter") :reader name)) (:documentation "The base class for all parameter classes representing a named parameter.")) (defmethod print-object ((p named-parameter) stream) (print-unreadable-object (p stream :type t :identity t) (prin1 (name p) stream))) (defmethod minimum-lambda-list-class ((parameter named-parameter)) 'semiordinary-lambda-list) (defclass destructuring-parameter (parameter) ((%inner-lambda-list :initarg :inner-lambda-list :initform (error "The inner lambda list must be provided for a destructuring parameter") :reader inner-lambda-list)) (:documentation "The base class used for destructing parameters/nested lambda lists (as in macros).")) (defmethod minimum-lambda-list-class ((parameter destructuring-parameter)) 'macro-lambda-list) (defclass required-parameter (parameter) () (:documentation "The class for representing required parameters.")) (defclass optional-parameter (parameter) ((%init-form :initarg :init-form :initform nil :reader init-form)) (:documentation "The class for representing optional parameters.")) (defclass keyword-parameter (optional-parameter) ((%keyword-name :initarg :keyword-name :initform (error "A keyword parameter must have a keyword") :reader keyword-name)) (:documentation "The class for representing keyword parameters.")) (defmethod print-object ((p keyword-parameter) stream) (print-unreadable-object (p stream :type t :identity t) (prin1 (keyword-name p) stream))) (defclass destructuring-required-parameter (destructuring-parameter required-parameter) () (:documentation "The class for representing required destructuring parameters in lambda lists. ")) (defclass destructuring-optional-parameter (destructuring-parameter optional-parameter) () (:documentation "The class for representing optional destructuring parameters in lambda lists. ")) (defclass destructuring-keyword-parameter (destructuring-parameter keyword-parameter) () (:documentation "The class for representing keyword destructuring parameters in lambda lists. ")) (defclass named-required-parameter (named-parameter required-parameter) () (:documentation "The class representing named mandatory parameters in a lambda list.")) (defclass named-optional-parameter (named-parameter optional-parameter) () (:documentation "The class representing named optional parameters in a lambda list.")) (defclass rest-parameter (named-parameter) () (:documentation "The class representing the &rest parameter in a lambda list.")) (defclass body-parameter (rest-parameter) () (:documentation "The class representing the &body parameter in a lambda list.")) ;; Fine-grained conditions for malformed lambda lists. (define-condition invalid-lambda-list (condition) ((%arglist :reader invalid-lambda-list :initarg :arglist :initform (error "Must provide an arglist for condition"))) (:documentation "Subclasses of this condition are signalled whenever a malformed arglist is found during arglist processing.")) (define-condition misplaced-element (invalid-lambda-list) ((%misplaced-element :reader misplaced-element :initarg :misplaced-element :initform (error "Must provide a misplaced element for condition")) (%misplaced-element-index :reader misplaced-element-index :initarg :misplaced-element-index :initform (error "Must provide a misplaced element index for condition"))) (:report (lambda (condition stream) (format stream "Element ~A is not allowed at position ~A in ~A" (misplaced-element condition) (misplaced-element-index condition) (invalid-lambda-list condition)))) (:documentation "Subclasses of this condition are signalled whenever some single element of a lambda list is in an misplaced position.")) (define-condition misplaced-&optional (misplaced-element) () (:documentation "Subclasses of this condition are signalled whenever an &optional argument is misplaced in an argument list.")) (define-condition &optional-after-&key (misplaced-&optional) () (:report (lambda (condition stream) (format stream "&optional found after &key in: ~A" (invalid-lambda-list condition)))) (:documentation "This condition is signalled whenever an &optional parameter is found after a &key argument in an argument list.")) (define-condition &optional-after-&rest (misplaced-&optional) () (:report (lambda (condition stream) (format stream "&optional found after &rest in: ~A" (invalid-lambda-list condition)))) (:documentation "This condition is signalled whenever an &optional parameter is found after a &rest argument in an argument list.")) (define-condition misplaced-&rest (misplaced-element) () (:documentation "Subclasses of this condition are signalled whenever a &rest parameter is misplaced in an argument list.")) (define-condition &rest-after-&key (misplaced-&rest) () (:report (lambda (condition stream) (format stream "&rest found after &key in: ~A" (invalid-lambda-list condition)))) (:documentation "This condition is signalled whenever a &rest parameter is found after a &key argument in a lambda list.")) (define-condition misplaced-&body (misplaced-element) () (:documentation "Subclasses of this condition are signalled whenever a &body parameter is misplaced in an argument list.")) (define-condition &body-after-&key (misplaced-&body) () (:report (lambda (condition stream) (format stream "&body found after &key in: ~A" (invalid-lambda-list condition)))) (:documentation "This condition is signalled whenever a &body parameter is found after a &key argument in a lambda list.")) (define-condition &body-and-&rest-found (misplaced-&body misplaced-&rest) () (:report (lambda (condition stream) (format stream "&body and &rest found in same lambda list: ~A" (invalid-lambda-list condition)))) (:documentation "This condition is signalled whenever both a &body and a &rest parameter is found in the same lambda list.")) (define-condition symbol-after-&allow-other-keys (misplaced-element) () (:report (lambda (condition stream) (format stream "Element ~A at position ~A is not allowed after &allow-other-keys in ~A" (misplaced-element condition) (misplaced-element-index condition) (invalid-lambda-list condition))))) (defun make-required-parameter (parameter-data &optional (min-arg-index 0)) "Parse `parameter-data' as a required parameter and return two values: an appropriate parameter object and a boolean that is NIL if the parameter cannot be part of an ordinary lambda list." (if (listp parameter-data) (values (make-instance 'destructuring-required-parameter :min-arg-index min-arg-index :inner-lambda-list (parse-lambda-list parameter-data 'destructuring-lambda-list)) t) (make-instance 'named-required-parameter :name parameter-data :min-arg-index min-arg-index))) (defun make-&optional-parameter (parameter-data &optional (min-arg-index 0)) "Parse `parameter-data' as an optional parameter and return two values: an appropriate parameter object and a boolean that is NIL if the parameter cannot be part of an ordinary lambda list." (cond ((and (listp parameter-data) (listp (first parameter-data))) (values (make-instance 'destructuring-optional-parameter :init-form (second parameter-data) :min-arg-index min-arg-index :inner-lambda-list (parse-lambda-list (first parameter-data) 'destructuring-lambda-list)) t)) ((listp parameter-data) (make-instance 'named-optional-parameter :init-form (second parameter-data) :min-arg-index min-arg-index :name (first parameter-data))) ((symbolp parameter-data) (make-instance 'named-optional-parameter :init-form nil :min-arg-index min-arg-index :name parameter-data)) (t (error "I have no idea how to handle ~A as an optional parameter in a lambda list" parameter-data)))) (defun make-&key-parameter (parameter-data &optional (min-arg-index 0)) "Parse `parameter-data' as a keyword parameter and return two values: an appropriate parameter object and a boolean that is true if the parameter cannot be part of an ordinary lambda list." (cond ((and (listp parameter-data) (listp (first parameter-data)) (listp (second (first parameter-data)))) (values (make-instance 'destructuring-keyword-parameter :init-form (second parameter-data) :min-arg-index min-arg-index :keyword-name (first (first parameter-data)) :inner-lambda-list (parse-lambda-list (second (first parameter-data)) 'destructuring-lambda-list)) t)) ((listp parameter-data) (make-instance 'keyword-parameter :init-form (second parameter-data) :min-arg-index min-arg-index :keyword-name (if (listp (first parameter-data)) (first (first parameter-data)) (intern (string (first parameter-data)) :keyword)))) ((symbolp parameter-data) (make-instance 'keyword-parameter :init-form nil :min-arg-index min-arg-index :keyword-name (intern (symbol-name parameter-data) :keyword))) (t (error "I have no idea how to handle ~A as a keyword parameter in a lambda list" parameter-data)))) (defun make-&rest-parameter (parameter-data &optional (min-arg-index 0)) "Parse `parameter-data' as a rest parameter and return two values: an appropriate parameter object and a boolean that is true if the parameter cannot be part of an ordinary lambda list." (make-instance 'rest-parameter :name parameter-data :min-arg-index min-arg-index)) (defun make-&body-parameter (parameter-data &optional (min-arg-index 0)) "Parse `parameter-data' as a body parameter and return two values: an appropriate parameter object and a boolean that is true if the parameter cannot be part of an ordinary lambda list." (values (make-instance 'body-parameter :name parameter-data :min-arg-index min-arg-index) t)) (defun parse-lambda-list (lambda-list &optional class) "Convert a provided `lambda-list' (as a list) to a `lambda-list' object, and signal errors if the lambda list is found to be invalid. This function can handle ordinary lambda lists, generic function lambda lists, macro lambda lists and extended lambda lists. If `lambda-list' is an invalid lambda list, an appropriate subclass of `invalid-lambda-list' will be signalled. If `class' is non-NIL, it should be the name of a subclass of `semiordinary-lambda-list'. A lambda list of this class will be returned. Otherwise, `parse-lambda-list' will figure out the right class based on the lambda list contents." (declare (optimize (debug 3))) (let ((ordinary-lambda-list-p t) (macro-lambda-list-p t) (index 0)) (labels ((incr-index () (prog1 index (incf index))) (update-ordinarity (new-ordinarity) (when ordinary-lambda-list-p (setf ordinary-lambda-list-p (not new-ordinarity)))) (required-parameter (parameter) (multiple-value-bind (parameter unordinaryp) (make-required-parameter parameter (incr-index)) (prog1 parameter (update-ordinarity unordinaryp)))) (&optional-parameter (parameter) (multiple-value-bind (parameter unordinaryp) (make-&optional-parameter parameter (incr-index)) (prog1 parameter (update-ordinarity unordinaryp)))) (&key-parameter (parameter) (multiple-value-bind (parameter unordinaryp) (make-&key-parameter parameter index) (prog1 parameter (update-ordinarity unordinaryp))))) (multiple-value-bind (required optional keyword allow-other-keys rest body) (macrolet ((in (&key optional key rest body) `(setf in-required nil in-&optional ,optional in-&key ,key in-&rest ,rest in-&body ,body)) (misplaced (condition &rest args) `(error ',condition :arglist lambda-list :misplaced-element element :misplaced-element-index index ,@args))) (loop for element in lambda-list with in-required = t with in-&optional = nil with in-&key = nil with in-&rest = nil with in-&body = nil with saw-&allow-other-keys = nil with saw-&rest-or-&body-param = nil if saw-&allow-other-keys do (misplaced symbol-after-&allow-other-keys) else if (lambda-list-keyword-p element) do (case element (&optional (cond (in-&key (misplaced &optional-after-&key)) (in-&rest (misplaced &optional-after-&rest)) (t (in :optional t)))) (&key (in :key t)) (&rest (cond (in-&key (misplaced &rest-after-&key)) (in-&body (misplaced &body-and-&rest-found)) (t (in :rest t)))) (&body (cond (in-&key (misplaced &body-after-&key)) (in-&rest (misplaced &body-and-&rest-found)) (t (in :body t)))) (&allow-other-keys (setf saw-&allow-other-keys t))) else if in-required collect (required-parameter element) into required else if in-&optional collect (&optional-parameter element) into optional else if in-&key collect (&key-parameter element) into keyword else if in-&rest if saw-&rest-or-&body-param do (misplaced misplaced-element) end and collect (make-&rest-parameter element index) into rest and do (setf saw-&rest-or-&body-param t) else if in-&body if saw-&rest-or-&body-param do (misplaced misplaced-element) end and do (setf ordinary-lambda-list-p nil) and collect (make-&body-parameter element index) into body and do (setf saw-&rest-or-&body-param t) finally (return (values required optional keyword saw-&allow-other-keys rest body)))) (assert (not (and body rest)) nil "There cannot be both &body and &rest in a lambda list") (let ((lambda-list-class (cond (class class) (ordinary-lambda-list-p 'ordinary-lambda-list) (macro-lambda-list-p 'macro-lambda-list)))) (apply #'make-instance lambda-list-class :original-lambda-list lambda-list :required-parameters required :optional-parameters optional :keyword-parameters keyword :allow-other-keys allow-other-keys :rest-parameter (first rest) (when (subtypep 'macro-lambda-list lambda-list-class) (list :body-parameter (first body))))))))) (defgeneric lambda-list-as-list (lambda-list) (:documentation "Return the list version of the provided lambda list object. This could be considered \"serialization\" of the lambda list object.")) (defgeneric serialize-lambda-list-parameter (element) (:documentation "Used by `lambda-list-as-list' to convert lambda list parameter objects to symbols or lists.")) (defmethod serialize-lambda-list-parameter ((element named-parameter)) (name element)) (defmethod serialize-lambda-list-parameter ((element named-optional-parameter)) (if (init-form element) (list (name element) (init-form element)) (name element))) (defmethod serialize-lambda-list-parameter ((element keyword-parameter)) (if (init-form element) (list (keyword-name element) (init-form element)) (keyword-name element))) (defmethod serialize-lambda-list-parameter ((element destructuring-required-parameter)) (lambda-list-as-list (inner-lambda-list element))) (defmethod serialize-lambda-list-parameter ((element destructuring-optional-parameter)) (append (list (lambda-list-as-list (inner-lambda-list element))) (when (init-form element) (list (init-form element))))) (defmethod serialize-lambda-list-parameter ((element destructuring-keyword-parameter)) (append (list (keyword-name element) (lambda-list-as-list (inner-lambda-list element))) (when (init-form element) (list (init-form element))))) ;; The following two methods are annoyingly similar. (defmethod lambda-list-as-list ((lambda-list ordinary-lambda-list)) (flet ((serialize-parameters (parameters) (mapcar #'serialize-lambda-list-parameter parameters))) (let ((required (serialize-parameters (required-parameters lambda-list))) (optional (serialize-parameters (optional-parameters lambda-list))) (rest (rest-parameter lambda-list)) (keyword (serialize-parameters (keyword-parameters lambda-list))) (allow-other-keys (allow-other-keys-p lambda-list))) (nconc required (when optional (cons '&optional optional)) (when rest (list '&rest (serialize-lambda-list-parameter rest))) (when keyword (cons '&key keyword)) (when allow-other-keys (list '&allow-other-keys)))))) (defmethod lambda-list-as-list ((lambda-list macro-lambda-list)) (flet ((serialize-parameters (parameters) (mapcar #'serialize-lambda-list-parameter parameters))) (let ((required (serialize-parameters (required-parameters lambda-list))) (optional (serialize-parameters (optional-parameters lambda-list))) (rest (rest-parameter lambda-list)) (body (body-parameter lambda-list)) (keyword (serialize-parameters (keyword-parameters lambda-list))) (allow-other-keys (allow-other-keys-p lambda-list))) (nconc required (when optional (cons '&optional optional)) (when rest (list '&rest (serialize-lambda-list-parameter rest))) (when body (list '&body (serialize-lambda-list-parameter body))) (when keyword (cons '&key keyword)) (when allow-other-keys (list '&allow-other-keys)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; indentation (defgeneric indent-form (syntax tree path)) (defmethod indent-form ((syntax lisp-syntax) (tree form*) path) (cond ((or (null path) (and (null (cdr path)) (zerop (car path)))) (values tree 0)) ((null (cdr path)) (values (elt-noncomment (children tree) (1- (car path))) 0)) (t (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path))))) (defmethod indent-form ((syntax lisp-syntax) (tree string-form) path) (values (form-toplevel syntax tree) 0)) (defmethod indent-form ((syntax lisp-syntax) (tree reader-conditional-form) path) (cond ((or (null path) (and (null (cdr path)) (zerop (car path)))) (values tree 0)) ((null (cdr path)) (values (first-form (children tree)) 0)))) (defmethod indent-form ((syntax lisp-syntax) (tree readtime-evaluation-form) path) (if (null (cdr path)) (values tree 0) (indent-form syntax (elt-form (children tree) 0) (cdr path)))) (defmethod indent-form ((syntax lisp-syntax) (tree list-form) path) (if (and (= (car path) 1) (null (cdr path))) ;; Before first element. (values tree 1) (let ((first-child (elt-noncomment (children tree) 1))) (cond ((form-token-p first-child) (compute-list-indentation syntax (form-to-object syntax first-child) tree path)) ((null (cdr path)) ;; top level (if (= (car path) 2) ;; indent like first element (values (elt-noncomment (children tree) 1) 0) ;; indent like second element (values (elt-noncomment (children tree) 2) 0))) (t ;; inside a subexpression (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path))))))) (defmethod indent-form ((syntax lisp-syntax) (tree simple-vector-form) path) (if (= (car path) 1) ;; Before first element. (values tree 1) (cond ((null (cdr path)) ;; Top level, indent like first element. (values (elt-noncomment (children tree) 1) 0)) (t ;; Inside a subexpression. (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path)))))) (defmethod indent-form ((syntax lisp-syntax) (tree token-form) path) (values tree 0)) (defmethod indent-form ((syntax lisp-syntax) (tree error-symbol) path) (values tree 0)) (defmethod indent-form ((syntax lisp-syntax) (tree long-comment-form) path) (values tree 0)) (defmethod indent-form ((syntax lisp-syntax) (tree pathname-form) path) (values tree 0)) (defmethod indent-form ((syntax lisp-syntax) (tree quote-form) path) (indent-list syntax (elt-noncomment (children tree) (car path)) (cdr path))) (defmethod indent-form ((syntax lisp-syntax) (tree backquote-form) path) (if (null (cdr path)) (indent-list syntax (elt-noncomment (children tree) (car path)) (cdr path)) (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path)))) (defmethod indent-form ((syntax lisp-syntax) (tree comma-form) path) (if (null (cdr path)) (indent-list syntax (elt-noncomment (children tree) (car path)) (cdr path)) (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path)))) (defmethod indent-form ((syntax lisp-syntax) (tree comma-at-form) path) (if (null (cdr path)) (indent-list syntax (elt-noncomment (children tree) (car path)) (cdr path)) (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path)))) (defmethod indent-form ((syntax lisp-syntax) (tree comma-dot-form) path) (if (null (cdr path)) (indent-list syntax (elt-noncomment (children tree) (car path)) (cdr path)) (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path)))) (defmethod indent-form ((syntax lisp-syntax) (tree function-form) path) (if (null (cdr path)) (values tree 0) (indent-form syntax (elt-form (children tree) 0) (cdr path)))) (defmethod indent-binding ((syntax lisp-syntax) tree path) (if (null (cdr path)) ;; top level (cond ((= (car path) 1) ;; before variable, indent 1 (values tree 1)) ((= (car path) 2) ;; between variable and value (values (elt-noncomment (children tree) 1) 0)) (t ;; after value (values (elt-noncomment (children tree) 2) 0))) (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path)))) (defmethod indent-bindings ((syntax lisp-syntax) tree path) (if (null (cdr path)) ;; entire bind form (if (= (car path) 1) ;; before first binding, indent 1 (values tree 1) ;; after some bindings, align with first binding (values (elt-noncomment (children tree) 1) 0)) ;; inside a bind form (indent-binding syntax (elt-noncomment (children tree) (car path)) (cdr path)))) (defmethod compute-list-indentation ((syntax lisp-syntax) (symbol symbol) tree path) (if (null (cdr path)) ;; top level (let* ((arglist (when (fboundp symbol) (arglist-for-form syntax symbol))) (body-or-rest-arg (when arglist (or (body-parameter arglist) (rest-parameter arglist)))) (body-or-rest-pos (when body-or-rest-arg (min-arg-index body-or-rest-arg)))) (if (and (or (macro-function symbol) (special-operator-p symbol)) (and (not (null body-or-rest-pos)) (plusp body-or-rest-pos))) ;; macro-form with "interesting" arguments. (if (>= (- (car path) 2) body-or-rest-pos) ;; &body arg. (values (elt-noncomment (children tree) 1) 1) ;; non-&body-arg. (values (elt-noncomment (children tree) 1) 1)) ;; normal form. (call-next-method))) ;; inside a subexpression (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path)))) (defmethod compute-list-indentation ((syntax lisp-syntax) symbol tree path) (if (null (cdr path)) ;; normal form. (if (= (car path) 2) ;; indent like first child (values (elt-noncomment (children tree) 1) 0) ;; indent like second child (values (elt-noncomment (children tree) 2) 0)) ;; inside a subexpression (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path)))) ;; TODO: `define-simple-indentor' is not flexible enough for the ;; indentation rules of `progn' and `multiple-value-bind' (and a few ;; others). TODO: Write a more powerful `define-indentor'. (defmethod compute-list-indentation ((syntax lisp-syntax) (symbol (eql 'progn)) tree path) (if (null (cdr path)) ;; normal form. (if (= (car path) 2) (values (elt-noncomment (children tree) 1) 1) (values (elt-noncomment (children tree) 2) 0)) ;; inside a subexpression (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path)))) (defmethod compute-list-indentation ((syntax lisp-syntax) (symbol (eql 'multiple-value-bind)) tree path) (cond ((null (cdr path)) (cond ;; Value bindings. ((= (car path) 2) (values tree 6)) ;; Values form. ((= (car path) 3) (values tree 4)) ;; First element of body. ((= (car path) 4) (values tree 2)) ;; More body elements, indent to first body element, like ;; `progn'. (t (values (elt-noncomment (children tree) 4) 0)))) ((= (car path) 2) (indent-list syntax (elt-noncomment (children tree) 2) (cdr path))) ((= (car path) 3) (indent-form syntax (elt-noncomment (children tree) 3) (cdr path))) (t (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path))))) (defmacro define-list-indentor (name element-indentor) `(defun ,name (syntax tree path) (if (null (cdr path)) ;; top level (if (= (car path) 1) ;; indent one more than the list (values tree 1) ;; indent like the first element (values (elt-noncomment (children tree) 1) 0)) ;; inside an element (,element-indentor syntax (elt-noncomment (children tree) (car path)) (cdr path))))) ;;; line up the elements vertically (define-list-indentor indent-list indent-list) ;;; for now the same as indent-list, but try to do better with ;;; optional parameters with default values (define-list-indentor indent-ordinary-lambda-list indent-list) ;;; again, can do better (define-list-indentor indent-macro-lambda-list indent-list) ;;; FIXME: also BOA, DEFSETF, DEFTYPE, SPECIALIZED, GENERIC-FUNCTION, ;;; DESTRUCTURING, DEFINE-MODIFY-MACRO and ;;; DEFINE-METHOD-COMBINATION-ARGUMENTS (defmacro define-simple-indentor (template) `(defmethod compute-list-indentation ((syntax lisp-syntax) (symbol (eql ',(car template))) tree path) (cond ((null (cdr path)) (values tree (if (<= (car path) ,(length template)) 4 2))) ,@(loop for fun in (cdr template) for i from 2 collect `((= (car path) ,i) (,fun syntax (elt-noncomment (children tree) ,i) (cdr path)))) (t (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path)))))) (define-simple-indentor (prog1 indent-form)) (define-simple-indentor (prog2 indent-form indent-form)) (define-simple-indentor (locally)) (define-simple-indentor (let indent-bindings)) (define-simple-indentor (let* indent-bindings)) (define-simple-indentor (defun indent-list indent-ordinary-lambda-list)) (define-simple-indentor (defmacro indent-list indent-macro-lambda-list)) (define-simple-indentor (with-slots indent-bindings indent-form)) (define-simple-indentor (with-accessors indent-bindings indent-form)) (define-simple-indentor (when indent-form)) (define-simple-indentor (unless indent-form)) (define-simple-indentor (print-unreadable-object indent-list)) (define-simple-indentor (defvar indent-form)) (define-simple-indentor (defparameter indent-form)) (define-simple-indentor (defconstant indent-form)) (define-simple-indentor (lambda indent-ordinary-lambda-list)) (define-simple-indentor (pprint-logical-block indent-list)) ;;; non-simple-cases: LOOP, MACROLET, FLET, LABELS ;;; do this better (define-list-indentor indent-slot-specs indent-list) (defmethod compute-list-indentation ((syntax lisp-syntax) (symbol (eql 'defclass)) tree path) (if (null (cdr path)) ;; top level (values tree (if (<= (car path) 3) 4 2)) (case (car path) ((2 3) ;; in the class name or superclasses respectively (indent-list syntax (elt-noncomment (children tree) (car path)) (cdr path))) (4 ;; in the slot specs (indent-slot-specs syntax (elt-noncomment (children tree) 4) (cdr path))) (t ;; this is an approximation, might want to do better (indent-list syntax (elt-noncomment (children tree) (car path)) (cdr path)))))) (defmethod compute-list-indentation ((syntax lisp-syntax) (symbol (eql 'defgeneric)) tree path) (if (null (cdr path)) ;; top level (values tree (if (<= (car path) 3) 4 2)) (case (car path) (2 ;; in the function name (indent-list syntax (elt-noncomment (children tree) 2) (cdr path))) (3 ;; in the lambda-list (indent-ordinary-lambda-list syntax (elt-noncomment (children tree) 3) (cdr path))) (t ;; in the options or method specifications (indent-list syntax (elt-noncomment (children tree) (car path)) (cdr path)))))) (defmethod compute-list-indentation ((syntax lisp-syntax) (symbol (eql 'defmethod)) tree path) (let ((lambda-list-pos (position-if #'form-list-p (remove-if #'comment-p (children tree))))) (cond ((null (cdr path)) ;; top level (values tree (if (or (null lambda-list-pos) (<= (car path) lambda-list-pos)) 4 2))) ((or (null lambda-list-pos) (< (car path) lambda-list-pos)) (indent-list syntax (elt-noncomment (children tree) (car path)) (cdr path))) ((= (car path) lambda-list-pos) (indent-ordinary-lambda-list syntax (elt-noncomment (children tree) (car path)) (cdr path))) (t (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path)))))) (defun indent-clause (syntax tree path) (if (null (cdr path)) ;; top level (case (car path) (1 (values tree 1)) (2 (values tree 1)) (t (values (elt-noncomment (children tree) 2) 0))) (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path)))) (defmethod compute-list-indentation ((syntax lisp-syntax) (symbol (eql 'cond)) tree path) (if (null (cdr path)) ;; top level (if (= (car path) 2) ;; after `cond' (values tree 2) ;; indent like the first clause (values (elt-noncomment (children tree) 2) 0)) ;; inside a clause (indent-clause syntax (elt-noncomment (children tree) (car path)) (cdr path)))) (macrolet ((def (symbol) `(defmethod compute-list-indentation ((syntax lisp-syntax) (symbol (eql ',symbol)) tree path) (if (null (cdr path)) (case (car path) (2 (values tree 4)) (3 (values tree 2)) (t (values (elt-noncomment (children tree) 3) 0))) (indent-clause syntax (elt-noncomment (children tree) (car path)) (cdr path)))))) (def case) (def ccase) (def ecase) (def typecase) (def ctypecase) (def etypecase)) (defmethod compute-list-indentation ((syntax lisp-syntax) (symbol (eql 'tagbody)) tree path) (if (null (cdr path)) ;; this TOKEN-MIXIN test is not quite right. It should be a ;; test for symbolness of the token, but it shouldn't depend on ;; the symbol existing in the current image. (Arguably, too, ;; this is a broken indentation form because it doesn't carry ;; over to the implicit tagbodies in macros such as DO. (if (form-token-p (elt-noncomment (children tree) (car path))) (values tree 2) (values tree 4)) (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path)))) (defmethod indent-local-function-definition ((syntax lisp-syntax) tree path) (cond ((null (cdr path)) ;; top level (cond ((= (car path) 1) ;; before name, indent 1 (values tree 1)) ((= (car path) 2) ;; between name and lambda list, indent 4 (values (elt-noncomment (children tree) 1) 4)) (t ;; after lambda list, indent 2 (values (elt-noncomment (children tree) 1) 2)))) ((= (car path) 1) ;; inside lambda list (indent-ordinary-lambda-list syntax (elt-noncomment (children tree) 1) (cdr path))) (t (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path))))) (define-list-indentor indent-local-function-definitions indent-local-function-definition) (define-simple-indentor (flet indent-local-function-definitions)) (define-simple-indentor (labels indent-local-function-definitions)) (define-simple-indentor (with-open-file indent-list)) ;;; CLIM indentation (define-simple-indentor (clim:with-output-as-presentation indent-list)) (define-simple-indentor (clim:vertically indent-list)) (define-simple-indentor (clim:horizontally indent-list)) (define-simple-indentor (clim:scrolling indent-list)) (define-simple-indentor (clim:with-drawing-options indent-list)) (define-simple-indentor (clim:define-command-table indent-list)) (define-simple-indentor (clim:define-command indent-list indent-list)) (define-simple-indentor (clim:define-application-frame indent-list indent-list)) (defun compute-path-in-trees (trees n offset) (cond ((or (null (first-noncomment trees)) (>= (start-offset (first-noncomment trees)) offset)) (list n)) ((or (< (start-offset (first-noncomment trees)) offset (end-offset (first-noncomment trees))) (typep (first-noncomment trees) 'incomplete-form-mixin)) (cons n (compute-path-in-tree (first-noncomment trees) offset))) (t (compute-path-in-trees (rest-noncomments trees) (1+ n) offset)))) (defun compute-path-in-tree (tree offset) (if (null (children tree)) '() (compute-path-in-trees (children tree) 0 offset))) (defun compute-path (syntax offset) (with-slots (stack-top) syntax (compute-path-in-tree stack-top offset))) (defun real-column-number (mark tab-width) (let ((mark2 (clone-mark mark))) (beginning-of-line mark2) (loop with column = 0 until (mark= mark mark2) do (if (eql (object-after mark2) #\Tab) (loop do (incf column) until (zerop (mod column tab-width))) (incf column)) do (incf (offset mark2)) finally (return column)))) (defmethod syntax-line-indentation ((syntax lisp-syntax) mark tab-width) (update-parse syntax 0 (offset mark)) (setf mark (clone-mark mark)) (beginning-of-line mark) (with-slots (stack-top) syntax (let ((path (compute-path syntax (offset mark)))) (multiple-value-bind (tree offset) (indent-form syntax stack-top path) (setf (offset mark) (start-offset tree)) (+ (real-column-number mark tab-width) offset))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Commenting (defmethod syntax-line-comment-string ((syntax lisp-syntax)) ";;; ") (defmethod comment-region ((syntax lisp-syntax) mark1 mark2) (line-comment-region syntax mark1 mark2)) (defmethod uncomment-region ((syntax lisp-syntax) mark1 mark2) (line-uncomment-region syntax mark1 mark2)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/input-editor.lisp0000644000175000017500000012417111345155772021216 0ustar pdmpdm;;; -*- Mode: Lisp; Package: DREI -*- ;;; (c) copyright 2001 by ;;; Tim Moore (moore@bricoworks.com) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Implementation of various bits and parts needed for Drei to ;;; function as the input-editor of McCLIM. Meaning, this is an ;;; interface between input-editing-streams and Drei instances. We ;;; also try not to mess too much with CLIM-INTERNALS to be somewhat ;;; portable (but not too much). (in-package :drei) ;; Note that we use `stream-scan-pointer' to access the scan pointer ;; of the stream in the protocol methods, despite the fact that the ;; `drei-input-editing-mixin' class does not have a scan pointer. We ;; assume that the subclass defines a scan pointer. (defclass drei-input-editing-mixin () ((%drei-instance :accessor drei-instance-of :initarg :drei-instance) (%input-position :accessor input-position :initform 0) (%activation-gesture :accessor activation-gesture :initform nil) (%rescanning-p :reader stream-rescanning-p :writer (setf stream-rescanning) :initform nil) (%input-buffer-array :accessor input-buffer-array :initform nil :documentation "After a command has been executed, the contents of the Drei area instance shall be replaced by the contents of this array, if non-NIL.")) (:documentation "An mixin that helps in implementing Drei-based input-editing streams. This class should not be directly instantiated.")) (defmethod initialize-instance :after ((obj drei-input-editing-mixin) &rest args &key stream (cursor-visibility t) (min-width 0)) (check-type min-width (or (integer 0) (eql t))) (check-type stream clim-stream-pane) (multiple-value-bind (cx cy) (stream-cursor-position stream) (let ((max-width (- (stream-text-margin stream) cx))) (with-keywords-removed (args (:initial-contents)) (setf (drei-instance obj) (apply #'make-instance 'drei-area :editor-pane stream :x-position cx :y-position cy :active cursor-visibility :max-width max-width :allow-other-keys t args))) ;; XXX Really add it here? (stream-add-output-record stream (drei-instance obj))))) (defmethod stream-default-view ((stream drei-input-editing-mixin)) (view (drei-instance stream))) (defmethod stream-insertion-pointer ((stream drei-input-editing-mixin)) (offset (point (view (drei-instance stream))))) (defmethod (setf stream-insertion-pointer) ((new-value integer) (stream drei-input-editing-mixin)) (setf (offset (point (view (drei-instance stream)))) new-value)) (defmethod cursor-visibility ((stream drei-input-editing-mixin)) (if (point-cursor (drei-instance stream)) (active (point-cursor (drei-instance stream))) ;; Uh... no I guess? nil)) (defmethod (setf cursor-visibility) (visibility (stream drei-input-editing-mixin)) (setf (active (drei-instance stream)) visibility (cursors-visible (drei-instance stream)) visibility)) (defclass drei-unselectable-presentation (presentation) () (:documentation "A presentation that will not be highlightable, and can thus be safely used for implementing stuff such as noise strings.")) (define-presentation-translator unselectable-presentation-to-nothing (drei-unselectable-presentation t global-command-table :menu nil :tester ((object) (declare (ignore object)))) (object) (declare (ignore object))) (defclass noise-string (drei-unselectable-presentation) ((%string :initarg :string :initform (error "A noise string must represent some string.") :reader noisy-string) (%text-style :initarg :text-style :initform (make-text-style :serif :italic nil) :reader text-style)) (:documentation "Buffer objects of this class will be skipped by the input-editor gesture reader. They should not be used outside the input editor.")) (define-presentation-method present ((object noise-string) (type noise-string) stream (view textual-view) &key &allow-other-keys) (with-text-style (stream (text-style object)) (princ (noisy-string object) stream))) (defclass accept-result (presentation) ((%object :initarg :object :initform (error "An object must be provided for the accept result.") :reader object) (%result-type :initarg :result-type :initform t :reader result-type)) (:documentation "Buffer objects of this class are inserted into the buffer when the user clicks on an applicable presentation while in an input context for the input-editor. They should not be used outside the input-editor.")) (define-presentation-method present (object (type accept-result) stream (view textual-view) &rest args &key) (apply #'present (object object) (result-type object) :stream stream :view view args)) (defmethod prompt-for-accept :around ((stream drei-input-editing-mixin) type view &rest args &key &allow-other-keys) (declare (ignore args)) ;; XXX: In Drei, the "input position" (a lovably underspecified ;; concept in the CLIM spec) is just after any input prompt. We do ;; not set the input position (or print the prompt) if we are ;; already at the input position or if we are rescanning. This is so ;; we can support fancy accept methods such as the one for ;; `command-or-form' (unless (stream-rescanning-p stream) ;; Put the prompt in the proper place, but be super careful not to ;; mess with the insertion pointer. (let ((ip-clone (clone-mark (point (view (drei-instance stream)))))) (unwind-protect (progn (setf (stream-insertion-pointer stream) (stream-scan-pointer stream)) (call-next-method)) (setf (stream-insertion-pointer stream) (offset ip-clone))) (redraw-input-buffer stream))) ;; We skip ahead of any noise strings to put us past the ;; prompt. This is safe, because the noise strings are to be ;; ignored anyway, but we need to be ahead to set the input ;; position properly (ie. after the prompt). (loop with buffer = (buffer (view (drei-instance stream))) until (>= (stream-scan-pointer stream) (size buffer)) while (or (typep #1=(buffer-object buffer (stream-scan-pointer stream)) 'noise-string) (delimiter-gesture-p #1#)) do (incf (stream-scan-pointer stream))) (setf (input-position stream) (stream-scan-pointer stream))) (defmethod stream-accept :after ((stream drei-input-editing-mixin) type &key &allow-other-keys) ;; If we end up asking for more input using the stream, we do not ;; want to permit the user to undo input for this context. (clear-undo-history (buffer (view (drei-instance stream))))) (defun buffer-array-mismatch (sequence1 sequence2 &key (from-end nil) (start1 0) (start2 0)) "Like `cl:mismatch', but supporting fewer keyword arguments, and the two sequences can be Drei buffers instead." (flet ((seq-elt (seq i) (typecase seq (drei-buffer (buffer-object seq i)) (array (aref seq i)))) (seq-length (seq) (typecase seq (drei-buffer (size seq)) (array (length seq))))) (if from-end (loop for index1 downfrom (1- (seq-length sequence1)) to 0 for index2 downfrom (1- (seq-length sequence2)) to 0 unless (= index1 index2 0) if (or (= index1 0) (= index2 0)) return index1 unless (eql (seq-elt sequence1 index1) (seq-elt sequence2 index2)) return (1+ index1)) (do* ((i1 start1 (1+ i1)) (i2 start2 (1+ i2)) x1 x2) ((and (>= i1 (seq-length sequence1)) (>= i2 (seq-length sequence2))) nil) (if (>= i1 (seq-length sequence1)) (return i1)) (if (>= i2 (seq-length sequence2)) (return i1)) (setq x1 (seq-elt sequence1 i1)) (setq x2 (seq-elt sequence2 i2)) (unless (eql x1 x2) (return i1)))))) (defun synchronize-drei-buffer (stream) "If the `input-buffer-array' of `stream' is non-NIL, copy the contents of the array to the Drei buffer. This will set the contents of the buffer to the contents of the array up to the fill pointer." (with-accessors ((array input-buffer-array)) stream (let ((buffer (buffer (view (drei-instance stream))))) (when array ;; Attempt to minimise the changes to the buffer, so the ;; position of marks will not be changed too much. Find the ;; first mismatch between buffer contents and array contents. (multiple-value-bind (index buffer-end array-end) (let* ((buffer-array-mismatch-begin (or (buffer-array-mismatch buffer array) 0)) (buffer-buffer-array-mismatch-end (or (buffer-array-mismatch buffer array :from-end t :start2 buffer-array-mismatch-begin) buffer-array-mismatch-begin)) (array-buffer-array-mismatch-end (or (buffer-array-mismatch array buffer :from-end t :start2 buffer-array-mismatch-begin) buffer-array-mismatch-begin))) (values buffer-array-mismatch-begin (max buffer-buffer-array-mismatch-end buffer-array-mismatch-begin) (max array-buffer-array-mismatch-end buffer-array-mismatch-begin))) (let ((insertion-pointer (stream-insertion-pointer stream))) (when index ; NIL if buffer and array are identical. ;; Delete from the first mismatch to the end of the ;; mismatch. (delete-buffer-range buffer index (- buffer-end index)) ;; Also delete from the end of the buffer if the array ;; is smaller than the buffer. (when (> (size buffer) (length array)) (delete-buffer-range buffer (length array) (- (size buffer) (length array)))) ;; Insert from the mismatch to end mismatch from the ;; array into the buffer. (insert-buffer-sequence buffer index (subseq array index array-end)) ;; Finally, see if it is possible to maintain the old ;; position of the insertion pointer. (setf (stream-insertion-pointer stream) (min insertion-pointer (size buffer)))))))))) (defun synchronize-input-buffer-array (stream) "If the `input-buffer-array' of `stream' is non-NIL, copy the contents of the Drei buffer to the array. The fill pointer of the array will point to after the last element." (with-accessors ((array input-buffer-array)) stream (let ((buffer (buffer (view (drei-instance stream))))) (when array (let ((new-array (buffer-sequence buffer 0 (size buffer)))) (setf array ;; We probably lose if `adjust-array' doesn't ;; destructively modify `array. (adjust-array array (length new-array) :initial-contents new-array :fill-pointer (length new-array)))))))) (defun update-drei-buffer (stream) "Update the Drei buffer of the Drei instance used by `stream' if the `input-buffer-array' of `stream' is non-NIl. This will set the contents of the buffer to the contents of the array up to the fill pointer. Changes to the buffer will be recordes as undoable. When this function returns, the `input-buffer-array' of `stream' will be NIL. Also, the syntax will be up-to-date." (with-undo ((list (buffer (view (drei-instance stream))))) (synchronize-drei-buffer stream)) (setf (input-buffer-array stream) nil)) ;; While the CLIM spec says that user-commands are not allowed to do ;; much with the input buffer, the Franz User Guide provides some ;; examples that hint to the opposite. How do we make modifications of ;; the input-buffer, which must be a standard array with a fill ;; pointer, to be applied to the "real" buffer? This is how: when this ;; method is called, we store the object in the stream object. In the ;; command loop, we check the stream object and update the buffer ;; (using `update-drei-buffer') to reflect the changes done to the ;; buffer. (defmethod stream-input-buffer ((stream drei-input-editing-mixin)) ;; NOTE: This is very slow (consing up a whole new array - twice!), ;; please do not use it unless you want to be compatible with other ;; editor substrates. Use the Drei buffer directly instead. (unless (input-buffer-array stream) ;; Create dummy array and synchronize it to the buffer contents. (setf (input-buffer-array stream) (make-array 0 :fill-pointer 0)) (synchronize-input-buffer-array stream)) (input-buffer-array stream)) (defmethod replace-input ((stream drei-input-editing-mixin) (new-input array) &key (start 0) (end (length new-input)) (buffer-start (input-position stream)) (rescan nil rescan-supplied-p)) (check-type start integer) (check-type end integer) (check-type buffer-start integer) ;; Since this is a CLIM-specified function, we have to make sure the ;; input-buffer-array is taken into consideration, because some ;; input-editor-command might call this function and expect the ;; changes to be reflected in the array it holds. Also, if changes ;; have been made to the array, they need to be propagated to the ;; buffer before we do anything. (synchronize-drei-buffer stream) (let* ((drei (drei-instance stream)) (view (view drei)) (new-contents (subseq new-input start end)) (old-contents (buffer-sequence (buffer view) buffer-start (stream-scan-pointer stream))) (equal (and (= (length new-contents) (length old-contents)) (every #'equal new-contents old-contents)))) (let ((begin-mark (clone-mark (point view)))) (unless equal (setf (offset begin-mark) buffer-start) (delete-region begin-mark (stream-scan-pointer stream)) (insert-sequence begin-mark new-contents) ;; Make the buffer reflect the changes in the array. (synchronize-input-buffer-array stream)) (display-drei drei) ;; XXX: This behavior for the :rescan parameter is not mentioned ;; explicitly in any CLIM guide, but McCLIM input-editing ;; machinery relies on it. (if (and (or rescan (not equal)) (not (and (null rescan) rescan-supplied-p))) (queue-rescan stream) (incf (stream-scan-pointer stream) (- (length new-contents) (length old-contents)))) ;; We have to return "the position in the input buffer". We ;; return the insertion position. (stream-insertion-pointer stream)))) (defun present-acceptably-to-string (object type view for-context-type) "Return two values - a string containing the printed representation of `object' when presented with `type' and `view', and an object. The second value will be NIL if the string is \"acceptable\", that is, acceptable as input to the accept method for `type', or `object' if it isn't." (flet ((present-it (acceptably) (present-to-string object type :view view :acceptably acceptably :for-context-type for-context-type))) (let* ((acceptably t) (printed-rep nil)) (handler-case (setq printed-rep (present-it t)) (error () (setq acceptably nil) (setq printed-rep (present-it nil)))) (values printed-rep (if acceptably nil object))))) (defmethod presentation-replace-input ((stream drei-input-editing-mixin) object type view &rest args &key (buffer-start (input-position stream)) rescan query-identifier (for-context-type type) (accept-result t)) (declare (ignore query-identifier buffer-start rescan)) ;; If the input is non-readable and `accept-result' is non-NIL, we ;; insert an `accept-result' object into the buffer, otherwise we ;; just insert the object itself. This is a non-specified ;; convenience extension (so we have to use :allow-other-keys t when ;; using it). (with-keywords-removed (args (:type :view :query-identifier :for-context-type)) (multiple-value-bind (printed-rep accept-object) (present-acceptably-to-string object type view for-context-type) (apply #'replace-input stream (if accept-object (vector (if accept-result (make-instance 'accept-result :object accept-object :result-type type) accept-object)) printed-rep) args)))) ;; The purpose of this method is to ensure that things such as lists ;; should are not completely inserted as literal objects if they have ;; unreadable elements. (defmethod presentation-replace-input ((stream drei-input-editing-mixin) object (type (eql 'expression)) view &rest args &key (buffer-start (input-position stream)) rescan query-identifier (for-context-type type)) (declare (ignore query-identifier rescan for-context-type buffer-start)) ;; Build up an array, `insertion', and use `replace-input' to insert ;; it. (let ((insertion (make-array 10 :adjustable t :fill-pointer 0))) (labels ((insert-object (object) (vector-push-extend object insertion (* (length insertion)))) (insert-objects (objects) (setf insertion (adjust-array insertion (+ (length insertion) (length objects)) :fill-pointer (+ (fill-pointer insertion) (length objects)))) (setf (subseq insertion (- (fill-pointer insertion) (length objects))) objects)) (insert-list-in-stream (list) (insert-object #\() (mapl #'(lambda (cons) (present-object (first cons)) (when (rest cons) (insert-object #\Space))) list) (insert-object #\))) (present-object (object) (multiple-value-bind (printed-rep accept-object) (present-acceptably-to-string object 'expression +textual-view+ 'expression) (if (null accept-object) (insert-objects printed-rep) (typecase object (list (insert-list-in-stream object)) (array (insert-object #\#) (insert-list-in-stream object)) (function (let ((name (nth-value 2 (function-lambda-expression object)))) (insert-objects (or (format nil "#'~A" name) (vector object))))) ;; Okay, we give up, just insert it. (t (insert-object object))))))) (present-object object)) (with-keywords-removed (args (:type :view :query-identifier :for-context-type)) (apply #'replace-input stream insertion args)))) (defmethod presentation-replace-input ((stream drei-input-editing-mixin) object (type (eql 'form)) view &rest args &key (buffer-start (input-position stream)) rescan query-identifier (for-context-type type)) (declare (ignore query-identifier rescan for-context-type buffer-start)) (apply #'presentation-replace-input stream object 'expression view args)) (defvar *drei-input-editing-stream* nil "Used to provide CLIM-specified input-editing-commands with the input-editing-stream. Bound when executing a command.") ;;; Have to reexamine how many of the keyword arguments to ;;; stream-read-gesture should really be passed to the encapsulated ;;; stream. ;;; ;;; OK, now I know :) They should all be passed, except for peek-p. ;;; However, the loop that calls stream-read-gesture on the ;;; encapsulated stream needs to return null if we see a :timeout or ;;; :eof. ;;; ;;; Activation gesture handling has been moved out of ;;; stream-process-gesture to stream-read-gesture and ;;; stream-unread-gesture. This allows a gesture to be read in while ;;; it is not an activation gesture, unread, and then read again as an ;;; activation gesture. This kind of game seems to be needed for ;;; reading forms properly. -- moore (defmethod stream-read-gesture ((stream drei-input-editing-mixin) &rest rest-args &key peek-p &allow-other-keys) (with-keywords-removed (rest-args (:peek-p)) (rescan-if-necessary stream) (with-accessors ((insertion-pointer stream-insertion-pointer) (scan-pointer stream-scan-pointer) (activation-gesture activation-gesture)) stream (let ((buffer (buffer (view (drei-instance stream)))) (last-was-noisy nil)) ; T if last passed gesture is noise-string (loop (loop while (< scan-pointer insertion-pointer) while (< scan-pointer (size buffer)) do (let ((gesture (buffer-object buffer scan-pointer))) ;; Skip noise strings. (cond ((typep gesture 'noise-string) (incf scan-pointer) (setf last-was-noisy t)) ((and (not peek-p) (typep gesture 'accept-result)) (incf scan-pointer) #+(or mcclim building-mcclim) (climi::throw-object-ptype (object gesture) (result-type gesture))) ;; Note that this implies that ;; `stream-read-gesture' may return accept ;; results, which might as well be arbitrary ;; objects to the code calling ;; `stream-read-gesture', since it can't really ;; do anything with them except for asserting ;; that they exist. According to the spec, ;; "accept results are treated as a single ;; gesture", and this kind of behavior is ;; necessary to make sure `stream-read-gesture' ;; doesn't simply claim that there are no more ;; gestures in the input-buffer when the ;; remaining gesture(s) is an accept result. ((typep gesture 'accept-result) (return-from stream-read-gesture gesture)) (t (unless peek-p (incf scan-pointer)) (return-from stream-read-gesture gesture))))) (unless last-was-noisy ; This prevents double-prompting. (setf (stream-rescanning stream) nil)) (when activation-gesture (return-from stream-read-gesture (prog1 activation-gesture (unless peek-p (setf activation-gesture nil))))) ;; In McCLIM, stream-process-gesture is responsible for ;; inserting characters into the buffer, changing the ;; insertion pointer and possibly setting up the ;; activation-gesture slot. (loop with gesture and type do (setf (values gesture type) (apply #'stream-read-gesture (encapsulating-stream-stream stream) rest-args)) when (null gesture) do (return-from stream-read-gesture (values gesture type)) when (stream-process-gesture stream gesture type) do (loop-finish))))))) (defmethod stream-unread-gesture ((stream drei-input-editing-mixin) gesture) (with-accessors ((scan-pointer stream-scan-pointer) (activation-gesture activation-gesture)) stream (when (> scan-pointer 0) (if (and (eql scan-pointer (stream-insertion-pointer stream)) (activation-gesture-p gesture)) (setf activation-gesture gesture) (decf scan-pointer))))) (defun read-gestures-and-act (stream first-gesture type) "Read gestures from `stream' and act upon them as per the semantics of `process-gesture'. This basically means that we read gestures and process a command, returning NIL if we don't consider it an \"editing command\", rescan if it changed something before the scan pointer, and just return the gesture if it inserted stuff after the scan pointer. `First-gesture' must be the gesture that will be read in the first call to `stream-read-gesture' for the stream encapsulated by `stream'. The second return value of this function will be `type' if stuff is inserted after the insertion pointer." (assert (<= (input-position stream) (stream-scan-pointer stream))) (let* ((drei (drei-instance stream)) (buffer (buffer (view drei))) (*command-processor* drei) (was-directly-processing (directly-processing-p drei)) (*drei-input-editing-stream* stream) (old-buffer-contents (buffer-sequence buffer 0 (size buffer)))) (with-bound-drei-special-variables (drei :prompt "M-x ") (update-drei-buffer stream) ;; Since we have an unread gesture in the encapsulated stream, ;; we should use that for further input. *standard-input* is ;; bound back to the minibuffer (maybe) when an actual command ;; is executed. (let ((*standard-input* (encapsulating-stream-stream stream))) ;; Commands are permitted to signal immediate rescans, but ;; we may need to do some stuff first. (unwind-protect (accepting-from-user (drei) ;; We narrow the buffer to the last object before ;; input-position, so the user will not be able to ;; delete arguments prompts or other things. (drei-core:with-narrowed-buffer (drei (loop for index from (1- (input-position stream)) above 0 when (typep (buffer-object buffer index) 'noise-string) return (1+ index) finally (return 0)) t t) (handler-case (process-gestures-or-command drei) (climi::selection-notify (c) (let* ((event (climi::event-of c)) (sheet (event-sheet event)) (port (port sheet))) (when (eq *standard-input* sheet) (insert-sequence (point (view drei)) (clim-backend:get-selection-from-event port event))))) (unbound-gesture-sequence (c) (display-message "~A is unbound" (gesture-name (gestures c)))) (abort-gesture (c) (if (member (abort-gesture-event c) *abort-gestures* :test #'event-matches-gesture-name-p) (signal 'abort-gesture :event (abort-gesture-event c)) (when was-directly-processing (display-message "Aborted"))))))) (update-drei-buffer stream))) (let ((first-mismatch (buffer-array-mismatch buffer old-buffer-contents))) (display-drei drei :redisplay-minibuffer t) (cond ((null first-mismatch) ;; No change actually took place, even though IP may ;; have moved. nil) ((< first-mismatch (stream-scan-pointer stream)) ;; Eek, change before scan pointer - this probably ;; changes the scan, so we'll have to rescan ;; everything. Bummer! (immediate-rescan stream)) (t ;; Something happened, but since we haven't even gotten ;; to scanning that part of the buffer yet, it doesn't ;; really matter. All that matters is that something ;; happened, and that it modified the buffer. This is a ;; somewhat liberal reading of the CLIM spec. (values first-gesture type))))))) (defmethod stream-process-gesture ((stream drei-input-editing-mixin) gesture type) ;; If some other command processor has taken control, we do not want ;; to assume that an activation gesture really is an activation ;; gesture. For example, #\Newline should not cause input activation ;; if isearch is being performed. (when (and (or (activation-gesture-p gesture) (climi::gesture-match gesture *completion-gestures*) (climi::gesture-match gesture *help-gestures*) (climi::gesture-match gesture *possibilities-gestures*)) (directly-processing-p (drei-instance stream))) (end-of-buffer (point (view (drei-instance stream)))) (unless (= (stream-scan-pointer stream) (size (buffer (view (drei-instance stream))))) (queue-rescan stream)) (setf (activation-gesture stream) gesture) (rescan-if-necessary stream) (return-from stream-process-gesture gesture)) (when (proper-gesture-p gesture) (let ((*original-stream* (encapsulating-stream-stream stream))) (unread-gesture gesture :stream (encapsulating-stream-stream stream)))) (read-gestures-and-act stream gesture type)) (defmethod reset-scan-pointer ((stream drei-input-editing-mixin) &optional (scan-pointer 0)) (setf (stream-scan-pointer stream) scan-pointer (stream-rescanning stream) t (input-position stream) (min scan-pointer (input-position stream)))) ;; This has been cribbed from SPLIT-SEQUENCE and lightly modified. (defun split-sequence (delimiter seq &key (count nil) (remove-empty-subseqs nil) (start 0) (end nil) (test nil test-supplied) (test-not nil test-not-supplied) (key nil key-supplied)) "Return a list of subsequences in seq delimited by delimiter. If :remove-empty-subseqs is NIL, empty subsequences will be included in the result; otherwise they will be discarded. All other keywords work analogously to those for CL:SUBSTITUTE. The second return value is an index suitable as an argument to CL:SUBSEQ into the sequence indicating where processing stopped." (let ((len (length seq)) (other-keys (nconc (when test-supplied (list :test test)) (when test-not-supplied (list :test-not test-not)) (when key-supplied (list :key key))))) (unless end (setq end len)) (loop for left = start then (+ right 1) for right = (min (or (apply #'position delimiter seq :start left other-keys) len) end) unless (and (= right left) remove-empty-subseqs) ; empty subseq we don't want if (and count (>= nr-elts count)) ;; We can't take any more. Return now. return (values subseqs left) else collect (subseq seq left right) into subseqs and sum 1 into nr-elts until (>= right end) finally (return (values subseqs right))))) (defmethod input-editor-format ((stream drei-input-editing-mixin) format-string &rest format-args) "Insert a noise string at the insertion-pointer of `stream'." ;; Since everything inserted with this method is noise strings, we ;; do not bother to modify the scan pointer or queue rescans. (let* ((drei (drei-instance stream)) (output (apply #'format nil format-string format-args))) (when (or (stream-rescanning-p stream) (zerop (length output))) (return-from input-editor-format nil)) ;; A noise string really should not contain a newline or Drei will ;; malfunction. Of course, the newlines inserted this way aren't ;; actually noise-strings. FIXME. (loop for (seq . rest) on (split-sequence #\Newline output) when (plusp (length seq)) do (insert-object (point (view drei)) (make-instance 'noise-string :string seq)) unless (null rest) do (insert-object (point (view drei)) #\Newline)))) (defmethod redraw-input-buffer ((stream drei-input-editing-mixin) &optional (start-position 0)) (declare (ignore start-position)) ;; We ignore `start-position', because it would be more work to ;; figure out what to redraw than to just redraw everything. ;; We assume that this function is mostly called from non-Drei-aware ;; code, and thus synchronise the input-editor-array with the Drei ;; buffer before redisplaying. (update-drei-buffer stream) (display-drei (drei-instance stream))) (defmethod erase-input-buffer ((stream drei-input-editing-mixin) &optional (start-position 0)) (declare (ignore start-position)) ;; No-op, just to save older CLIM programs from dying. nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; `Add-input-editor-command' ;;; ;;; The CLIM spec requires us to define a completely unusable function ;;; for mapping gestures to functions in the input editor. Since the ;;; CLIM spec does not define, or even suggest, any kind of ;;; programmatic access to the data structures of the input-editor for ;;; these function, it is utterly impossible to write portable ;;; input-editor functions using this facility. Fortunately, Franz's ;;; user guide saves us. An input-editor-command defined via this ;;; facility takes four arguments: the input-editing stream, the input ;;; buffer (ugh!), the gesture used to invoke the command, and the ;;; accumulated numeric argument. (defun add-input-editor-command (gestures function) "Set up Drei so performing `gestures' will result in the invocation of `function'. Only works for Drei-based input-editing streams. `Function' will be called with four arguments: the input-editing stream, the input buffer, the gesture used to invoke the command, and the accumulated numeric argument." (set-key `(,(lambda (numeric-argument) (funcall function *drei-input-editing-stream* (stream-input-buffer *drei-input-editing-stream*) gestures numeric-argument)) ,*numeric-argument-marker*) 'exclusive-input-editor-table gestures)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Presentation type specialization. ;;; When starting out with reading `command-or-form', we use Lisp ;;; syntax, so things like Structedit works. If it turns out to be a ;;; command, switch back to Fundamental. (define-presentation-method accept :around ((type command-or-form) (stream drei-input-editing-mixin) view &key) (with-drei-options ((drei-instance stream) :syntax "Lisp" :keep-syntax t) (call-next-method))) (define-presentation-method accept :around ((type command) (stream drei-input-editing-mixin) view &key) (with-drei-options ((drei-instance stream) :syntax "Fundamental" :keep-syntax nil) (call-next-method))) (define-presentation-method accept :around ((type expression) (stream drei-input-editing-mixin) view &key) (with-drei-options ((drei-instance stream) :syntax "Lisp" :keep-syntax t) (redraw-input-buffer stream) (call-next-method))) (define-presentation-method accept ((type expression) (stream drei-input-editing-mixin) (view textual-view) &key) (let ((*completion-gestures* nil) (*possibilities-gestures* nil)) (with-delimiter-gestures (nil :override t) (loop named control-loop with start-scan-pointer = (stream-scan-pointer stream) with drei = (drei-instance stream) with syntax = (syntax (view drei)) ;; The input context permits the user to mouse-select displayed ;; Lisp objects and put them into the input buffer as literal ;; objects. for gesture = (with-input-context ('expression :override nil) (object type) (read-gesture :stream stream) (expression (performing-drei-operations (drei :with-undo t :redisplay t) (presentation-replace-input stream object type (view drei) :buffer-start (stream-insertion-pointer stream) :allow-other-keys t :accept-result nil :rescan t)) (rescan-if-necessary stream) nil)) ;; True if `gesture' was freshly read from the user, and not ;; just retrieved from the buffer during a rescan. for freshly-inserted = (and (plusp (stream-scan-pointer stream)) (not (equal (buffer-object (buffer (view drei)) (1- (stream-scan-pointer stream))) gesture))) for form = (drei-lisp-syntax::form-after syntax (input-position stream)) ;; We do not stop until the input is complete and an activation ;; gesture has just been provided. The freshness check is so ;; #\Newline characters in the input will not cause premature ;; activation. until (and (activation-gesture-p gesture) (or (and freshly-inserted (drei-lisp-syntax::form-complete-p form)))) when (and (activation-gesture-p gesture) (null form)) do ;; We have to remove the buffer contents (whitespace, ;; comments or error states, if this happens) or code ;; above us will not believe us when we tell them that the ;; input is empty (delete-buffer-range (buffer (view drei)) start-scan-pointer (- (stream-scan-pointer stream) start-scan-pointer)) (setf (stream-scan-pointer stream) start-scan-pointer) (simple-parse-error "Empty input") ;; We only want to process the gesture if it is fresh, because ;; if it isn't, it has already been processed at some point in ;; the past. when (and (activation-gesture-p gesture) freshly-inserted) do (with-activation-gestures (nil :override t) (stream-process-gesture stream gesture nil)) finally (unread-gesture gesture :stream stream) (let* ((object (handler-case (drei-lisp-syntax:form-to-object syntax form :read t :package *package*) (drei-lisp-syntax:form-conversion-error (e) ;; Move point to the problematic form ;; and signal a rescan. (setf (activation-gesture stream) nil) (handle-drei-condition drei e) (display-drei drei :redisplay-minibuffer t) (immediate-rescan stream)))) (ptype (presentation-type-of object))) (return-from control-loop (values object (if (presentation-subtypep ptype 'expression) ptype 'expression)))))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/buffer.lisp0000644000175000017500000006677111345155772020057 0ustar pdmpdm;;; -*- Mode: Lisp; Package: DREI-BUFFER -*- ;;; (c) copyright 2004-2005 by ;;; Robert Strandh (strandh at labri.fr) ;;; (c) copyright 2004-2005 by ;;; Elliott Johnson (ejohnson at fasl.info) ;;; (c) copyright 2005 by ;;; Matthieu Villeneuve (matthieu.villeneuve at free.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; A not-so-stupid implementation of the buffer protocol. This ;;; implementation serves two purposes: First, so that higher-level ;;; functionality can be built on top of a working implementation of ;;; the buffer protocol, and second, to use as a comparison for ;;; testing a new, better implementation of the buffer protocol. (in-package :drei-buffer) (defclass buffer () () (:documentation "The base class for all buffers. A buffer conceptually contains a large array of arbitrary objects. Lines of objects are separated by newline characters. The last object of the buffer is not necessarily a newline character.")) (defclass standard-buffer (buffer) ((contents :initform (make-instance 'standard-cursorchain) :reader contents)) (:documentation "The standard instantiable class for buffers.")) (defgeneric buffer (mark) (:documentation "Return the buffer that the mark is positioned in.")) (defclass mark () () (:documentation "The base class for all marks.")) (defclass left-sticky-mark (mark) () (:documentation "A subclass of mark. A mark of this type will \"stick\" to the left of an object, i.e. when an object is inserted at this mark, the mark will be positioned to the left of the object.")) (defclass right-sticky-mark (mark) () (:documentation "A subclass of mark. A mark of this type will \"stick\" to the right of an object, i.e. when an object is inserted at this mark, the mark will be positioned to the right of the object.")) (defgeneric offset (mark) (:documentation "Return the offset of the mark into the buffer.")) (defgeneric (setf offset) (new-offset mark) (:documentation "Set the offset of the mark into the buffer. A motion-before-beginning condition is signaled if the offset is less than zero. A motion-after-end condition is signaled if the offset is greater than the size of the buffer.")) (defclass mark-mixin () ((buffer :initarg :buffer :reader buffer :documentation "The buffer that the mark is in.") (cursor :reader cursor)) (:documentation "A mixin class used in the initialization of a mark.")) (defmethod offset ((mark mark-mixin)) (cursor-pos (cursor mark))) (define-condition no-such-offset (simple-error) ((offset :reader condition-offset :initarg :offset)) (:report (lambda (condition stream) (format stream "No such offset: ~a" (condition-offset condition)))) (:documentation "This condition is signaled whenever an attempt is made to access buffer contents that is before the beginning or after the end of the buffer.")) (define-condition offset-before-beginning (no-such-offset) () (:report (lambda (condition stream) (format stream "Offset before beginning: ~a" (condition-offset condition)))) (:documentation "This condition is signaled whenever an attempt is made to access buffer contents that is before the beginning of the buffer.")) (define-condition offset-after-end (no-such-offset) () (:report (lambda (condition stream) (format stream "Offset after end: ~a" (condition-offset condition)))) (:documentation "This condition is signaled whenever an attempt is made to access buffer contents that is after the end of the buffer.")) (define-condition invalid-motion (simple-error) ((offset :reader condition-offset :initarg :offset)) (:report (lambda (condition stream) (format stream "Invalid motion to offset: ~a" (condition-offset condition)))) (:documentation "This condition is signaled whenever an attempt is made to move a mark before the beginning or after the end of the buffer.")) (define-condition motion-before-beginning (invalid-motion) () (:report (lambda (condition stream) (format stream "Motion before beginning: ~a" (condition-offset condition)))) (:documentation "This condition is signaled whenever an attempt is made to move a mark before the beginning of the buffer.")) (define-condition motion-after-end (invalid-motion) () (:report (lambda (condition stream) (format stream "Motion after end: ~a" (condition-offset condition)))) (:documentation "This condition is signaled whenever an attempt is made to move a mark after the end of the buffer.")) (defmethod (setf offset) (new-offset (mark mark-mixin)) (assert (<= 0 new-offset) () (make-condition 'motion-before-beginning :offset new-offset)) (assert (<= new-offset (size (buffer mark))) () (make-condition 'motion-after-end :offset new-offset)) (setf (cursor-pos (cursor mark)) new-offset)) (defgeneric backward-object (mark &optional count) (:documentation "Move the mark backward the number of positions indicated by count. This function could be implemented by a `decf' on the offset of the mark, but many buffer implementations can implement this function much more efficiently in a different way. A `motion-before-beginning' condition is signaled if the resulting offset of the mark is less than zero. A `motion-after-end' condition is signaled if the resulting offset of the mark is greater than the size of the buffer. Returns `mark'.")) (defgeneric forward-object (mark &optional count) (:documentation "Move the mark forward the number of positions indicated by count. This function could be implemented by an `incf' on the offset of the mark, but many buffer implementations can implement this function much more efficiently in a different way. A `motion-before-beginning' condition is signaled if the resulting offset of the mark is less than zero. A `motion-after-end' condition is signaled if the resulting offset of the mark is greater than the size of the buffer. Returns `mark'.")) (defmethod forward-object ((mark mark-mixin) &optional (count 1)) (incf (offset mark) count) t) (defmethod backward-object ((mark mark-mixin) &optional (count 1)) (decf (offset mark) count) t) (defclass standard-left-sticky-mark (left-sticky-mark mark-mixin) () (:documentation "A left-sticky-mark subclass suitable for use in a standard-buffer")) (defclass standard-right-sticky-mark (right-sticky-mark mark-mixin) () (:documentation "A right-sticky-mark subclass suitable for use in a standard-buffer")) (defmethod initialize-instance :after ((mark standard-left-sticky-mark) &rest args &key (offset 0)) "Associates a created mark with the buffer it was created for." (declare (ignore args)) (assert (<= 0 offset) () (make-condition 'motion-before-beginning :offset offset)) (assert (<= offset (size (buffer mark))) () (make-condition 'motion-after-end :offset offset)) (setf (slot-value mark 'cursor) (make-instance 'left-sticky-flexicursor :chain (slot-value (buffer mark) 'contents) :position offset))) (defmethod initialize-instance :after ((mark standard-right-sticky-mark) &rest args &key (offset 0)) "Associates a created mark with the buffer it was created for." (declare (ignore args)) (assert (<= 0 offset) () (make-condition 'motion-before-beginning :offset offset)) (assert (<= offset (size (buffer mark))) () (make-condition 'motion-after-end :offset offset)) (setf (slot-value mark 'cursor) (make-instance 'right-sticky-flexicursor :chain (slot-value (buffer mark) 'contents) :position offset))) (defgeneric make-buffer-mark (buffer &optional offset stick-to) (:documentation "Create a mark with the provided `offset' and stickyness, with the buffer of the mark being `buffer'. Instantiable buffer classes must define a method on this generic function. The default value for `offset' should be 0, and the default value of `stick-to' should be `:left'.")) (defmethod make-buffer-mark ((buffer standard-buffer) &optional (offset 0) (stick-to :left)) (make-instance (ecase stick-to (:left 'standard-left-sticky-mark) (:right 'standard-right-sticky-mark)) :buffer buffer :offset offset)) (defgeneric clone-mark (mark &optional stick-to) (:documentation "Clone a mark. By default (when stick-to is NIL) the same type of mark is returned. Otherwise stick-to is either :left or :right indicating whether a left-sticky or a right-sticky mark should be created.")) (defmethod clone-mark ((mark standard-left-sticky-mark) &optional stick-to) (cond ((or (null stick-to) (eq stick-to :left)) (make-instance 'standard-left-sticky-mark :buffer (buffer mark) :offset (offset mark))) ((eq stick-to :right) (make-instance 'standard-right-sticky-mark :buffer (buffer mark) :offset (offset mark))) (t (error "invalid value for stick-to")))) (defmethod clone-mark ((mark standard-right-sticky-mark) &optional stick-to) (cond ((or (null stick-to) (eq stick-to :right)) (make-instance 'standard-right-sticky-mark :buffer (buffer mark) :offset (offset mark))) ((eq stick-to :left) (make-instance 'standard-left-sticky-mark :buffer (buffer mark) :offset (offset mark))) (t (error "invalid value for stick-to")))) (defgeneric size (buffer) (:documentation "Return the number of objects in the buffer.")) (defmethod size ((buffer standard-buffer)) (nb-elements (contents buffer))) (defgeneric number-of-lines (buffer) (:documentation "Return the number of lines of the buffer, or really the number of newline characters.")) (defmethod number-of-lines ((buffer standard-buffer)) (loop for offset from 0 below (size buffer) count (eql (buffer-object buffer offset) #\Newline))) (defgeneric mark< (mark1 mark2) (:documentation "Return T if the offset of `mark1' is strictly less than that of `mark2'. An error is signaled if the two marks are not positioned in the same buffer. It is acceptable to pass an offset in place of one of the marks.")) (defmethod mark< ((mark1 mark-mixin) (mark2 mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) (< (offset mark1) (offset mark2))) (defmethod mark< ((mark1 mark-mixin) (mark2 integer)) (< (offset mark1) mark2)) (defmethod mark< ((mark1 integer) (mark2 mark-mixin)) (< mark1 (offset mark2))) (defgeneric mark<= (mark1 mark2) (:documentation "Return T if the offset of `mark1' is less than or equal to that of `mark2'. An error is signaled if the two marks are not positioned in the same buffer. It is acceptable to pass an offset in place of one of the marks.")) (defmethod mark<= ((mark1 mark-mixin) (mark2 mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) (<= (offset mark1) (offset mark2))) (defmethod mark<= ((mark1 mark-mixin) (mark2 integer)) (<= (offset mark1) mark2)) (defmethod mark<= ((mark1 integer) (mark2 mark-mixin)) (<= mark1 (offset mark2))) (defgeneric mark= (mark1 mark2) (:documentation "Return T if the offset of `mark1' is equal to that of `mark2'. An error is signaled if the two marks are not positioned in the same buffer. It is acceptable to pass an offset in place of one of the marks.")) (defmethod mark= ((mark1 mark-mixin) (mark2 mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) (= (offset mark1) (offset mark2))) (defmethod mark= ((mark1 mark-mixin) (mark2 integer)) (= (offset mark1) mark2)) (defmethod mark= ((mark1 integer) (mark2 mark-mixin)) (= mark1 (offset mark2))) (defgeneric mark> (mark1 mark2) (:documentation "Return T if the offset of `mark1' is strictly greater than that of `mark2'. An error is signaled if the two marks are not positioned in the same buffer. It is acceptable to pass an offset in place of one of the marks.")) (defmethod mark> ((mark1 mark-mixin) (mark2 mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) (> (offset mark1) (offset mark2))) (defmethod mark> ((mark1 mark-mixin) (mark2 integer)) (> (offset mark1) mark2)) (defmethod mark> ((mark1 integer) (mark2 mark-mixin)) (> mark1 (offset mark2))) (defgeneric mark>= (mark1 mark2) (:documentation "Return T if the offset of `mark1' is greater than or equal to that of `mark2'. An error is signaled if the two marks are not positioned in the same buffer. It is acceptable to pass an offset in place of one of the marks.")) (defmethod mark>= ((mark1 mark-mixin) (mark2 mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) (>= (offset mark1) (offset mark2))) (defmethod mark>= ((mark1 mark-mixin) (mark2 integer)) (>= (offset mark1) mark2)) (defmethod mark>= ((mark1 integer) (mark2 mark-mixin)) (>= mark1 (offset mark2))) (defgeneric beginning-of-buffer (mark) (:documentation "Move the mark to the beginning of the buffer. This is equivalent to `(setf (offset mark) 0)', but returns mark.")) ;; Easy way to make sure mark is always returned. (defmethod beginning-of-buffer :around (mark) (call-next-method) mark) (defmethod beginning-of-buffer ((mark mark-mixin)) (setf (offset mark) 0)) (defgeneric end-of-buffer (mark) (:documentation "Move the mark to the end of the buffer and return mark.")) (defmethod end-of-buffer :around (mark) (call-next-method) mark) (defmethod end-of-buffer ((mark mark-mixin)) (setf (offset mark) (size (buffer mark)))) (defgeneric beginning-of-buffer-p (mark) (:documentation "Return T if the mark is at the beginning of the buffer, nil otherwise.")) (defmethod beginning-of-buffer-p ((mark mark-mixin)) (zerop (offset mark))) (defgeneric end-of-buffer-p (mark) (:documentation "Return T if the mark is at the end of the buffer, NIL otherwise.")) (defmethod end-of-buffer-p ((mark mark-mixin)) (= (offset mark) (size (buffer mark)))) (defgeneric beginning-of-line-p (mark) (:documentation "Return T if the mark is at the beginning of the line (i.e., if the character preceding the mark is a newline character or if the mark is at the beginning of the buffer), NIL otherwise.")) (defmethod beginning-of-line-p ((mark mark-mixin)) (or (beginning-of-buffer-p mark) (eql (object-before mark) #\Newline))) (defgeneric end-of-line-p (mark) (:documentation "Return T if the mark is at the end of the line (i.e., if the character following the mark is a newline character, or if the mark is at the end of the buffer), NIL otherwise.")) (defmethod end-of-line-p ((mark mark-mixin)) (or (end-of-buffer-p mark) (eql (object-after mark) #\Newline))) (defgeneric beginning-of-line (mark) (:documentation "Move the mark to the beginning of the line. The mark will be positioned either immediately after the closest receding newline character, or at the beginning of the buffer if no preceding newline character exists. Returns `mark'.")) (defmethod beginning-of-line :around (mark) (call-next-method) mark) (defmethod beginning-of-line ((mark mark-mixin)) (loop until (beginning-of-line-p mark) do (backward-object mark))) (defgeneric end-of-line (mark) (:documentation "Move the mark to the end of the line. The mark will be positioned either immediately before the closest following newline character, or at the end of the buffer if no following newline character exists. Returns `mark'.")) (defmethod end-of-line :around (mark) (call-next-method) mark) (defmethod end-of-line ((mark mark-mixin)) (let* ((offset (offset mark)) (buffer (buffer mark)) (size (size buffer))) (loop until (or (= offset size) (eql (buffer-object buffer offset) #\Newline)) do (incf offset)) (setf (offset mark) offset))) (defgeneric buffer-line-number (buffer offset) (:documentation "Return the line number of the offset. Lines are numbered from zero.")) (defmethod buffer-line-number ((buffer standard-buffer) (offset integer)) (loop for i from 0 below offset count (eql (buffer-object buffer i) #\Newline))) (defgeneric buffer-column-number (buffer offset) (:documentation "Return the column number of the offset. The column number of an offset is the number of objects between it and the preceding newline, or between it and the beginning of the buffer if the offset is on the first line of the buffer.")) (defmethod buffer-column-number ((buffer standard-buffer) (offset integer)) (loop for i downfrom offset while (> i 0) until (eql (buffer-object buffer (1- i)) #\Newline) count t)) (defgeneric line-number (mark) (:documentation "Return the line number of the mark. Lines are numbered from zero.")) (defmethod line-number ((mark mark-mixin)) (buffer-line-number (buffer mark) (offset mark))) (defgeneric column-number (mark) (:documentation "Return the column number of the mark. The column number of a mark is the number of objects between it and the preceding newline, or between it and the beginning of the buffer if the mark is on the first line of the buffer.")) (defmethod column-number ((mark mark-mixin)) (buffer-column-number (buffer mark) (offset mark))) (defgeneric (setf column-number) (number mark) (:documentation "Set the column number of the mark, return the column number. Note that if `number' is larger than the length of the line `mark' is in, `mark' will be moved to end of line.")) (defmethod (setf column-number) (number mark) (beginning-of-line mark) (loop repeat number until (end-of-line-p mark) do (incf (offset mark)) finally (return (column-number mark)))) (defgeneric insert-buffer-object (buffer offset object) (:documentation "Insert the object at the offset in the buffer. Any left-sticky marks that are placed at the offset will remain positioned before the inserted object. Any right-sticky marks that are placed at the offset will be positioned after the inserted object.")) (defmethod insert-buffer-object ((buffer standard-buffer) offset object) (assert (<= 0 offset) () (make-condition 'offset-before-beginning :offset offset)) (assert (<= offset (size buffer)) () (make-condition 'offset-after-end :offset offset)) (insert* (contents buffer) offset object)) (defgeneric insert-buffer-sequence (buffer offset sequence) (:documentation "Like calling insert-buffer-object on each of the objects in the sequence.")) (defmethod insert-buffer-sequence ((buffer standard-buffer) offset sequence) (assert (<= 0 offset) () (make-condition 'offset-before-beginning :offset offset)) (assert (<= offset (size buffer)) () (make-condition 'offset-after-end :offset offset)) (insert-vector* (contents buffer) offset sequence)) (defgeneric insert-object (mark object) (:documentation "Insert the object at the mark. This function simply calls insert-buffer-object with the buffer and the position of the mark.")) (defmethod insert-object ((mark mark-mixin) object) (insert-buffer-object (buffer mark) (offset mark) object)) (defgeneric insert-sequence (mark sequence) (:documentation "Insert the objects in the sequence at the mark. This function simply calls insert-buffer-sequence with the buffer and the position of the mark.")) (defmethod insert-sequence ((mark mark-mixin) sequence) (insert-buffer-sequence (buffer mark) (offset mark) sequence)) (defgeneric delete-buffer-range (buffer offset n) (:documentation "Delete n objects from the buffer starting at the offset. If `offset' is negative or `offset'+`n' is greater than the size of the buffer, a `no-such-offset' condition is signaled.")) (defmethod delete-buffer-range ((buffer standard-buffer) offset n) (assert (<= 0 offset) () (make-condition 'offset-before-beginning :offset offset)) (assert (<= offset (size buffer)) () (make-condition 'offset-after-end :offset offset)) (assert (<= (+ offset n) (size buffer)) () (make-condition 'offset-after-end :offset (+ offset n))) (delete-elements* (contents buffer) offset n)) (defgeneric delete-range (mark &optional n) (:documentation "Delete `n' objects after `(if n > 0)' or before `(if n < 0)' the mark. This function eventually calls delete-buffer-range, provided that `n' is not zero.")) (defmethod delete-range ((mark mark-mixin) &optional (n 1)) (cond ((plusp n) (delete-buffer-range (buffer mark) (offset mark) n)) ((minusp n) (delete-buffer-range (buffer mark) (+ (offset mark) n) (- n))) (t nil))) (defgeneric delete-region (mark1 mark2) (:documentation "Delete the objects in the buffer that are between `mark1' and `mark2'. An error is signaled if the two marks are positioned in different buffers. It is acceptable to pass an offset in place of one of the marks. This function calls `delete-buffer-range' with the appropriate arguments.")) (defmethod delete-region ((mark1 mark-mixin) (mark2 mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) (let ((offset1 (offset mark1)) (offset2 (offset mark2))) (when (> offset1 offset2) (rotatef offset1 offset2)) (delete-buffer-range (buffer mark1) offset1 (- offset2 offset1)))) (defmethod delete-region ((mark1 mark-mixin) offset2) (let ((offset1 (offset mark1))) (when (> offset1 offset2) (rotatef offset1 offset2)) (delete-buffer-range (buffer mark1) offset1 (- offset2 offset1)))) (defmethod delete-region (offset1 (mark2 mark-mixin)) (let ((offset2 (offset mark2))) (when (> offset1 offset2) (rotatef offset1 offset2)) (delete-buffer-range (buffer mark2) offset1 (- offset2 offset1)))) (defgeneric buffer-object (buffer offset) (:documentation "Return the object at the offset in the buffer. The first object has offset 0. If `offset' is less than zero or greater than or equal to the size of the buffer, a `no-such-offset' condition is signaled.")) (defmethod buffer-object ((buffer standard-buffer) offset) (assert (<= 0 offset) () (make-condition 'offset-before-beginning :offset offset)) (assert (<= offset (1- (size buffer))) () (make-condition 'offset-after-end :offset offset)) (element* (contents buffer) offset)) (defgeneric (setf buffer-object) (object buffer offset) (:documentation "Set the object at the offset in the buffer. The first object has offset 0. If `offset' is less than zero or greater than or equal to the size of the buffer, a `no-such-offset' condition is signaled.")) (defmethod (setf buffer-object) (object (buffer standard-buffer) offset) (assert (<= 0 offset) () (make-condition 'offset-before-beginning :offset offset)) (assert (<= offset (1- (size buffer))) () (make-condition 'offset-after-end :offset offset)) (setf (element* (contents buffer) offset) object)) (defgeneric buffer-sequence (buffer offset1 offset2) (:documentation "Return the contents of the buffer starting at `offset1' and ending at `offset2-1' as a sequence. If either of the offsets is less than zero or greater than or equal to the size of the buffer, a `no-such-offset' condition is signaled. If `offset2' is smaller than or equal to `offset1', an empty sequence will be returned.")) (defmethod buffer-sequence ((buffer standard-buffer) offset1 offset2) (assert (<= 0 offset1) () (make-condition 'offset-before-beginning :offset offset1)) (assert (<= offset1 (size buffer)) () (make-condition 'offset-after-end :offset offset1)) (assert (<= 0 offset2) () (make-condition 'offset-before-beginning :offset offset2)) (assert (<= offset2 (size buffer)) () (make-condition 'offset-after-end :offset offset2)) (if (< offset1 offset2) (loop with result = (make-array (- offset2 offset1)) for offset from offset1 below offset2 for i upfrom 0 do (setf (aref result i) (buffer-object buffer offset)) finally (return result)) (make-array 0))) (defun buffer-substring (buffer start end) "Return a string of the contents of buffer from `start' to `end', which must be offsets." (coerce (buffer-sequence buffer start end) 'string)) (defgeneric object-before (mark) (:documentation "Return the object that is immediately before the mark. If mark is at the beginning of the buffer, a `no-such-offset' condition is signaled. If the mark is at the beginning of a line, but not at the beginning of the buffer, a newline character is returned.")) (defmethod object-before ((mark mark-mixin)) (buffer-object (buffer mark) (1- (offset mark)))) (defgeneric object-after (mark) (:documentation "Return the object that is immediately after the mark. If mark is at the end of the buffer, a `no-such-offset' condition is signaled. If the mark is at the end of a line, but not at the end of the buffer, a newline character is returned.")) (defmethod object-after ((mark mark-mixin)) (buffer-object (buffer mark) (offset mark))) (defgeneric region-to-sequence (mark1 mark2) (:documentation "Return a freshly allocated sequence of the objects after `mark1' and before `mark2'. An error is signaled if the two marks are positioned in different buffers. If mark1 is positioned at an offset equal to or greater than that of `mark2', an empty sequence is returned. It is acceptable to pass an offset in place of one of the marks. This function calls `buffer-sequence' with the appropriate arguments.")) (defmethod region-to-sequence ((mark1 mark-mixin) (mark2 mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) (let ((offset1 (offset mark1)) (offset2 (offset mark2))) (when (> offset1 offset2) (rotatef offset1 offset2)) (buffer-sequence (buffer mark1) offset1 offset2))) (defmethod region-to-sequence ((offset1 integer) (mark2 mark-mixin)) (let ((offset2 (offset mark2))) (when (> offset1 offset2) (rotatef offset1 offset2)) (buffer-sequence (buffer mark2) offset1 offset2))) (defmethod region-to-sequence ((mark1 mark-mixin) (offset2 integer)) (let ((offset1 (offset mark1))) (when (> offset1 offset2) (rotatef offset1 offset2)) (buffer-sequence (buffer mark1) offset1 offset2))) (defun region-to-string (start end) "Return a string of the contents of the buffer associated with the marks, from `start' to `end', of which at least one must be a mark object." (coerce (region-to-sequence start end) 'string)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Buffer modification protocol (defclass observable-buffer-mixin (observable-mixin) () (:documentation "A mixin class that will make a subclass buffer notify observers when it is changed through the buffer protocol. When an observer of the buffer is notified of changes, the provided data will be a cons of two values, offsets into the buffer denoting the region that has been modified.")) (defmethod insert-buffer-object :after ((buffer observable-buffer-mixin) offset object) (notify-observers buffer (constantly (cons offset (1+ offset))))) (defmethod insert-buffer-sequence :after ((buffer observable-buffer-mixin) offset sequence) (notify-observers buffer (constantly (cons offset (+ offset (length sequence)))))) (defmethod delete-buffer-range :after ((buffer observable-buffer-mixin) offset n) (notify-observers buffer (constantly (cons offset offset)))) (defmethod (setf buffer-object) :after (object (buffer observable-buffer-mixin) offset) (notify-observers buffer (constantly (cons offset (1+ offset))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Print method for ease of debugging (defmethod print-object ((object buffer) stream) (print-unreadable-object (object stream :type t :identity t) (format stream "size:~A" (size object)))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/abbrev.lisp0000640000175000017500000001006610741375212020015 0ustar pdmpdm;;; -*- Mode: Lisp; Package: DREI-ABBREV -*- ;;; (c) copyright 2004 by ;;; Robert Strandh (strandh@labri.fr) ;;; (c) copyright 2004 by ;;; Elliott Johnson (ejohnson@fasl.info) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Abbrevs are expanded by a call to the generic function ;;; expand-abbrev. That function takes a word to be expanded and an ;;; instance of the class abbrev-expander and returns either NIL ;;; (meaning there was no expansion for this word) or another string ;;; which is the expansion of the word. ;;; ;;; We define a particular sublcass of abbrev-expander which just ;;; contains a dictionary (an alist) of pairs and ;;; which does case-mangling on the expansion according to the case of ;;; the word. Client code would typically create other subclasses of ;;; abbrev-expander that can do more sophisticated abbrev expansion. (in-package :drei-abbrev) ;;; the protocol class for all abbrev expanders. (defclass abbrev-expander () () (:documentation "The protocol class for all abbreviation expanders")) (defgeneric expand-abbrev (word abbrev-expander) (:documentation "Given a word and an abbrev expander, return the expanded abbrev, or NIL if no expansion exists")) (defclass dictionary-abbrev-expander (abbrev-expander) ((dictionary :initform '() :accessor dictionary :documentation "A dictionary of abbreviations.")) (:documentation "A protocol class specified for dictionary abbreviation expanders.")) (defgeneric add-abbrev (word expansion dictionary-abbrev-expander) (:documentation "Add an abbrev expansion to a dictionary abbrev expander")) (defmethod add-abbrev (word expansion (expander dictionary-abbrev-expander)) (push (cons word expansion) (dictionary expander))) (defun string-upper-case-p (string) "A predicate testing if each character of a string is uppercase." (every #'upper-case-p string)) (defmethod expand-abbrev (word (expander dictionary-abbrev-expander)) "Expands an abbrevated word by attempting to assocate it with a member of an abbreviation dictionary. If such an association is found, an uppercase, expanded version of the abbrevation is returned." (let ((expansion (cdr (assoc word (dictionary expander) :test #'string-equal)))) (when expansion (cond ((string-upper-case-p word) (string-upcase expansion)) ((upper-case-p (aref word 0)) (string-capitalize expansion)) (t expansion))))) (defun possibly-expand-abbrev (mark) "Replaces a bit of abbreviated text with its fully expanded counterpart." (let ((buffer (buffer mark))) (when (and (not (beginning-of-buffer-p mark)) (constituentp (object-before mark))) (let ((offset1 (offset mark)) (offset2 (offset mark))) (loop until (zerop offset1) while (constituentp (buffer-object buffer (1- offset1))) do (decf offset1)) (let ((expansion (expand-abbrev (coerce (buffer-sequence buffer offset1 offset2) 'string) (abbrev-expander (implementation buffer))))) (when expansion (delete-buffer-range buffer offset1 (- offset2 offset1)) (insert-buffer-sequence buffer offset1 expansion))))))) (defclass abbrev-mixin () ((expander :initform (make-instance 'dictionary-abbrev-expander) :initarg :expander :accessor abbrev-expander)) (:documentation "A mixin class which adds abbreviation expansion facilities to a buffer via the accessor \"abbrev-expander\"")) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/targets.lisp0000644000175000017500000001766711345155772020257 0ustar pdmpdm;;; -*- Mode: Lisp; Package: DREI-CORE -*- ;;; (c) copyright 2007 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Facilities and protocols for iterating through view objects, the ;;; point being that the view may be magically exchanged for some ;;; other view, permitting easy iteration through multiple views as a ;;; single sequence. This is meant to support Climacs' Group-facility, ;;; I'm not sure what else it could be used for. (in-package :drei-core) (defclass target-specification () ((%drei :reader drei-instance-of :initarg :drei-instance :initform (error "A Drei instance must be provided for a target specification"))) (:documentation "The base class for target specifications, objects that permit browsing through targets for various operations. `Target-specification' instances start off deactivated.")) (defgeneric activate-target-specification (target-specification) (:documentation "Cause the Drei instance associated with `target-specification' to switch to the \"current\" target of `target-specification', whatever that is. It is illegal to call any other target function on a `target-specification' object until it has been activated by this function, and it is illegal to call this function on an already activated `target-specification' instance.")) (defgeneric deactivate-target-specification (target-specification) (:documentation "Deactivate the `target-specification' instance, restoring whatever state the call to `activate-target-specification' modified. It is illegal to call `deactivate-target-specification' on a deactivated `target-specification' instance.")) (defgeneric subsequent-targets-p (target-specification) (:documentation "Return true if there are more targets to act on, that is, if the `next-target' function would not signal an error.")) (defgeneric preceding-targets-p (target-specification) (:documentation "Return true if there are targets to act on in sequence before the current target, that is, if the `previous-target' function would not signal an error.")) (defgeneric next-target (target-specification) (:documentation "Change to the next target specified by the target specification. Signals an error of type `no-more-targets' if `subsequent-targets-p' is false.")) (defgeneric previous-target (target-specification) (:documentation "Change to the previous target specified by the target specification. Signals an error of type `no-more-targets' if `preceding-targets-p' is false.")) (define-condition no-more-targets (simple-error) () (:report (lambda (condition stream) (declare (ignore condition)) (format stream "No more targets available for iteration"))) (:documentation "Signal that there are no more targets available for iteration, either forward or backwards in the sequence of targets.")) (defclass current-view-target (target-specification) ((%view :accessor view)) (:documentation "A target specification class specifying just one view, the current view of the Drei instance at the time of object creation. This is mostly used as a dummy target specification to make target-aware commands behave \"normally\" when no particular targets are specified.")) (defmethod initialize-instance :after ((obj current-view-target) &rest initargs) (declare (ignore initargs)) (setf (view obj) (view (drei-instance obj)))) (defmethod activate-target-specification ((spec current-view-target)) ;; Noop. ) (defmethod deactivate-target-specification ((spec current-view-target)) ;; Noop. ) (defmethod subsequent-targets-p ((spec current-view-target)) nil) (defmethod preceding-targets-p ((spec current-view-target)) nil) (defmethod next-target ((spec current-view-target)) (error 'no-more-targets)) (defmethod previous-target ((spec current-view-target)) (error 'no-more-targets)) (defvar *default-target-creator* #'(lambda (drei) (make-instance 'current-view-target :drei-instance drei)) "A function of a single argument, the Drei instance, that creates a target specification object (or subtype thereof) that should be used for aquiring targets.") (defclass view-list-target-specification (target-specification) ((%views :accessor views :initform '() :initarg :views) (%view-count :accessor view-count) (%current-view-index :initform 0 :accessor current-view-index) (%original-view :accessor original-view :initform nil) (%original-offset :accessor original-offset :initform nil)) (:documentation "A target specification that has a provided list of existing views as its target.")) (defun reorder-views (list-spec) "Reorder the views of a `view-list-target-specification' object to be more useful. If the current view is in the list of views, it is moved to the head of the list, since it makes sense to make it the starting point." (unless (eq (view (drei-instance list-spec)) (first (views list-spec))) (let ((filtered-views (remove (view (drei-instance list-spec)) (views list-spec)))) (when (/= (length filtered-views) (view-count list-spec)) (setf (views list-spec) (cons (view (drei-instance list-spec)) filtered-views)))))) (defmethod initialize-instance :after ((obj view-list-target-specification) &rest initargs) (declare (ignore initargs)) (setf (view-count obj) (length (views obj))) (reorder-views obj)) (defmethod (setf views) :after (new-views (obj view-list-target-specification)) (setf (view-count obj) (length (views obj))) (reorder-views obj)) (defmethod activate-target-specification ((spec view-list-target-specification)) (unless (or (null (views spec)) (eq (view (drei-instance spec)) (first (views spec)))) (setf (original-view spec) (view (drei-instance spec)) (original-offset spec) (offset (point (view (drei-instance spec)))) (view (drei-instance spec)) (first (views spec))) (beginning-of-buffer (point (view (drei-instance spec)))))) (defmethod deactivate-target-specification ((spec view-list-target-specification)) (when (original-view spec) (setf (view (drei-instance spec)) (original-view spec) (offset (point (view (drei-instance spec)))) (original-offset spec)))) (defmethod subsequent-targets-p ((spec view-list-target-specification)) (/= (1+ (current-view-index spec)) (view-count spec))) (defmethod preceding-targets-p ((spec view-list-target-specification)) (plusp (current-view-index spec))) (defmethod next-target ((spec view-list-target-specification)) (if (subsequent-targets-p spec) (progn (setf (view (drei-instance spec)) (elt (views spec) (incf (current-view-index spec))) (active (view (drei-instance spec))) t) (beginning-of-buffer (point (view (drei-instance spec))))) (error 'no-more-targets))) (defmethod previous-target ((spec view-list-target-specification)) (if (preceding-targets-p spec) (progn (setf (view (drei-instance spec)) (elt (views spec) (decf (current-view-index spec)))) (end-of-buffer (point (view (drei-instance spec)))) (active (view (drei-instance spec))) t) (error 'no-more-targets))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/drei-redisplay.lisp0000644000175000017500000017065711345155772021522 0ustar pdmpdm;;; -*- Mode: Lisp; Package: DREI -*- ;;; (c) copyright 2005 by ;;; Robert Strandh (strandh@labri.fr) ;;; (c) copyright 2005 by ;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr) ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Declarations and definitions of the generic functions and helper ;;; utilities needed for the Drei redisplay engine (in-package :drei) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Display of Drei instances. ;;; ;;; The basic Drei redisplay functions: (defgeneric display-drei-view-contents (stream view) (:documentation "The purpose of this function is to display the contents of a Drei view to some output surface. `Stream' is the CLIM output stream that redisplay should be performed on, `view' is the Drei view instance that is being displayed. Methods defined for this generic function can draw whatever they want, but they should not assume that they are the only user of `stream', unless the `stream' argument has been specialized to some application-specific pane class that can guarantee this. For example, when accepting multiple values using the `accepting-values' macro, several Drei instances will be displayed simultaneously on the same stream. It is permitted to only specialise `stream' on `clim-stream-pane' and not `extended-output-stream'. When writing methods for this function, be aware that you cannot assume that the buffer will contain only characters, and that any subsequence of the buffer is coercable to a string. Drei buffers can contain arbitrary objects, and redisplay methods are required to handle this (though they are not required to handle it nicely, they can just ignore the object, or display the `princ'ed representation.)") (:method :around ((stream extended-output-stream) (view drei-view)) (letf (((stream-default-view stream) view)) (call-next-method)))) (defgeneric display-drei-view-cursor (stream view cursor) (:documentation "The purpose of this function is to display a visible indication of a cursor of a Drei view to some output surface. `Stream' is the CLIM output stream that drawing should be performed on, `view' is the Drei view object that is being redisplayed, `cursor' is the cursor object to be displayed (a subclass of `drei-cursor') and `syntax' is the syntax object of `view'. Methods on this generic function can draw whatever they want, but they should not assume that they are the only user of `stream', unless the `stream' argument has been specialized to some application-specific pane class that can guarantee this. It is permitted to only specialise `stream' on `clim-stream-pane' and not `extended-output-stream'. It is recommended to use the function `offset-to-screen-position' to determine where to draw the visual representation for the cursor. It is also recommended to use the ink specified by `cursor' to perform the drawing, if applicable. This method will only be called by the Drei redisplay engine when the cursor is active and the buffer position it refers to is on display - therefore, `offset-to-screen-position' is *guaranteed* to not return NIL or T.") (:method :around ((stream extended-output-stream) (view drei-view) (cursor drei-cursor)) (when (visible-p cursor) (letf (((stream-default-view stream) view)) (call-next-method))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; The standard redisplay implementation for buffer views. (defstruct face "A face is a description of how to draw (primarily) text, it consists of an ink (a colour) and a text style. The text style may be incomplete, in which case it is merged with the default text style whenever it needs to be used." (ink +foreground-ink+) (style nil)) (defconstant +default-stroke-drawer-dispatcher+ #'(lambda (stream view stroke cursor-x cursor-y default-drawing-fn draw) (funcall default-drawing-fn stream view stroke cursor-x cursor-y draw)) "A simple function of seven arguments that simply calls the first argument as a function with the remaining sex arguments. Used as the default drawing-function of `drawing-options' objects.") (defstruct drawing-options "A set of options for how to display a stroke." (face (make-face)) (function +default-stroke-drawer-dispatcher+)) (defun drawing-options-equal (o1 o2) "Return true if `o1' and `o2' are equal, that is, they specify the same options. Does not take the drawing-function into account due to the halting problem (and also, for more practical reasons), with the exception that no `drawing-options' object with a non-`stroke-drawing-fn' drawing function is equivalent to a `drawing-options' with a `stroke-drawing-fn' drawing function." (let ((f1 (drawing-options-face o1)) (f2 (drawing-options-face o2))) (and (equal (face-ink f1) (face-ink f2)) (equal (face-style f1) (face-style f2)) (or (not (eq (drawing-options-function o1) +default-stroke-drawer-dispatcher+)) (eq (drawing-options-function o2) +default-stroke-drawer-dispatcher+)) (or (not (eq (drawing-options-function o2) +default-stroke-drawer-dispatcher+)) (eq (drawing-options-function o1) +default-stroke-drawer-dispatcher+))))) (defvar +default-drawing-options+ (make-drawing-options) "The default set of drawing options used for strokes when nothing else has been specified, or when the default is good enough. Under these options, the region will be printed as a string with the default foreground color.") (defstruct (dimensions :conc-name) "A simple mutable rectangle structure. The coordinates should be absolute coordinates in the coordinate system of a sheet. A special `center' slot is also provided to enable the recording of what might be considered a *logical* centre of the dimensions on the vertical axis. `Center' should be relative to `y1'." (x1 0) (y1 0) (x2 0) (y2 0) (center 0)) (defun dimensions-height (dimensions) "Return the width of the provided `dimensions' object." (- (y2 dimensions) (y1 dimensions))) (defun dimensions-width (dimensions) "Return the width of the provided `dimensions' object." (- (x2 dimensions) (x1 dimensions))) (defun coordinates-intersects-dimensions (dimensions x1 y1 x2 y2) "Return true if the rectangle defined by (x1, y1), (x2, y2) intersects with the rectangle defined by `dimensions'." (and (or (<= x1 (x1 dimensions) x2) (<= x1 (x2 dimensions) x2) (<= (x1 dimensions) x1 (x2 dimensions)) (<= (x1 dimensions) x2 (x2 dimensions))) (or (<= y1 (y1 dimensions) y2) (<= y1 (y2 dimensions) y2) (<= (y1 dimensions) y1 (y2 dimensions)) (<= (y1 dimensions) y2 (y2 dimensions))))) (defstruct (displayed-stroke (:conc-name stroke-)) "A stroke is a description of how a buffer region (`start-offset', `end-offset') is displayed on the screen. If `dirty' is true, something has obscured or scribbled over the part of the screen area taken up by the stroke. If `modified' is true, this stroke object might output something different than the last time it was redisplayed, and should thus update any caches or similar. When `modified' is set, `dirty' probably also should be set. `widths' is an array of cumulative screen-resolution widths of the `parts', being a run of characters or a non-graphic character: see ANALYSE-STROKE-STRING." (start-offset) (end-offset) (drawing-options +default-drawing-options+) (dirty t) (modified t) (dimensions (make-dimensions)) (widths) (parts)) (defun stroke-at-end-of-line (buffer stroke) "Return true if the end offset of `stroke' is at the end of a line in `buffer'. Otherwise, return nil. The end offset of `stroke' must be a valid offset for `buffer' or an error will be signalled." (offset-end-of-line-p buffer (stroke-end-offset stroke))) (defstruct (displayed-line (:conc-name line-)) "A line on display. A line delimits a buffer region (always bounded by newline objects or border beginning/end) and contains strokes. `Stroke-count' tells how many of the stroke objects in `stroke' are actually live, and how many are old, stale objects to prevent the need for consing if new strokes are added to the line." (start-offset 0) (end-offset) (dimensions (make-dimensions)) (strokes (make-array 0 :adjustable t)) (stroke-count 0)) (defgeneric pump-state-for-offset (view offset) (:documentation "Return a pump state that will enable pumping strokes from `offset' in the buffer of `view' (via `stroke-pump'). The pump state is not guaranteed to be valid past the next call to `stroke-pump' or `synchronize-view'. The results are undefined if `offset' is not at the beginning of a line.") (:method ((view drei-syntax-view) (offset integer)) (pump-state-for-offset-with-syntax view (syntax view) offset))) (defgeneric stroke-pump (view stroke pump-state) (:documentation "Put stroke information in `stroke', returns new pump-state. `Pump-state' must either be the result of a call to `pump-state-for-offset' or be the return value of an earlier call to `stroke-pump'. A pump state is not guaranteed to be valid past the next call to `stroke-pump' or `synchronize-view'. It is permissible for `pump-state' to be destructively modified by this function.") (:method ((view drei-syntax-view) stroke pump-state) (stroke-pump-with-syntax view (syntax view) stroke pump-state))) (defun clear-rectangle* (stream x1 y1 x2 y2) "Draw on `stream' from (x1,y1) to (x2,y2) with the background ink for the stream." (draw-rectangle* stream x1 y1 x2 y2 :ink +background-ink+)) (defun invalidate-stroke (stroke &key modified cleared) "Invalidate `stroke' by setting its dirty-bit to true. If `modified' or `cleared' is true, also set the modified-bit to true. If `cleared' is true, inform the stroke that its previous output has been cleared by someone, and that it does not need to clear it itself during its next redisplay." (setf (stroke-dirty stroke) t (stroke-modified stroke) (or (stroke-modified stroke) modified cleared)) (when cleared (setf (x1 (stroke-dimensions stroke)) 0 (y1 (stroke-dimensions stroke)) 0 (x2 (stroke-dimensions stroke)) 0 (y2 (stroke-dimensions stroke)) 0))) (defun invalidate-line-strokes (line &key modified cleared) "Invalidate all the strokes of `line' by setting their dirty-bit to true. If `modified' or `cleared' is true, also set their modified-bit to true. If `cleared' is true, inform the strokes that their previous output has been cleared by someone, and that they do not need to clear it themselves during their next redisplay." (loop for stroke across (line-strokes line) do (invalidate-stroke stroke :modified modified :cleared cleared))) (defun invalidate-all-strokes (view &key modified cleared) "Invalidate all the strokes of `view' by setting their dirty-bit to true. If `modified' or `cleared' is true, also set their modified-bit to true. If `cleared' is true, inform the strokes that their previous output has been cleared by someone, and that they do not need to clear it themselves during their next redisplay." (loop for line across (displayed-lines view) do (invalidate-line-strokes line :modified modified :cleared cleared))) (defmacro do-displayed-lines ((line-sym view) &body body) "Loop over lines on display for `view', evaluating `body' with `line-sym' bound to the `displayed-line' object for each line." (check-type line-sym symbol) (with-gensyms (line-index) (once-only (view) `(dotimes (,line-index (displayed-lines-count ,view)) (let ((,line-sym (aref (displayed-lines ,view) ,line-index))) ,@body))))) (defmacro do-undisplayed-lines ((line-sym view) &body body) "Loop over lines not on display for `view', evaluating `body' with `line-sym' bound to the `displayed-line' object for each line." (check-type line-sym symbol) (with-gensyms (line-index) (once-only (view) `(dotimes (,line-index (- (length (displayed-lines ,view)) (displayed-lines-count ,view))) (let ((,line-sym (aref (displayed-lines ,view) (+ (displayed-lines-count ,view) ,line-index)))) ,@body))))) (defmacro do-displayed-line-strokes ((stroke-sym line &optional) &body body) "Loop over the displayed strokes of `line', evaluating `body' with `stroke-sym' bound to the `displayed-stroke' object for each line." (check-type stroke-sym symbol) (with-gensyms (stroke-index) (once-only (line) `(dotimes (,stroke-index (line-stroke-count ,line)) (let* ((,stroke-sym (aref (line-strokes ,line) ,stroke-index))) ,@body))))) (defmacro do-undisplayed-line-strokes ((stroke-sym line &optional) &body body) "Loop over the undisplayed strokes of `line', evaluating `body' with `stroke-sym' bound to the `displayed-stroke' object for each line." (check-type stroke-sym symbol) (with-gensyms (stroke-index) (once-only (line) `(dotimes (,stroke-index (- (length (line-strokes ,line)) (line-stroke-count ,line))) (let* ((,stroke-sym (aref (line-strokes ,line) (+ (line-stroke-count ,line) ,stroke-index)))) ,@body))))) (defun invalidate-strokes-in-region (view start-offset end-offset &key modified cleared to-line-end) "Invalidate all the strokes of `view' that overlap the region `start-offset'/`end-offset' by setting their dirty-bit to true. If `modified' or `cleared' is true, also set their modified-bit to true. If `cleared' is true, inform the strokes that their previous output has been cleared by someone, and that they do not need to clear it themselves during their next redisplay. If `to-line-end' is true, if a line is in the region, strokes in it will be invalidated until the end, even if line-end is beyond the region." (as-region (start-offset end-offset) ;; If the region is outside the visible region, no-op. (when (and (plusp (displayed-lines-count view)) ; If there is any display... (overlaps start-offset end-offset (offset (top view)) (offset (bot view)))) (let ((line1-index (index-of-displayed-line-containing-offset view start-offset)) (line2-index (index-of-displayed-line-containing-offset view end-offset))) (loop for line = (line-information view line1-index) when (<= start-offset (line-start-offset line) (line-end-offset line) end-offset) ;; The entire line is within the region. do (invalidate-line-strokes line :modified modified :cleared cleared) ;; Only part of the line is within the region. else do (do-displayed-line-strokes (stroke line) (when (overlaps start-offset (if to-line-end (line-end-offset line) end-offset) (stroke-start-offset stroke) (stroke-end-offset stroke)) (invalidate-stroke stroke :modified modified :cleared cleared))) if (= line1-index line2-index) do (loop-finish) else do (incf line1-index)))))) (defun find-stroke-containing-offset (view offset) "Find the stroke of `view' that displays the buffer offset `offset'. If no such stroke can be found, this function returns NIL." (do-displayed-lines (line view) (when (<= (line-start-offset line) offset (line-end-offset line)) (do-displayed-line-strokes (stroke line) (when (and (<= (stroke-start-offset stroke) offset (end-offset (stroke-end-offset stroke)))) (return stroke)))))) (defun index-of-displayed-line-containing-offset (view offset) "Return the index of the `displayed-line' object containing `offset'. If `offset' is before the displayed lines, return 0. If `offset' is after the displayed lines, return the index of the last line." (with-accessors ((lines displayed-lines)) view (cond ((< offset (line-start-offset (aref lines 0))) 0) ((> offset (line-end-offset (last-displayed-line view))) (1- (displayed-lines-count view))) (t ;; Binary search for the line. (loop with low-index = 0 with high-index = (displayed-lines-count view) for middle = (floor (+ low-index high-index) 2) for this-line = (aref lines middle) for line-start = (line-start-offset this-line) for line-end = (line-end-offset this-line) do (cond ((<= line-start offset line-end) (loop-finish)) ((> offset line-start) (setf low-index (1+ middle))) ((< offset line-start) (setf high-index middle))) finally (return middle)))))) (defun ensure-line-information-size (view min-size) "Ensure that the array of lines for `view' contains at least `min-size' elements." (with-accessors ((displayed-lines displayed-lines)) view (setf displayed-lines (ensure-array-size displayed-lines min-size #'make-displayed-line)))) (defun line-information (view index) "Return the `index'th `displayed-line' object of `view'." (ensure-line-information-size view (1+ index)) (elt (displayed-lines view) index)) (defun last-displayed-line (view) "Return the last line on display for `view', will result in an error if there is no such line (note that even an empty buffer consists of a single line on display, as long as it has been redislayed at some point)." (elt (displayed-lines view) (1- (displayed-lines-count view)))) (defun ensure-line-stroke-information-size (line min-size) "Ensure that the array of strokes in `line' contains at least `min-size' elements." (with-accessors ((line-strokes line-strokes)) line (setf line-strokes (ensure-array-size line-strokes min-size #'make-displayed-stroke)))) (defun line-stroke-information (line stroke-number) "Return the `index'th `displayed-stroke' object of `line'." (ensure-line-stroke-information-size line (1+ stroke-number)) (aref (line-strokes line) stroke-number)) (defun line-last-stroke (line) "Return the last stroke in `line', will result in an error if there is no such stroke (note that even an empty line consists of a single stroke on display, as long as it has been redislayed at some point)." (aref (line-strokes line) (1- (line-stroke-count line)))) (defun put-stroke (view line pump-state line-change offset) "Use `stroke-pump' with `pump-state' to get a new stroke for `view', and add it to the sequence of displayed strokes in `line'. `Line-change' should be a relative offset specifying how much the start-offset of `line' has changed since the last time it was redisplayed. `Offset' is the offset at which the next stroke will start." (let ((stroke (line-stroke-information line (line-stroke-count line)))) (unless (stroke-modified stroke) (incf (stroke-start-offset stroke) line-change) (incf (stroke-end-offset stroke) line-change) (when (/= (stroke-start-offset stroke) offset) (invalidate-stroke stroke :modified t))) (prog1 (stroke-pump view stroke pump-state) (incf (line-stroke-count line)) (setf (line-end-offset line) (stroke-end-offset stroke))))) (defun record-stroke (stroke parts widths x1 y1 x2 y2 &optional (drawn t) (center (/ (- y2 y1) 2))) "Record the fact that `stroke' has been drawn (if `drawn' is true), that it consists of parts `parts' with the widths `widths', and that it covers the specified area on screen. Sets the dirty-bit of `stroke' to false if `drawn' is true, and always sets the modified-bit of `stroke' to false, as it updates the dimensions." (let ((dimensions (stroke-dimensions stroke))) (setf (stroke-dirty stroke) (and (stroke-dirty stroke) (not drawn)) (stroke-modified stroke) nil (stroke-parts stroke) parts (stroke-widths stroke) widths (x1 dimensions) x1 (y1 dimensions) y1 (x2 dimensions) x2 (y2 dimensions) y2 (center dimensions) center))) (defun non-graphic-char-rep (object) "Return the appropriate representation of `object', a non-graphic char. This will be a string of the format \"^[letter]\" for non-graphic chars with a char-code of less than #o200, \"\\[octal code]\" for those above #o200, and the #\\Tab character in the case of a #\\Tab. NOTE: Assumes an ASCII/Unicode character encoding." (let ((code (char-code object))) (cond ((eql object #\Tab) object) ((< code #o200) (format nil "^~C" (code-char (+ code (char-code #\@))))) (t (format nil "\\~O" code))))) (defun analyse-stroke-string (string) "Return a list of parts of `string', where each part is a continuous run of graphic characters or a single non-graphic character. Each element in the list is of the form START, END, and one of NIL (meaning a run of graphic characters) or an object representing the non-graphic char." (loop with len = (length string) for left = 0 then (+ right 1) for right = (or (position-if-not #'graphic-char-p string :start left) len) unless (= left right) collect (list left right) into parts until (>= right len) collect (list right (+ right 1) (non-graphic-char-rep (aref string right))) into parts finally (return parts))) (defun calculate-stroke-width (stroke-string text-style stream x-position) "Calculate the width information of `stroke-string' when displayed with `text-style' (which must be fully specified) on `stream', starting at the horizontal device unit offset `x-position'. Three values will be returned: the total width of the stroke, the parts of the stroke and the widths of the parts of the stroke." (loop with parts = (analyse-stroke-string stroke-string) with width = 0 with widths = (make-array 1 :adjustable t :fill-pointer t :initial-element 0) for (start end object) in parts do (cond ((eql object #\Tab) (incf width (next-tab-stop stream (stream-default-view stream) (+ width x-position))) (vector-push-extend width widths)) (object (multiple-value-bind (w) (text-size stream object :text-style text-style) (incf width w) (vector-push-extend width widths))) (t (multiple-value-bind (w) (text-size stream stroke-string :start start :end end :text-style text-style) (incf width w) (vector-push-extend width widths)))) finally (return (values width parts widths)))) (defvar +roman-face-style+ (make-text-style nil :roman nil) "A text style specifying a roman face, but with unspecified family and size.") (defun stroke-drawing-fn (stream view stroke cursor-x cursor-y draw) "Draw `stroke' to `stream' baseline-adjusted at the position (`cursor-x', `cursor-y'). `View' is the view object that `stroke' belongs to. If `draw' is true, actually draw the stroke to `stream', otherwise, just calculate its size. It is assumed that the buffer region delimited by `stroke' only contains characters. `Stroke' is drawn with face given by the drawing options of `stroke', using the default text style of `stream' to fill out any holes. The screen area beneath `stroke' will be cleared before any actual output takes place." (with-accessors ((start-offset stroke-start-offset) (end-offset stroke-end-offset) (dimensions stroke-dimensions) (drawing-options stroke-drawing-options) (widths stroke-widths) (parts stroke-parts)) stroke (let* ((stroke-string (in-place-buffer-substring (buffer view) (cache-string view) start-offset end-offset)) (merged-text-style (merge-text-styles (face-style (drawing-options-face drawing-options)) (medium-merged-text-style (sheet-medium stream)))) ;; Ignore face when computing height, otherwise we get ;; bouncy lines when things like parenmatching bolds parts ;; of the line. (roman-text-style (merge-text-styles +roman-face-style+ merged-text-style)) (text-style-ascent (text-style-ascent roman-text-style (sheet-medium stream))) (text-style-descent (text-style-descent roman-text-style (sheet-medium stream)))) (with-accessors ((x1 x1) (x2 x2) (center center)) dimensions (multiple-value-bind (width stroke-parts part-widths) (if (stroke-modified stroke) (calculate-stroke-width stroke-string merged-text-style stream cursor-x) (values (- x2 x1) parts widths)) (when draw (loop for (start end object) in stroke-parts for width across part-widths do (cond ((eql object #\Tab) nil) (object (draw-text* stream object (+ cursor-x width) cursor-y :text-style merged-text-style :ink +darkblue+ :align-y :baseline)) (t (draw-text* stream stroke-string (+ cursor-x width) cursor-y :start start :end end :text-style merged-text-style :ink (face-ink (drawing-options-face drawing-options)) :align-y :baseline))))) (record-stroke stroke stroke-parts part-widths cursor-x (- cursor-y text-style-ascent) (+ width cursor-x) (+ cursor-y text-style-descent) draw text-style-ascent)))))) (defun update-stroke-dimensions (stream view stroke cursor-x cursor-y) "Calculate the dimensions of `stroke' on `stream' at (`cursor-x', `cursor-y'), but without actually drawing anything. Will use the function specified in the drawing-options of `stroke' to carry out the actual calculations." (unless (and (= cursor-x (x1 (stroke-dimensions stroke))) (= cursor-y (y1 (stroke-dimensions stroke))) (not (stroke-dirty stroke)) (mark<= (stroke-end-offset stroke) (bot view))) (invalidate-stroke stroke :modified t)) (when (stroke-dirty stroke) (funcall (drawing-options-function (stroke-drawing-options stroke)) stream view stroke cursor-x cursor-y #'stroke-drawing-fn nil))) (defvar *highlight-strokes* nil "If true, draw a box around all strokes and a line through their baseline..") (defvar *stroke-boundary-ink* +red+ "The ink with which stroke boundaries will be highlighted when `*highlight-strokes* is true.") (defvar *stroke-baseline-ink* +blue+ "The ink with which stroke baselines will be highlighted when `*highlight-strokes* is true.") (defun draw-stroke (pane view stroke cursor-x cursor-y) "Draw `stroke' on `pane' with a baseline at `cursor-y'. Drawing starts at the horizontal offset `cursor-x'. Stroke must thus have updated dimensional information. Nothing will be done unless `stroke' is dirty." (when (stroke-dirty stroke) (with-accessors ((x1 x1) (y1 y1) (x2 x2) (y2 y2) (center center)) (stroke-dimensions stroke) (when (> x2 (bounding-rectangle-width pane)) (change-space-requirements pane :width x2)) (when (> y2 (bounding-rectangle-height pane)) (change-space-requirements pane :height y2)) (funcall (drawing-options-function (stroke-drawing-options stroke)) pane view stroke cursor-x cursor-y #'stroke-drawing-fn t) (when *highlight-strokes* (draw-rectangle* pane x1 y1 (1- x2) (1- y2) :filled nil :ink *stroke-boundary-ink*) (draw-line* pane x1 (+ y1 center) x2 (+ y1 center) :ink *stroke-baseline-ink*))))) (defun end-line (line x1 y1 line-width line-height) "End the addition of strokes to `line' for now, and update the dimensions of `line'." (let ((dimensions (line-dimensions line))) (setf (x1 dimensions) x1 (y1 dimensions) y1 (x2 dimensions) (+ x1 line-width) (y2 dimensions) (+ y1 line-height)))) (defun end-line-cleaning-up (view line line-x1 line-y1 line-width line-height) "End the addition of strokes to `line' for now, and update the dimensions of `line'." (end-line line line-x1 line-y1 line-width line-height) (setf (max-line-width view) (max (max-line-width view) (dimensions-width (line-dimensions line)))) ;; This way, strokes that have at one point been left undisplayed ;; will always be considered modified when they are filled ;; again. The return is for optimisation, we know that an unused ;; stroke can only be followed by other unused strokes. (do-undisplayed-line-strokes (stroke line) (if (null (stroke-start-offset stroke)) (return) (progn (setf (stroke-start-offset stroke) nil) (invalidate-stroke stroke :modified t))))) (defun draw-line-strokes (pane view initial-pump-state start-offset cursor-x cursor-y view-width) "Pump strokes from `view', using `initial-pump-state' to begin with, and draw them on `pane'. The line is set to start at the buffer offset `start-offset', and will be drawn starting at (`cursor-x', `cursor-y'). `View-width' is the width of the view in device units, as calculated by the previous output iteration." (let* ((line (line-information view (displayed-lines-count view))) (orig-x-offset cursor-x) (offset-change (- start-offset (line-start-offset line))) (line-spacing (stream-vertical-spacing pane))) (setf (line-start-offset line) start-offset (line-stroke-count line) 0) ;; So yeah, this is fairly black magic, but it's not actually ;; ugly, just complex. (multiple-value-bind (line-width baseline descent pump-state) ;; Pump all the line strokes and calculate their dimensions. (loop with offset = start-offset for index from 0 for stroke = (line-stroke-information line index) for stroke-dimensions = (stroke-dimensions stroke) for pump-state = (put-stroke view line initial-pump-state offset-change offset) then (put-stroke view line pump-state offset-change offset) do (update-stroke-dimensions pane view stroke cursor-x cursor-y) (setf cursor-x (x2 stroke-dimensions)) (setf offset (stroke-end-offset stroke)) maximizing (- (dimensions-height stroke-dimensions) (center stroke-dimensions)) into descent maximizing (+ (center stroke-dimensions) cursor-y) into baseline summing (dimensions-width stroke-dimensions) into line-width when (stroke-at-end-of-line (buffer view) stroke) return (values line-width baseline descent pump-state)) (let ((line-height (- (+ baseline descent) cursor-y))) ;; Loop over the strokes and clear the parts of the pane that ;; has to be redrawn, trying to minimise the number of calls to ;; `clear-rectangle*'.. (flet ((maybe-clear (x1 x2) (unless (= x1 x2) (clear-rectangle* pane x1 cursor-y x2 (+ cursor-y line-height line-spacing))))) (loop with last-clear-x = orig-x-offset for stroke-index below (line-stroke-count line) for stroke = (aref (line-strokes line) stroke-index) for stroke-dimensions = (stroke-dimensions stroke) do (unless (= baseline (+ cursor-y (center stroke-dimensions))) (invalidate-stroke stroke)) (unless (stroke-dirty stroke) (maybe-clear last-clear-x (x1 stroke-dimensions)) (setf last-clear-x (x2 stroke-dimensions))) ;; This clears from end of line to the end of the sheet. finally (maybe-clear last-clear-x (+ last-clear-x view-width)))) ;; Now actually draw them in a way that makes sure they all ;; touch the bottom of the line. (loop for stroke-index below (line-stroke-count line) for stroke = (aref (line-strokes line) stroke-index) for stroke-dimensions = (stroke-dimensions stroke) do (draw-stroke pane view stroke (x1 stroke-dimensions) baseline) finally (progn (end-line-cleaning-up view line orig-x-offset cursor-y line-width line-height) (incf (displayed-lines-count view)) (return (values pump-state line-height)))))))) (defun clear-stale-lines (pane view old-width old-height) "Clear from the last displayed line to the end of `pane' and mark undisplayed line objects as dirty. `Old-width'/`old-height' are the old dimensions of the display of `view' in device units." ;; This way, strokes of lines that have at one point been left ;; undisplayed will always be considered modified when they are ;; filled again. The return is for optimisation, we know that an ;; unused stroke can only be followed by other unused strokes. (do-undisplayed-lines (line view) (setf (line-stroke-count line) 0) (do-undisplayed-line-strokes (stroke line) (if (null (stroke-start-offset stroke)) (return) (progn (setf (stroke-start-offset stroke) nil) (invalidate-stroke stroke :modified t))))) (with-bounding-rectangle* (x1 y1 x2 y2) view (declare (ignore x2)) (when (> old-height (- y2 y1)) (clear-rectangle* pane x1 y2 (+ x1 old-width) (+ y1 old-height))))) (defun object-drawer () "Return a closure capable of functioning as a stroke drawer. It expects its stroke to cover a single-object non-character buffer region, which will be presented with its appropriate presentation type (found via `presentation-type-of') to generate output." (let (output-record baseline (widths (make-array 2 :initial-contents (list 0 0))) (parts (list 0 1))) #'(lambda (stream view stroke cursor-x cursor-y default-drawing-fn draw) (declare (ignore default-drawing-fn)) (with-accessors ((start-offset stroke-start-offset) (drawing-options stroke-drawing-options)) stroke (let* ((object (buffer-object (buffer view) start-offset))) (when (or (null output-record) (stroke-modified stroke)) (setf output-record (with-output-to-output-record (stream) (present object (presentation-type-of object) :stream stream)) baseline (clim-extensions:output-record-baseline output-record))) ;; You will not believe this! If `cursor-x' is 0, it seems ;; like the changing position is ignored. So add some ;; minuscule amount to it, and all will be well. 0.1 ;; device units shouldn't even be visible. (let ((width (bounding-rectangle-width output-record))) (setf (output-record-position output-record) (values (+ cursor-x 0.1) (- cursor-y baseline))) (when draw (replay output-record stream)) (setf (aref widths 1) width) (record-stroke stroke parts widths cursor-x (- cursor-y baseline) (+ width cursor-x) cursor-y draw baseline))))))) (defmethod display-drei-view-contents ((pane basic-pane) (view drei-buffer-view)) (with-bounding-rectangle* (x1 y1 x2 y2) view (let* ((old-width (- x2 x1)) (old-height (- y2 y1)) (start-offset (offset (beginning-of-line (top view)))) (pump-state (pump-state-for-offset view start-offset)) (pane-height (bounding-rectangle-height (or (pane-viewport pane) pane)))) ;; For invalidation of the parts of the display that have ;; changed. (synchronize-view view :begin (offset (top view)) :end (max (offset (bot view)) (offset (top view)))) (setf (displayed-lines-count view) 0 (max-line-width view) 0) (multiple-value-bind (cursor-x cursor-y) (stream-cursor-position pane) (with-output-recording-options (pane :record nil :draw t) (loop for line = (line-information view (displayed-lines-count view)) do (multiple-value-bind (new-pump-state line-height) (draw-line-strokes pane view pump-state start-offset cursor-x cursor-y old-width) (setf pump-state new-pump-state start-offset (1+ (line-end-offset line))) (incf cursor-y (+ line-height (stream-vertical-spacing pane)))) when (or (and (not (extend-pane-bottom view)) (>= (y2 (line-dimensions line)) pane-height)) (= (line-end-offset line) (size (buffer view)))) return (progn (setf (offset (bot view)) (line-end-offset line)) (clear-stale-lines pane view old-width old-height)))))))) ;;; A default redisplay implementation that should work for subclasses ;;; of `drei-buffer-view'. Syntaxes that don't want to implement their ;;; own redisplay behavior can just call these. (defstruct (pump-state (:constructor make-pump-state (line-index offset chunk-index))) "A pump state object used by the `drei-buffer-view'. `Line' is the line object `offset' is in, and `line-index' is the index of `line' in the list of lines maintained by the view that created this pump state." line-index offset chunk-index) (defun chunk-for-offset (buffer-line offset) "Return the index of the first chunk of `buffer-line' that contains `offset'." (position (- offset (offset (start-mark buffer-line))) (chunks buffer-line) :test #'<= :key #'car)) (defun buffer-view-pump-state-for-offset (view offset) "Return a pump state usable for pumpting strokes for `view' (a `drei-buffer-view') from `offset'." ;; Perform binary search looking for line starting with `offset'. (synchronize-view view :begin offset) (with-accessors ((lines lines)) view (loop with low-index = 0 with high-index = (nb-elements lines) for middle = (floor (+ low-index high-index) 2) for this-line = (element* lines middle) for line-start = (start-mark this-line) do (cond ((offset-in-line-p this-line offset) (loop-finish)) ((mark> offset line-start) (setf low-index (1+ middle))) ((mark< offset line-start) (setf high-index middle))) finally (return (make-pump-state middle offset (chunk-for-offset this-line offset)))))) (defun fetch-chunk (line chunk-index) "Retrieve the `chunk-index'th chunk from `line'. The return value is either an integer, in which case it specifies the end-offset of a string chunk relative to the start of the line, or a function, in which case it is the drawing function for a single-object non-character chunk." (destructuring-bind (relative-chunk-end-offset . objectp) (aref (chunks line) chunk-index) (if objectp (object-drawer) (+ relative-chunk-end-offset (offset (start-mark line)))))) (defun buffer-view-stroke-pump (view stroke pump-state) "Pump redisplay data into `stroke' based on `pump-state' and the information managed by `view', which must be a `drei-buffer-view'." ;; `Pump-state' will be destructively modified. (prog1 pump-state (with-accessors ((line-index pump-state-line-index) (offset pump-state-offset) (chunk-index pump-state-chunk-index)) pump-state (let* ((chunk (fetch-chunk (element* (lines view) line-index) chunk-index)) (drawing-options (if (functionp chunk) (make-drawing-options :function chunk) +default-drawing-options+)) (end-offset (if (functionp chunk) (1+ offset) chunk))) (setf (stroke-start-offset stroke) offset (stroke-end-offset stroke) end-offset (stroke-drawing-options stroke) drawing-options) (if (offset-end-of-line-p (buffer view) end-offset) (setf line-index (1+ line-index) chunk-index 0 offset (1+ end-offset)) (setf chunk-index (1+ chunk-index) offset end-offset)))))) (defmethod pump-state-for-offset ((view drei-buffer-view) (offset integer)) (buffer-view-pump-state-for-offset view offset)) (defmethod stroke-pump ((view drei-buffer-view) stroke pump-state) (buffer-view-stroke-pump view stroke pump-state)) ;;; The following is the equivalent of a turbocharger for the ;;; redisplay engine. (defstruct (skipalong-pump-state (:constructor make-skipalong-pump-state (offset))) "A pump state for fast skipalong that doesn't involve the (potentially expensive) actual stroke pump. It transparently turns into a real pump state when it happens across invalid strokes. `Offset' is the offset of the next stroke to be pumped." offset) (defmethod stroke-pump :around ((view drei-buffer-view) (stroke displayed-stroke) (pump-state skipalong-pump-state)) (with-accessors ((state-offset skipalong-pump-state-offset)) pump-state (if (or (stroke-modified stroke) (/= (stroke-start-offset stroke) state-offset)) (stroke-pump view stroke (pump-state-for-offset view state-offset)) (progn (setf state-offset (+ (stroke-end-offset stroke) (if (offset-end-of-line-p (buffer view) (stroke-end-offset stroke)) 1 0))) pump-state)))) (defmethod stroke-pump :around ((view drei-buffer-view) (stroke displayed-stroke) pump-state) (if (stroke-modified stroke) (call-next-method) (stroke-pump view stroke (make-skipalong-pump-state (stroke-start-offset stroke))))) ;;; Cursor handling. (defun offset-in-stroke-position (stream view stroke offset) "Calculate the position in device units of `offset' in `stroke', relative to the starting position of `stroke'. `Offset' is an absolute offset into the buffer of `view'," (let ((string (in-place-buffer-substring (buffer view) (cache-string view) (stroke-start-offset stroke) offset))) (loop with pos = (- offset (stroke-start-offset stroke)) for width across (stroke-widths stroke) for next upfrom 1 for (start end object) in (stroke-parts stroke) when (and object (= pos end)) do (return (aref (stroke-widths stroke) next)) when (<= start pos end) do (return (+ width (text-size stream string :start start :end pos :text-style (merge-text-styles (face-style (drawing-options-face (stroke-drawing-options stroke))) (medium-merged-text-style (sheet-medium stream))))))))) (defgeneric offset-to-screen-position (pane view offset) (:documentation "Returns the position of offset as a screen position. Returns `x', `y', `stroke-height', `object-width' as values if offset is on the screen, NIL if offset is before the beginning of the screen, and T if offset is after the end of the screen. `Object-width' may be an approximation if `offset' is at the end of the buffer.")) (defmethod offset-to-screen-position ((pane clim-stream-pane) (view drei-view) (offset number)) (flet ((worker () (do-displayed-lines (line view) (when (<= (line-start-offset line) offset (line-end-offset line)) (with-accessors ((line-dimensions line-dimensions)) line (do-displayed-line-strokes (stroke line) (with-accessors ((start-offset stroke-start-offset) (end-offset stroke-end-offset) (stroke-dimensions stroke-dimensions)) stroke (cond ((and (= start-offset offset) (/= start-offset end-offset)) (return-from worker (values (x1 stroke-dimensions) (y1 stroke-dimensions) (dimensions-height stroke-dimensions) (if (= end-offset (1+ start-offset)) (dimensions-width stroke-dimensions) (offset-in-stroke-position pane view stroke (1+ offset)))))) ((and (<= start-offset offset) (< offset end-offset)) (return-from worker (let* ((relative-x-position (offset-in-stroke-position pane view stroke offset)) (absolute-x-position (+ (x1 stroke-dimensions) relative-x-position))) (values absolute-x-position (y1 stroke-dimensions) (dimensions-height stroke-dimensions) (if (= (1+ offset) end-offset) (- (x2 stroke-dimensions) absolute-x-position) (- (offset-in-stroke-position pane view stroke (1+ offset)) relative-x-position))))))))) ;; If we reach this point, we are just past the last ;; stroke, so let's extract information from it. (let ((stroke-dimensions (stroke-dimensions (line-last-stroke line)))) (return-from worker (values (x2 stroke-dimensions) (y1 stroke-dimensions) (dimensions-height stroke-dimensions))))))))) (with-accessors ((buffer buffer) (top top) (bot bot)) view (let ((default-object-width (text-style-width (medium-merged-text-style (sheet-medium pane)) pane))) (cond ((< offset (offset top)) nil) ((< (offset bot) offset) t) (t ;; Search through strokes, returning when we find one that ;; `offset' is in. Strokes with >1 object are assumed to be ;; strings. (multiple-value-bind (x y stroke-height object-width) (worker) (if (and x y stroke-height) (values x y stroke-height (or object-width default-object-width)) (let* ((first-line (aref (displayed-lines view) 0)) (dimensions (line-dimensions first-line))) (values (x1 dimensions) (y1 dimensions) (- (y2 dimensions) (y1 dimensions)) default-object-width)))))))))) (defmethod display-drei-view-cursor :around ((pane extended-output-stream) (view point-mark-view) (cursor drei-cursor)) ;; Try to draw the cursor... (call-next-method) ;; If it is the point, and there was no space for it... (when (and (eq (mark cursor) (point view)) (or (> (bounding-rectangle-max-x cursor) (bounding-rectangle-max-x pane)) (> (if (extend-pane-bottom view) (bounding-rectangle-max-y cursor) 0) (bounding-rectangle-max-y pane)))) ;; Embiggen the sheet. (change-space-requirements pane :width (max (bounding-rectangle-max-x cursor) (bounding-rectangle-max-x pane)) :height (max (if (extend-pane-bottom view) (bounding-rectangle-max-y cursor) 0) (bounding-rectangle-max-y pane))) ;; And draw the cursor again. (call-next-method))) (defmethod display-drei-view-cursor :around ((stream extended-output-stream) (view drei-buffer-view) (cursor drei-cursor)) (clear-output-record cursor) (when (visible-p cursor) (prog1 (call-next-method) (with-bounding-rectangle* (x1 y1 x2 y2) cursor (do-displayed-lines (line view) (cond ((> (y1 (line-dimensions line)) y2) (return)) ((coordinates-intersects-dimensions (line-dimensions line) x1 y1 x2 y2) (block stroke-loop (do-displayed-line-strokes (stroke line) (cond ((> (x1 (stroke-dimensions stroke)) x2) (return-from stroke-loop)) ((coordinates-intersects-dimensions (stroke-dimensions stroke) x1 y1 x2 y2) (setf (stroke-dirty stroke) t) (setf (stroke-modified stroke) t)))))))) (with-bounding-rectangle* (vx1 vy1 vx2 vy2) view (declare (ignore vy1 vx2 vy2)) (setf (max-line-width view) (max (max-line-width view) (- x2 vx1)))))))) (defmethod display-drei-view-cursor ((stream extended-output-stream) (view drei-buffer-view) (cursor drei-cursor)) (multiple-value-bind (cursor-x cursor-y stroke-height object-width) (offset-to-screen-position stream view (offset (mark cursor))) (letf (((stream-current-output-record stream) cursor)) (unless (zerop (* object-width stroke-height)) (draw-rectangle* stream cursor-x cursor-y (+ cursor-x object-width) (+ cursor-y stroke-height) :ink (ink cursor)))))) (defmethod bounding-rectangle* ((view drei-buffer-view)) "Return the bounding rectangle of the visual appearance of `view' as four values, just as `bounding-rectangle*'. Will return 0, 0, 0, 0 when `view' has not been redisplayed." (if (zerop (displayed-lines-count view)) (values 0 0 0 0) (let ((first-line (aref (displayed-lines view) 0)) (last-line (last-displayed-line view))) (values (x1 (line-dimensions first-line)) (y1 (line-dimensions first-line)) (+ (x1 (line-dimensions first-line)) (max-line-width view)) (y2 (line-dimensions last-line)))))) (defmethod bounding-rectangle-width ((view drei-buffer-view)) (multiple-value-bind (x1 y1 x2) (bounding-rectangle* view) (declare (ignore y1)) (- x2 x1))) (defun drei-bounding-rectangle* (drei-instance) "Return the bounding rectangle of the visual appearance of `drei-instance' as four values, just as `bounding-rectangle*'." (bounding-rectangle* (view drei-instance))) (defun drei-bounding-rectangle-width (drei-instance) "Return the width of the bounding rectangle of `drei-instance', calculated by `drei-bounding-rectangle*'." (multiple-value-bind (x1 y1 x2) (drei-bounding-rectangle* drei-instance) (declare (ignore y1)) (- x2 x1))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Drei area redisplay. ;; XXX: Full redraw for every replay, should probably use the `region' ;; parameter to only invalidate some strokes. (defmethod replay-output-record ((drei drei-area) (stream extended-output-stream) &optional (x-offset 0) (y-offset 0) (region +everywhere+)) (declare (ignore x-offset y-offset region)) (letf (((stream-cursor-position stream) (output-record-start-cursor-position drei))) (invalidate-all-strokes (view drei)) (display-drei-view-contents stream (view drei)))) (defmethod replay-output-record ((cursor drei-cursor) stream &optional (x-offset 0) (y-offset 0) (region +everywhere+)) (declare (ignore x-offset y-offset region)) (with-output-recording-options (stream :record t :draw t) (display-drei-view-cursor stream (view cursor) cursor))) (defun display-drei-area (drei) (with-accessors ((stream editor-pane) (view view)) drei (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) drei (replay drei stream) (with-bounding-rectangle* (new-x1 new-y1 new-x2 new-y2) drei (unless (or (and (= new-x1 old-x1) (= new-y1 old-y2) (= new-x2 old-x2) (= new-y2 old-y2)) (null (output-record-parent drei))) (recompute-extent-for-changed-child (output-record-parent drei) drei old-x1 old-y1 old-x2 old-y2)))) (when (point-cursor drei) (with-bounding-rectangle* (x1 y1 x2 y2) (point-cursor drei) (when (pane-viewport stream) (let* ((viewport (pane-viewport stream)) (viewport-height (bounding-rectangle-height viewport)) (viewport-width (bounding-rectangle-width viewport)) (viewport-region (pane-viewport-region stream))) ;; Scroll if point went outside the visible area. (when (and (active drei) (pane-viewport stream) (not (and (region-contains-position-p viewport-region x2 y2) (region-contains-position-p viewport-region x1 y1)))) (scroll-extent stream (max 0 (- x2 viewport-width)) (max 0 (- y2 viewport-height)))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Drei pane redisplay. (defgeneric handle-redisplay (pane view region) (:documentation "Handle redisplay of `view' upon `pane' (which is a Drei pane) in the given region. Methods defined on this function should mark their redisplay information as dirty based on `region' and call the default method, which will in turn call `display-drei' on `pane'.") (:method ((pane drei-pane) (view drei-view) (region region)) (display-drei pane))) (defmethod handle-repaint ((pane drei-pane) region) (handle-redisplay pane (view pane) region)) (defmethod handle-redisplay ((pane drei-pane) (view drei-buffer-view) (region region)) (invalidate-all-strokes (view pane) :cleared t) (call-next-method)) (defun reposition-pane (drei-pane) "Try to put point close to the middle of the pane by moving top half a pane-size up." (let* ((view (view drei-pane)) (nb-lines-in-pane (number-of-lines-in-region (top view) (bot view)))) (with-accessors ((top top) (point point)) view (setf (offset top) (offset point)) (beginning-of-line top) (loop do (beginning-of-line top) repeat (floor nb-lines-in-pane 2) until (beginning-of-buffer-p top) do (decf (offset top)) (beginning-of-line top)) (invalidate-all-strokes view :modified t)))) (defun adjust-pane (drei-pane) "Reposition the pane if point is outside the region delimited by the top/bot marks of its view. Returns true if adjustment was needed." (when (typep (view drei-pane) 'point-mark-view) (with-accessors ((buffer buffer) (top top) (bot bot) (point point)) (view drei-pane) (when (or (mark< point top) (mark> point bot)) (reposition-pane drei-pane) t)))) (defmethod page-down (pane (view drei-buffer-view)) (with-accessors ((top top) (bot bot)) view (when (mark> (size (buffer bot)) bot) (setf (offset top) (offset bot)) (beginning-of-line top) (setf (offset (point view)) (offset top)) (invalidate-all-strokes view :modified t)))) (defmethod page-up (pane (view drei-buffer-view)) (with-accessors ((top top) (bot bot)) view (when (> (offset top) 0) (setf (offset (point view)) (offset top)) (backward-object (point view)) (beginning-of-line (point view))))) (defgeneric fix-pane-viewport (pane view) (:documentation "Fix the size and scrolling of `pane', which has `view'.")) (defmethod fix-pane-viewport ((pane drei-pane) (view drei-view)) (let* ((output-width (drei-bounding-rectangle-width pane)) (viewport (pane-viewport pane)) (viewport-width (and viewport (bounding-rectangle-width viewport))) (pane-width (bounding-rectangle-width pane))) ;; If the width of the output is greater than the width of the ;; sheet, make the sheet wider. If the sheet is wider than the ;; viewport, but doesn't really need to be, make it thinner. (when (and viewport (> pane-width viewport-width) (>= viewport-width output-width)) (change-space-requirements pane :width output-width)))) (defmethod fix-pane-viewport :after ((pane drei-pane) (view point-mark-view)) (when (and (pane-viewport pane) (active pane)) (with-bounding-rectangle* (x1 y1 x2 y2) (point-cursor pane) (declare (ignore y1)) (multiple-value-bind (x-position y-position) (transform-position (sheet-transformation pane) 0 0) (let ((viewport-width (bounding-rectangle-width (or (pane-viewport pane) pane))) (viewport-height (bounding-rectangle-height (or (pane-viewport pane) pane)))) (cond ((> x2 (+ (abs x-position) viewport-width)) (scroll-extent pane (round (- x2 viewport-width)) 0)) ((> (abs x-position) x2) (scroll-extent pane (if (> viewport-width x1) 0 (round x1)) 0))) (when (and (> y2 (+ y-position viewport-height)) (not (end-of-buffer-p (bot view)))) (full-redisplay pane) ;; We start all over! (display-drei-pane (pane-frame pane) pane))))))) (defmethod pane-needs-redisplay :around ((pane drei-pane)) (values (call-next-method) nil)) (defgeneric fully-redisplay-pane (pane view) (:documentation "Fully redisplay `pane' showing `view', finally setting the `full-redisplay-p' flag to false.") (:method :after (pane (view drei-view)) (setf (full-redisplay-p view) nil))) (defmethod fully-redisplay-pane ((drei-pane drei-pane) (view point-mark-view)) (reposition-pane drei-pane)) (defmethod fully-redisplay-pane :after ((drei-pane drei-pane) (view drei-buffer-view)) (invalidate-all-strokes view)) (defun display-drei-pane (frame drei-pane) "Display `pane'. If `pane' has focus, `current-p' should be non-NIL." (let ((view (view drei-pane))) (with-accessors ((buffer buffer)) view (when (typep view 'point-mark-view) (when (full-redisplay-p view) (fully-redisplay-pane drei-pane view))) (setf (stream-cursor-position drei-pane) (values 0 0)) (display-drei-view-contents drei-pane view) (if (adjust-pane drei-pane) (display-drei-pane frame drei-pane) ;; Point must be on top of all other cursors. (dolist (cursor (cursors drei-pane) (fix-pane-viewport drei-pane (view drei-pane))) (replay cursor drei-pane)))))) (defgeneric full-redisplay (pane) (:documentation "Queue a full redisplay for `pane'.")) (defmethod full-redisplay ((pane drei-pane)) (setf (full-redisplay-p (view pane)) t)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/cl-automaton/0000750000175000017500000000000011347763412020270 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/cl-automaton/automaton-package.lisp0000640000175000017500000000333610562110260024550 0ustar pdmpdm;;; -*- Mode: Lisp; Package: AUTOMATON -*- ;;; ;;; (c) copyright 2005-2007 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (defpackage #:eqv-hash (:use :cl) (:export #:hash #:eqv #:key-situation #:builtin-key-situation #:eq-key-situation #:+eq-key-situation+ #:eql-key-situation #:+eql-key-situation+ #:equal-key-situation #:+equal-key-situation+ #:equalp-key-situation #:+equalp-key-situation+ #:case-sensitive-key-situation #:+case-sensitive-key-situation+ #:case-insensitive-key-situation #:+case-insensitive-key-situation+ #:make-generalized-hash-table #:generalized-hash-table #:ht #:cnt #:situation #:htref #:htadd #:htremove #:htpresent #:with-ht #:with-ht-collect)) (defpackage #:automaton (:nicknames #:cl-automaton) (:use :cl #:eqv-hash) (:export #:string-regexp #:regexp-automaton #:run #:run-to-first-match #:run-to-first-unmatch #:state-equal #:automaton-equal #:regexp-equal))cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/cl-automaton/automaton.asd0000640000175000017500000000067010524227664022774 0ustar pdmpdm;;; -*- mode: lisp -*- ;;; ;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic@yahoo.com) ;;; (in-package #:asdf) (defsystem #:automaton :depends-on ("rt") :components ((:file "automaton-package") (:file "eqv-hash" :depends-on ("automaton-package")) (:file "state-and-transition" :depends-on ("eqv-hash")) (:file "automaton" :depends-on ("state-and-transition" "eqv-hash")) (:file "regexp" :depends-on ("automaton"))))cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/cl-automaton/automaton.lisp0000640000175000017500000012323010705412617023165 0ustar pdmpdm;;; -*- Mode: Lisp; Package: AUTOMATON -*- ;;; ;;; (c) copyright 2005-2007 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; ;;; Derived from dk.brics.automaton v1.8.1, (c) 2001-2005 by Anders M/oller ;;; - Functionality not used by the regular expression engine and not tested ;;; has been omitted from this initial release. ;;; - Some comments have been copied verbatim from the original code. (in-package :automaton) (deftype minimization () '(member huffman brzozowski hopcroft)) (defvar *minimization* 'hopcroft) (defvar *minimize-always* t) ;;; Class invariants: ;;; - An automaton is either represented explicitly (with state and ;;; transition objects) or with a singleton string in case the ;;; automaton accepts exactly one string. ;;; - Automata are always reduced (see areduce) and have no transitions ;;; to dead states (see remove-dead-transitions). ;;; - If an automaton is nondeterministic, then deterministic returns nil ;;; (but the converse is not required). ;;; Implicitly, all states and transitions of an automaton are reachable ;;; from its initial state. ;;; If the states or transitions are manipulated manually, the ;;; restore-invariant and (setf deterministic) methods should be used ;;; afterwards to restore certain representation invariants that are ;;; assumed by the built-in automata operations. ;;; If minimize-always is true, minimize will automatically be invoked ;;; after every operation that otherwise may produce a non-minimal automaton ;;; (usually, an intermediate result). (defclass automaton () ((minimization :initform *minimization* :accessor minimization :type minimization) (initial :initform (make-instance 'state) :accessor initial :type state) (deterministic :initform t :accessor deterministic :type boolean) (info :initform nil :accessor info) (hash-code :initform 0 :accessor hash-code :type fixnum) (singleton :initform nil :accessor singleton :type (or null string)) (minimize-always :initform *minimize-always* :accessor minimize-always :type boolean))) (defun restore-invariant (a) (remove-dead-transitions a) (setf (hash-code a) 0)) (declaim (special *state-ht*)) (defun automaton-equal (a1 a2) ; for testing, assumes minimization (and (eq (minimization a1) (minimization a2)) (let ((*state-ht* (make-hash-table :test #'equal))) (state-equal (initial a1) (initial a2))) (eq (deterministic a1) (deterministic a2)) (eqv a1 a2 +equalp-key-situation+) (eq (minimize-always a1) (minimize-always a2)))) (defclass int-pair () ; TODO: replace with a simple cons ((n1 :initarg :n1 :reader n1 :type fixnum) (n2 :initarg :n2 :reader n2 :type fixnum))) (defclass state-list-node () ((q :initform nil :initarg :q :accessor q :type (or null state)) (succ :initform nil :accessor succ :type (or null state-list-node)) (pred :initform nil :accessor pred :type (or null state-list-node)) (sl :initform nil :initarg :sl :accessor sl :type (or null state-list)))) (defclass state-list () ((size :initform 0 :accessor size :type fixnum) (fst :initform nil :accessor fst :type (or null state-list-node)) (lst :initform nil :accessor lst :type (or null state-list-node)))) (defun check-minimize-always (a) (if (minimize-always a) (minimize a) a)) (defun states (a) "Returns a hash table containing the set of states reachable from the initial state of A." (expand-singleton a) (let ((visited (make-hash-table)) (worklist nil)) (setf (gethash (initial a) visited) t) (push (initial a) worklist) (loop for s = (first worklist) while worklist do (pop worklist) (with-ht (tr nil) (transitions s) (let ((s2 (to tr))) (unless (gethash s2 visited) (setf (gethash s2 visited) t) (push s2 worklist))))) visited)) (defun accepting-states (a) "Returns a hash table containing the set of accepting states reachable from the initial state of A." (let ((accepting (make-hash-table))) (loop for s being the hash-keys of (states a) when (accept s) do (setf (gethash s accepting) t)) accepting)) (defun set-state-nums (states) "Renumerates, by assigning consecutive numbers to the NUM slot of states being the keys of STATES hash table, and finally returns STATES." (let ((i -1)) (loop for s being the hash-keys of states do (setf (num s) (incf i)))) states) (defun totalize (a) "Adds transitions to an explicit crash state, added to A, to ensure that the transition function is total. Finally, returns A." (let* ((s (make-instance 'state)) (tr (make-instance 'transition :minc +min-char-code+ :maxc +max-char-code+ :to s))) (htadd (transitions s) tr) (loop for p being the hash-keys of (states a) and maxi = +min-char-code+ do (loop for tr in (sorted-transition-list p nil) do (with-slots (minc maxc) tr (when (> minc maxi) (htadd (transitions p) (make-instance 'transition :minc maxi :maxc (1- minc) :to s))) (when (> (1+ maxc) maxi) (setq maxi (1+ maxc))))) (when (<= maxi +max-char-code+) (htadd (transitions p) (make-instance 'transition :minc maxi :maxc +max-char-code+ :to s)))) a)) (defun areduce (a) "Reduces automaton A by combining overlapping and adjacent edge intervals with the same destination. Finally, returns A." (if (singleton a) a (let ((states (states a))) (set-state-nums states) (loop for s being the hash-keys of states do (let ((st (sorted-transition-list s t))) (reset-transitions s) (let ((p nil) (min -1) (max -1)) (loop for tr in st if (eq p (to tr)) do (with-slots (minc maxc) tr (if (<= minc (1+ max)) (when (> maxc max) (setq max maxc)) (progn (when p (htadd (transitions s) (make-instance 'transition :minc min :maxc max :to p))) (setq min minc max maxc)))) else do (with-slots (minc maxc to) tr (when p (htadd (transitions s) (make-instance 'transition :minc min :maxc max :to p))) (setq p to min minc max maxc))) (when p (htadd (transitions s) (make-instance 'transition :minc min :maxc max :to p)))))) a))) (defun start-points (a) "Returns a sorted vector of all interval start points (character codes)." (let ((pset (make-hash-table))) (loop for s being the hash-keys of (states a) do (setf (gethash +min-char-code+ pset) t) (with-ht (tr nil) (transitions s) (with-slots (minc maxc) tr (setf (gethash minc pset) t) (when (< maxc +max-char-code+) (setf (gethash (1+ maxc) pset) t))))) (let ((pa (make-array (hash-table-count pset) :element-type 'char-code-type))) (loop for p being the hash-keys of pset and n from 0 do (setf (aref pa n) p) finally (return (sort pa #'<)))))) (defun live-states2 (a states) "Returns the set of live states of A that are in STATES hash table. A state is live if an accepting state is reachable from it." (let ((map (make-hash-table))) (loop for s being the hash-keys of states do (setf (gethash s map) (make-hash-table))) (loop for s being the hash-keys of states do (with-ht (tr nil) (transitions s) (setf (gethash s (gethash (to tr) map)) t))) (let* ((live (accepting-states a)) (worklist (loop for s being the hash-keys of live collect s))) (loop for s = (first worklist) while worklist do (pop worklist) (loop for p being the hash-keys of (gethash s map) unless (gethash p live) do (setf (gethash p live) t) (push p worklist))) live))) (defun remove-dead-transitions (a) "Returns reduced A with transitions to dead states removed. A state is dead if no accepting state is reachable from it." (if (singleton a) nil (let* ((states (states a)) (live (live-states2 a states))) (loop for s being the hash-keys of states do (let ((st (transitions s))) (reset-transitions s) (with-ht (tr nil) st (when (gethash (to tr) live) (htadd (transitions s) tr))))) (areduce a)))) (defun sorted-transitions (states) "Renumerates each state in STATES hash table, and returns a vector of sorted vectors of transitions for each state, ordered by the NUM slot." (set-state-nums states) (let ((transitions (make-array (hash-table-count states)))) (loop for s being the hash-keys of states do (setf (aref transitions (num s)) (sorted-transition-vector s nil))) transitions)) (defun empty-automaton () "Returns a new determinsitic automaton with the empty language." (let ((a (make-instance 'automaton)) (s (make-instance 'state))) (setf (initial a) s (deterministic a) t) a)) (defun empty-string-automaton () "Returns a new deterministic automaton that accepts only the empty string." (let ((a (make-instance 'automaton))) (setf (singleton a) "" (deterministic a) t) a)) (defun any-string-automaton () "Returns a new deterministic automaton that accepts any string." (let ((a (make-instance 'automaton)) (s (make-instance 'state))) (setf (initial a) s (accept s) t (deterministic a) t) (htadd (transitions s) (make-instance 'transition :minc +min-char-code+ :maxc +max-char-code+ :to s)) a)) (defun any-char-automaton () "Returns a new deterministic automaton that accepts any single character." (char-range-automaton +min-char-code+ +max-char-code+)) (defun char-automaton (c) "Returns a new deterministic automaton that accepts a single character whose code is C." (char-range-automaton c c)) (defun char-range-automaton (cmin cmax) "Returns a new deterministic automaton that accepts a single character whose code is in closed interval [CMIN, CMAX]." (let ((a (make-instance 'automaton)) (s1 (make-instance 'state)) (s2 (make-instance 'state))) (setf (initial a) s1 (accept s2) t (deterministic a) t) (when (<= cmin cmax) (htadd (transitions s1) (make-instance 'transition :minc cmin :maxc cmax :to s2))) a)) (defun char-set-automaton (str) "Returns a new deterministic automaton that accepts a single character in set STR." (let ((a (make-instance 'automaton)) (s1 (make-instance 'state)) (s2 (make-instance 'state))) (setf (initial a) s1 (accept s2) t (deterministic a) t) (loop with t-table = (transitions s1) for c across str do (htadd t-table (make-instance 'transition :minc (char-code c) :maxc (char-code c) :to s2))) (areduce a))) (defun any-of-right-length-subautomaton (str n) "Returns a new sub-automaton (root of a state graph) accepting non-negative (decimal) integers of length of (subseq STR N)." (let ((s (make-instance 'state))) (if (= (length str) n) (setf (accept s) t) (htadd (transitions s) (make-instance 'transition :minc (char-code #\0) :maxc (char-code #\9) :to (any-of-right-length-subautomaton str (1+ n))))) s)) (defun at-least-subautomaton (str n initials zeros) "Returns a new sub-automaton (root of a state graph) accepting non-negative (decimal) integers of value at least the one represented by (subseq STR N), and of length of (subseq STR N)." (let ((s (make-instance 'state))) (if (= (length str) n) (setf (accept s) t) (let ((c (elt str n))) (when zeros (push s (car initials))) (htadd (transitions s) (make-instance 'transition :minc (char-code c) :maxc (char-code c) :to (at-least-subautomaton str (1+ n) initials (and zeros (char= c #\0))))) (when (char< c #\9) (htadd (transitions s) (make-instance 'transition :minc (1+ (char-code c)) :maxc (char-code #\9) :to (any-of-right-length-subautomaton str (1+ n))))))) s)) (defun at-most-subautomaton (str n) "Returns a new sub-automaton (root of a state graph) accepting non-negative (decimal) integers of value at most the one represented by (subseq STR N), and of length of (subseq STR N)." (let ((s (make-instance 'state))) (if (= (length str) n) (setf (accept s) t) (let ((c (elt str n))) (htadd (transitions s) (make-instance 'transition :minc (char-code c) :maxc (char-code c) :to (at-most-subautomaton str (1+ n)))) (when (char> c #\0) (htadd (transitions s) (make-instance 'transition :minc (char-code #\0) :maxc (1- (char-code c)) :to (any-of-right-length-subautomaton str (1+ n))))))) s)) (defun between-subautomaton (str1 str2 n initials zeros) "Returns a new sub-automaton (root of a state graph) accepting non-negative (decimal) integers of value between the one represented by (subseq STR1 N) and (subseq STR2 N), inclusive, and of length of \(subseq STR1 N) = (subseq STR2 N)." (let ((s (make-instance 'state))) (if (= (length str1) n) (setf (accept s) t) (let ((c1 (elt str1 n)) (c2 (elt str2 n))) (when zeros (push s (car initials))) (if (char= c1 c2) (htadd (transitions s) (make-instance 'transition :minc (char-code c1) :maxc (char-code c1) :to (between-subautomaton str1 str2 (1+ n) initials (and zeros (char= c1 #\0))))) (progn (htadd (transitions s) (make-instance 'transition :minc (char-code c1) :maxc (char-code c1) :to (at-least-subautomaton str1 (1+ n) initials (and zeros (char= c1 #\0))))) (htadd (transitions s) (make-instance 'transition :minc (char-code c2) :maxc (char-code c2) :to (at-most-subautomaton str2 (1+ n)))) (when (< (1+ (char-code c1)) (char-code c2)) (htadd (transitions s) (make-instance 'transition :minc (1+ (char-code c1)) :maxc (1- (char-code c2)) :to (any-of-right-length-subautomaton str1 (1+ n))))))))) s)) (defun interval-automaton (min max digits) "Returns a new automaton that accepts strings representing non-negative (decimal) integers in interval [MIN, MAX]. If DIGITS > 0, uses the fixed number of digits (strings must be prefixed by 0s to obtain the right length). Otherwise, the number of digits is not fixed. If MIN > MAX or if the numbers in the interval cannot be expressed with the given fixed number of digits, an error is signaled." (flet ((%num-digits (n) (if (= n 0) 1 (1+ (floor (log n 10)))))) (assert (and (<= 0 min max) (or (<= digits 0) (<= (%num-digits max) digits))) () "MIN and MAX not expressible with the same number of digits") (let* ((a (make-instance 'automaton)) (d (if (> digits 0) digits (%num-digits max))) (str1 (format nil "~V,'0D" d min)) (str2 (format nil "~V,'0D" d max)) (initials (cons nil nil))) (setf (initial a) (between-subautomaton str1 str2 0 initials (<= digits 0))) (if (<= digits 0) (let ((pairs nil)) (loop for p in (car initials) unless (eq (initial a) p) do (push (make-instance 'state-pair :s1 (initial a) :s2 p) pairs)) (add-epsilons a pairs) (htadd (transitions (initial a)) (make-instance 'transition :minc (char-code #\0) :maxc (char-code #\0) :to (initial a))) (setf (deterministic a) nil)) (setf (deterministic a) t)) (check-minimize-always a)))) (defun expand-singleton (a) "Expands the singleton representation of A into the regular representation, and returns A." (with-slots ((st singleton)) a (when st (let ((p (make-instance 'state))) (setf (initial a) p) (loop for c across st do (let ((q (make-instance 'state))) (htadd (transitions p) (make-instance 'transition :minc (char-code c) :maxc (char-code c) :to q)) (setq p q))) (setf (accept p) t (deterministic a) t st nil)))) a) (defun string-automaton (str) "Returns a new deterministic automaton that accepts the single given string STR." (let ((a (make-instance 'automaton))) (setf (singleton a) str (deterministic a) t) a)) (defun aconcatenate (a1 a2) "Returns a new automaton that accepts the concatenation of the languages of A1 and A2. Complexity: linear in the number of states." (if (and (singleton a1) (singleton a2)) (string-automaton (concatenate 'string (singleton a1) (singleton a2))) (progn (setf a1 (clone-expanded a1) a2 (clone-expanded a2)) (loop for s being the hash-keys of (accepting-states a1) do (setf (accept s) nil) (add-epsilon s (initial a2))) (setf (deterministic a1) nil) (check-minimize-always a1)))) (defun aconcatenate-many (l) "Returns a new automaton that accepts the concatenation of the languages of automata in list L, respecting the order. Complexity: linear in the total number of states." (if l (let* ((a1 (clone-expanded (car l))) (ac1 (accepting-states a1))) (loop for a2 in (cdr l) do (let* ((a2 (clone-expanded a2)) (ac2 (accepting-states a2))) (loop for s being the hash-keys of ac1 do (setf (accept s) nil) (add-epsilon s (initial a2)) (when (accept s) (setf (gethash s ac2) t))) (setq ac1 ac2))) (setf (deterministic a1) nil) (check-minimize-always a1)) (empty-string-automaton))) (defun optional (a) "Returns a new automaton that accepts the union of the empty string and the language of A. Complexity: linear in the number of states." (let ((a (clone-expanded a)) (s (make-instance 'state))) (add-epsilon s (initial a)) (setf (accept s) t (initial a) s (deterministic a) nil) (check-minimize-always a))) (defun repeat (a) "Returns a new automaton that accepts the Kleene star (zero or more concatenated repetitions) of the language of A. Complexity: linear in the number of states." (let ((a (clone-expanded a)) (s (make-instance 'state))) (setf (accept s) t) (add-epsilon s (initial a)) (loop for p being the hash-keys of (accepting-states a) do (add-epsilon p s)) (setf (initial a) s (deterministic a) nil) (check-minimize-always a))) (defun repeat-min (a min) "Returns a new automaton that accepts MIN or more concatenated repetitions of the language of A." (let ((a2 (repeat a))) (loop while (> min 0) do (setq a2 (aconcatenate a a2) min (1- min))) a2)) (defun repeat-minmax (a min max) "Returns a new automaton that accepts a number, from [MIN, MAX], of concatenated repetitions of the language of A. If MIN > MAX, the empty automaton is returned." (expand-singleton a) (when (> min max) (return-from repeat-minmax (empty-automaton))) (decf max min) (let ((a2 (cond ((= min 0) (empty-string-automaton)) ((= min 1) (clone a)) (t (loop with tmp = a while (> (decf min) 0) do (setq tmp (aconcatenate a tmp)) finally (return tmp)))))) (when (= max 0) (return-from repeat-minmax a2)) (let ((a3 (clone a))) (loop while (> (decf max) 0) do (let ((a4 (clone a))) (loop for p being the hash-keys of (accepting-states a4) do (add-epsilon p (initial a3))) (setq a3 a4))) (loop for p being the hash-keys of (accepting-states a2) do (add-epsilon p (initial a3))) (setf (deterministic a2) nil) (check-minimize-always a2)))) (defun acomplement (a) "Returns a new deterministic" (let ((a (clone-expanded a))) (determinize a) (totalize a) (loop for p being the hash-keys of (states a) do (setf (accept p) (not (accept p)))) (remove-dead-transitions a) (check-minimize-always a))) (defun aintersection (a1 a2) "Returns a new deterministic automaton that accepts the intersection of the languages of A and A2. As a side-effect, both A1 and A2 are determinized if not already deterministic. Complexity: quadratic in the number of states (when deterministic)." (if (and (singleton a1) (singleton a2)) (if (string= (singleton a1) (singleton a2)) (string-automaton (singleton a1)) (empty-automaton)) (progn (determinize a1) (determinize a2) (let* ((trs1 (sorted-transitions (states a1))) (trs2 (sorted-transitions (states a2))) (a3 (make-instance 'automaton)) (worklist nil) (newstates (make-generalized-hash-table +equalp-key-situation+)) (s (make-instance 'state)) (p (make-instance 'state-pair :s s :s1 (initial a1) :s2 (initial a2)))) (setf (initial a3) s) (push p worklist) (setf (htref newstates p) p) (loop while worklist do (setq p (pop worklist)) (setf (accept (s p)) (and (accept (s1 p)) (accept (s2 p)))) (let* ((t1 (aref trs1 (num (s1 p)))) (t2 (aref trs2 (num (s2 p)))) (t1l (length t1)) (t2l (length t2))) (loop with n1 = 0 and n2 = 0 while (and (< n1 t1l) (< n2 t2l)) do (cond ((< (maxc (aref t1 n1)) (minc (aref t2 n2))) (incf n1)) ((< (maxc (aref t2 n2)) (minc (aref t1 n1))) (incf n2)) (t (let* ((q (make-instance 'state-pair :s1 (to (aref t1 n1)) :s2 (to (aref t2 n2)))) (r (htref newstates q)) (min (max (minc (aref t1 n1)) (minc (aref t2 n2)))) (max (min (maxc (aref t1 n1)) (maxc (aref t2 n2))))) (unless r (setf (s q) (make-instance 'state)) (push q worklist) (setf (htref newstates q) q) (setq r q)) (htadd (transitions (s p)) (make-instance 'transition :minc min :maxc max :to (s r))) (if (< (maxc (aref t1 n1)) (maxc (aref t2 n2))) (incf n1) (incf n2)))))))) (setf (deterministic a3) t) (remove-dead-transitions a3) (check-minimize-always a3))))) (defun aunion (a1 a2) "Returns a new automaton that accepts the union of the languages of A1 and A2. Complexity: linear in the number of states." (when (and (singleton a1) (singleton a2) (string= (singleton a1) (singleton a2))) (return-from aunion (clone a1))) (let ((a2 (clone-expanded a2)) (a3 (clone-expanded a1)) (s (make-instance 'state))) (add-epsilon s (initial a2)) (add-epsilon s (initial a3)) (setf (initial a2) s (deterministic a2) nil) (check-minimize-always a2))) (defun aunion-many (l) "Returns a new automaton that accepts the union of the languages of automata given in list L." (let ((s (make-instance 'state)) (a (make-instance 'automaton))) (loop for b in l do (add-epsilon s (initial (clone-expanded b)))) (setf (initial a) s (deterministic a) nil) (check-minimize-always a))) (defun determinize (a) "Determinizes A and returns it." (if (or (deterministic a) (singleton a)) a (let ((initialset (make-instance 'state-set))) (setf (gethash (initial a) (ht initialset)) t) (determinize2 a initialset)))) (defun determinize2 (a initialset) "Determinizes A using the set of initial states in INITIALSET state-set." (let ((points (start-points a)) (sets (make-generalized-hash-table +equalp-key-situation+)) (worklist nil) (newstate (make-generalized-hash-table +equalp-key-situation+))) (setf (htref sets initialset) initialset) (push initialset worklist) (setf (initial a) (make-instance 'state)) (setf (htref newstate initialset) (initial a)) (loop while worklist do (let* ((s (pop worklist)) (r (htref newstate s))) (loop for q being the hash-keys of (ht s) when (accept q) do (setf (accept r) t) (return)) (loop with len = (length points) for c across points and n from 0 do (let ((p (make-instance 'state-set))) (loop for q being the hash-keys of (ht s) do (with-ht (tr nil) (transitions q) (when (<= (minc tr) c (maxc tr)) (setf (gethash (to tr) (ht p)) t)))) (unless (htpresent sets p) (setf (htref sets p) p) (push p worklist) (setf (htref newstate p) (make-instance 'state))) (let ((q (htref newstate p)) (min c) (max (if (< (1+ n) len) (1- (aref points (1+ n))) +max-char-code+))) (htadd (transitions r) (make-instance 'transition :minc min :maxc max :to q))))))) (setf (deterministic a) t) (remove-dead-transitions a))) (defun minimize (a) "Minimizes, and determinizes if not already deterministic, A and returns it." (with-slots (singleton minimization hash-code) a (unless singleton (ecase minimization (huffman (minimize-huffman a)) (brzozowski (minimize-brzozowski a)) (hopcroft (minimize-hopcroft a)))) (setf hash-code (+ (* 3 (num-of-states a)) (* 2 (num-of-transitions a)))) (when (= hash-code 0) (setf hash-code 1))) a) (defun states-agree (trs mark n1 n2) (let ((t1 (aref trs n1)) (t2 (aref trs n2))) (loop with k1 = 0 and k2 = 0 and l1 = (length t1) and l2 = (length t2) while (and (< k1 l1) (< k2 l2)) do (cond ((< (maxc (aref t1 k1)) (minc (aref t2 k2))) (incf k1)) ((< (maxc (aref t2 k2)) (minc (aref t1 k1))) (incf k2)) (t (let ((m1 (num (to (aref t1 k1)))) (m2 (num (to (aref t2 k2))))) (when (> m1 m2) (rotatef m1 m2)) (when (aref mark m1 m2) (return nil)) (if (< (maxc (aref t1 k1)) (maxc (aref t2 k2))) (incf k1) (incf k2))))) finally (return t)))) (defun add-triggers (trs triggers n1 n2) (let ((t1 (aref trs n1)) (t2 (aref trs n2))) (loop with k1 = 0 and k2 = 0 while (and (< k1 (length t1)) (< k2 (length t2))) do (cond ((< (maxc (aref t1 k1)) (minc (aref t2 k2))) (incf k1)) ((< (maxc (aref t2 k2)) (minc (aref t1 k1))) (incf k2)) (t (unless (eq (to (aref t1 k1)) (to (aref t2 k2))) (let ((m1 (num (to (aref t1 k1)))) (m2 (num (to (aref t2 k2))))) (when (> m1 m2) (rotatef m1 m2)) (unless (aref triggers m1 m2) (setf (aref triggers m1 m2) (make-hash-table))) (setf (gethash (make-instance 'int-pair :n1 n1 :n2 n2) (aref triggers m1 m2)) t))) (if (< (maxc (aref t1 k1)) (maxc (aref t2 k2))) (incf k1) (incf k2))))))) (defun mark-pair (mark triggers n1 n2) (setf (aref mark n1 n2) t) (when (aref triggers n1 n2) (loop for p being the hash-keys of (aref triggers n1 n2) do (let ((m1 (n1 p)) (m2 (n2 p))) (when (> m1 m2) (rotatef m1 m2)) (unless (aref mark m1 m2) (mark-pair mark triggers m1 m2)))))) (defun ht-set-to-vector (ht) (loop with vec = (make-array (hash-table-count ht)) for k being the hash-keys of ht and i from 0 do (setf (aref vec i) k) finally (return vec))) (defun minimize-huffman (a) "Minimizes A using the standard textbook, Huffman's algorithm. Complexity: O(N ^ 2), where N is the number of states." (determinize a) (totalize a) (let* ((ss (states a)) (ss-cnt (hash-table-count ss)) (trs (make-array ss-cnt)) (states (ht-set-to-vector ss)) (mark (make-array `(,ss-cnt ,ss-cnt) :element-type 'boolean :initial-element nil)) (triggers (make-array `(,ss-cnt ,ss-cnt) :initial-element nil)) (numclasses 0)) (loop for n1 below ss-cnt do (setf (num (aref states n1)) n1 (aref trs n1) (sorted-transition-vector (aref states n1) nil)) (loop for n2 from (1+ n1) below ss-cnt unless (eq (accept (aref states n1)) (accept (aref states n2))) do (setf (aref mark n1 n2) t))) (loop for n1 below ss-cnt do (loop for n2 from (1+ n1) below ss-cnt unless (aref mark n1 n2) do (if (states-agree trs mark n1 n2) (add-triggers trs triggers n1 n2) (mark-pair mark triggers n1 n2)))) (loop for n below ss-cnt do (setf (num (aref states n)) -1)) (loop for n1 below ss-cnt when (= (num (aref states n1)) -1) do (setf (num (aref states n1)) numclasses) (loop for n2 from (1+ n1) below ss-cnt unless (aref mark n1 n2) do (setf (num (aref states n2)) numclasses)) (incf numclasses)) (let ((newstates (make-array numclasses))) (loop for n below numclasses do (setf (aref newstates n) (make-instance 'state))) (loop for n below ss-cnt do (setf (num (aref newstates (num (aref states n)))) n) (when (eq (aref states n) (initial a)) (setf (initial a) (aref newstates (num (aref states n)))))) (loop for n below numclasses do (let ((s (aref newstates n))) (setf (accept s) (accept (aref states (num s)))) (with-ht (tr nil) (transitions (aref states (num s))) (htadd (transitions s) (make-instance 'transition :minc (minc tr) :maxc (maxc tr) :to (aref newstates (num (to tr)))))))) (remove-dead-transitions a)))) (defun minimize-brzozowski (a) "Minimizes A using Brzozowski's algorithm. Complexity: O(2 ^ N), where N is the number of states, but works very well in practice (even better than Hopcroft's)." (if (singleton a) nil (progn (determinize2 a (make-instance 'state-set :ht (areverse a))) (determinize2 a (make-instance 'state-set :ht (areverse a)))))) (defun minimize-hopcroft (a) "Minimizes A using Hopcroft's algorithm. Complexity: O(N log N), regarded as one of the most generally efficient existing algorithms." (determinize a) (let ((trs (transitions (initial a)))) (when (= (cnt trs) 1) (with-ht (tr nil) trs (when (and (eq (to tr) (initial a)) (= (minc tr) +min-char-code+) (= (maxc tr) +max-char-code+)) (return-from minimize-hopcroft))))) (totalize a) (let* ((ss (states a)) (ss-cnt (hash-table-count ss)) (states (ht-set-to-vector ss))) (set-state-nums ss) (let* ((sigma (start-points a)) (sigma-cnt (length sigma)) (rvrs (make-array `(,ss-cnt ,sigma-cnt) :initial-element nil)) (rvrs-ne (make-array `(,ss-cnt ,sigma-cnt) :element-type 'boolean :initial-element nil)) (partition (make-array ss-cnt :initial-element nil)) (block (make-array ss-cnt :element-type 'fixnum)) (active (make-array `(,ss-cnt ,sigma-cnt))) (active2 (make-array `(,ss-cnt ,sigma-cnt) :initial-element nil)) (pending nil) (pending2 (make-array `(,sigma-cnt ,ss-cnt) :element-type 'boolean :initial-element nil)) (split nil) (split2 (make-array ss-cnt :element-type 'boolean :initial-element nil)) (refine nil) (refine2 (make-array ss-cnt :element-type 'boolean :initial-element nil)) (splitblock (make-array ss-cnt :initial-element nil)) (k 2)) (loop for j below ss-cnt do (loop for i below sigma-cnt do (setf (aref active j i) (make-instance 'state-list)))) (loop for q below ss-cnt for qq = (aref states q) do (let ((j (if (accept qq) 0 1))) (push qq (aref partition j)) (setf (aref block (num qq)) j) (loop for i below sigma-cnt do (let* ((aa (code-char (aref sigma i))) (p (sstep qq aa))) (push qq (aref rvrs (num p) i)) (setf (aref rvrs-ne (num p) i) t))))) (loop for j from 0 to 1 do (loop for i below sigma-cnt do (loop for qq in (aref partition j) when (aref rvrs-ne (num qq) i) do (setf (aref active2 (num qq) i) (slnadd (aref active j i) qq))))) (loop for i below sigma-cnt for i0 = (size (aref active 0 i)) and i1 = (size (aref active 1 i)) do (let ((j (if (<= i0 i1) 0 1))) (push (make-instance 'int-pair :n1 j :n2 i) pending) (setf (aref pending2 i j) t))) (loop for ip = (first pending) for p = (when pending (n1 ip)) and i = (when pending (n2 ip)) while pending do (pop pending) (setf (aref pending2 i p) nil) (loop for m = (fst (aref active p i)) then (succ m) while m do (loop for s in (aref rvrs (num (q m)) i) unless (aref split2 (num s)) do (setf (aref split2 (num s)) t) (push s split) (let ((j (aref block (num s)))) (push s (aref splitblock j)) (unless (aref refine2 j) (setf (aref refine2 j) t) (push j refine))))) (loop for j in refine do (when (< (length (aref splitblock j)) (length (aref partition j))) (loop for s in (aref splitblock j) do (setf (aref partition j) (remove s (aref partition j))) (push s (aref partition k)) (setf (aref block (num s)) k) (loop for c below sigma-cnt for sn = (aref active2 (num s) c) when (and sn (eq (sl sn) (aref active j c))) do (slnremove sn) (setf (aref active2 (num s) c) (slnadd (aref active k c) s)))) (loop for c below sigma-cnt for ij = (size (aref active j c)) and ik = (size (aref active k c)) if (and (not (aref pending2 c j)) (< 0 ij) (<= ij ik)) do (setf (aref pending2 c j) t) (push (make-instance 'int-pair :n1 j :n2 c) pending) else do (setf (aref pending2 c k) t) (push (make-instance 'int-pair :n1 k :n2 c) pending)) (incf k)) (loop for s in (aref splitblock j) do (setf (aref split2 (num s)) nil)) (setf (aref refine2 j) nil) (setf (aref splitblock j) nil)) (setq split nil) (setq refine nil)) (let ((newstates (make-array k))) (loop for n below k for s = (make-instance 'state) do (setf (aref newstates n) s) (loop for q in (aref partition n) do (when (eq q (initial a)) (setf (initial a) s)) (setf (accept s) (accept q) (num s) (num q) (num q) n))) (loop for n below k for s = (aref newstates n) do (with-ht (tr nil) (transitions (aref states (num s))) (setf (num s) n) (htadd (transitions s) (make-instance 'transition :minc (minc tr) :maxc (maxc tr) :to (aref newstates (num (to tr))))))) (remove-dead-transitions a))))) (defun areverse (a) "Reverses the language of non-singleton A. Returns a hash table of new initial states." (let ((m (make-hash-table)) (states (states a)) (astates (accepting-states a))) (loop for r being the hash-keys of states do (setf (gethash r m) (make-generalized-hash-table +equalp-key-situation+) (accept r) nil)) (loop for r being the hash-keys of states do (with-ht (tr nil) (transitions r) (htadd (gethash (to tr) m) (make-instance 'transition :minc (minc tr) :maxc (maxc tr) :to r)))) (loop for r being the hash-keys of states do (setf (transitions r) (gethash r m))) (setf (accept (initial a)) t (initial a) (make-instance 'state)) (loop for r being the hash-keys of astates do (add-epsilon (initial a) r)) (setf (deterministic a) nil) astates)) (defun add-epsilons (a pairs) "Adds epsilon transitions to A and returns it. This is done by adding extra character interval transitions that are equivalent to the given set of epsilon transitions. PAIRS is a list of state-pair objects representing pairs of source-destination states where the epsilon transitions should be added." (expand-singleton a) (let ((forward (make-hash-table)) (back (make-hash-table))) (loop for p in pairs do (let ((tos (gethash (s1 p) forward)) (froms (gethash (s2 p) back))) (unless tos (setq tos (make-hash-table)) (setf (gethash (s1 p) forward) tos)) (setf (gethash (s2 p) tos) t) (unless froms (setq froms (make-hash-table)) (setf (gethash (s2 p) back) froms)) (setf (gethash (s1 p) froms) t))) (let ((worklist pairs) (workset (make-generalized-hash-table +equalp-key-situation+))) (loop for p in pairs do (htadd workset p)) (loop for p = (first worklist) while worklist do (pop worklist) (htremove workset p) (let ((tos (gethash (s2 p) forward)) (froms (gethash (s1 p) back))) (when tos (loop for s being the hash-keys of tos for pp = (make-instance 'state-pair :s1 (s1 p) :s2 s) unless (member pp pairs :test #'(lambda (o1 o2) (eqv o1 o2 +equalp-key-situation+))) do (push pp pairs) (setf (gethash s (gethash (s1 p) forward)) t) (setf (gethash (s1 p) (gethash s back)) t) (push pp worklist) (htadd workset pp) (when froms (loop for q being the hash-keys of froms for qq = (make-instance 'state-pair :s1 q :s2 (s1 p)) unless (htpresent workset qq) do (push qq worklist) (htadd worklist qq))))))) (loop for p in pairs do (add-epsilon (s1 p) (s2 p))) (setf (deterministic a) nil) (check-minimize-always a)))) (defun run (a str) "Returns true if STR is accepted by A. As a side-effect, A is determinized if not already deterministic. Complexity: linear in the length of STR (when A is deterministic)." (if (singleton a) (string= str (singleton a)) (progn (determinize a) (let ((p (initial a))) (loop for i below (length str) for q = (sstep p (elt str i)) unless q return nil do (setq p q) finally (return (accept p))))))) (defun run-to-first-match (a str &optional (start 0) (end (length str))) "Returns the end position of match if a substring of STR, optionally between positions START and END, is found that is accepted by A; otherwise, returns nil. Complexity: linear in the length of STR (when A is deterministic)." (if (singleton a) (let ((from (search (singleton a) str :start2 start :end2 end))) (when from (+ from (length str)))) (progn (determinize a) (let ((p (initial a))) (loop for i from start below end for q = (sstep p (elt str i)) do (unless q (return nil)) (if (accept q) (return (1+ i)) (setq p q)) finally (return nil)))))) (defun run-to-first-unmatch (a str &optional (start 0) (end (length str))) "Returns the end position of match if a substring of STR, optionally between positions START and END, is found that is accepted by A; otherwise, returns nil. A greedy approach is taken until the first match failure or the end of STR (whatever happens first), trying to extend the match length one character at a time. Complexity: linear in the length of STR (when A is deterministic)." (if (singleton a) (let ((from (search (singleton a) str :start2 start :end2 end))) (when from (+ from (length str)))) (progn (determinize a) (let* ((p (initial a)) (matched (accept p))) (loop for i from start below end for q = (sstep p (elt str i)) if (not q) return (if matched i nil) else do (if (accept q) (setq matched t) (when matched (return i))) (setq p q) finally (return (if matched i nil))))))) (defun num-of-states (a) "Returns the number of states of A." (if (singleton a) (1+ (length (singleton a))) (hash-table-count (states a)))) (defun num-of-transitions (a) "Returns the number of transitions of A." (if (singleton a) (length (singleton a)) (loop for s being the hash-keys of (states a) sum (cnt (transitions s))))) (defun empty-p (a) "Returns true if A accepts no strings." (if (singleton a) nil (and (not (accept (initial a))) (= (cnt (transitions (initial a))) 0)))) (defun subset-of (a a2) "Returns true if the language of A is a subset of the language of A2." (if (singleton a) (if (singleton a2) (string= (singleton a) (singleton a2)) (run a2 (singleton a))) (empty-p (aintersection a (acomplement a2))))) (defmethod eqv ((a1 automaton) (a2 automaton) (s (eql +equalp-key-situation+))) "Returns true if the language of A1 is equal to the language of A2." (or (and (singleton a1) (singleton a2) (string= (singleton a1) (singleton a2))) (and (= (hash a1 s) (hash a2 s)) (subset-of a1 a2) (subset-of a2 a1)))) (defmethod hash ((a automaton) (s (eql +equalp-key-situation+))) "Returns the hash code for automaton A." (when (= (hash-code a) 0) (minimize a)) (hash-code a)) (defvar *print-renumerate-states* nil) (defmethod print-object ((a automaton) s) (let* ((a (if *print-renumerate-states* (clone a) a)) (states (states a))) (when *print-renumerate-states* (set-state-nums states)) (format s "~@~:>" (num (initial a)) (loop for st being the hash-keys of states collect st))) a) (defun clone-expanded (a) "Returns a clone of A, expanded if singleton." (let ((a (clone a))) (expand-singleton a) a)) (defmethod clone ((a automaton)) "Returns a clone of A." (let ((a2 (make-instance 'automaton))) (setf (minimization a2) (minimization a) (deterministic a2) (deterministic a) (info a2) (info a) (hash-code a2) (hash-code a) (minimize-always a2) (minimize-always a)) (if (singleton a) (setf (singleton a2) (singleton a)) (let ((map (make-hash-table)) (states (states a))) (loop for s being the hash-keys of states do (setf (gethash s map) (make-instance 'state))) (loop for s being the hash-keys of states do (let ((p (gethash s map))) (setf (accept p) (accept s)) (when (eq s (initial a)) (setf (initial a2) p)) (let ((p-table (transitions p))) (with-ht (tr nil) (transitions s) (htadd p-table (make-instance 'transition :minc (minc tr) :maxc (maxc tr) :to (gethash (to tr) map))))))))) a2)) (defun slnadd (sl q) "Adds state Q to state-list SL and returns a new state-list-node object." (make-instance 'state-list-node :q q :sl sl)) (defmethod initialize-instance :after ((sln state-list-node) &rest initargs) (declare (ignorable initargs)) (if (= (incf (size (sl sln))) 1) (setf (fst (sl sln)) sln (lst (sl sln)) sln) (setf (succ (lst (sl sln))) sln (pred sln) (lst (sl sln)) (lst (sl sln)) sln))) (defun slnremove (sln) "Removes state-list-node SLN from its state-list object." (decf (size (sl sln))) (if (eq sln (fst (sl sln))) (setf (fst (sl sln)) (succ sln)) (setf (succ (pred sln)) (succ sln))) (if (eq sln (lst (sl sln))) (setf (lst (sl sln)) (pred sln)) (setf (pred (succ sln)) (pred sln))))cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/cl-automaton/eqv-hash.txt0000640000175000017500000001313410524227664022550 0ustar pdmpdmRobert Strandh's Generalized Hash Table Proposal Background ---------- The standard specifies only four types of hash tables possible, according to whether the equality function is eq, eql, equal or equalp. Many applications need to define their own key hashing functions and key equality tests. This often becomes an exercise in transforming the desired key into something that is acceptable to one of these equality function. This proposal is for extending the concepts of hashing and equality so that the user can define application-specific extensions. Proposal -------- The idea is to introduce two new generic functions: hash object situation [generic function] eqv object1 object2 situation [generic function] The crucial idea (perhaps not original) is the last argument, a `key situation' which is an object that determines how objects are compared or hashed. Client code will typically write methods on these functions. The hash function must return a nonnegative fixnum[1]. Client code must respect the following invariant: (eqv object1 object2 situation) implies (= (hash object1 situation) (hash object2 situation)) There would be a number of predefined key situations, and methods to compare objects in these situations. For that, situations are organized into a hierarchy of CLOS classes. key-situation [protocol class] The base class for all key situations. builtin-key-situation [class] This class is a subclass of key-situation. All predefined situations are subclasses of builtin-key-situation. Client code is not allowed to alter or override the predefined methods for hash and eqv. The reason is that an implementation should be able to assume that it deals with the predefined methods and optimize compiled code by inlining them. eq-key-situation [class] This class is a subclass of builtin-key-situation. When eqv is called with an instance of this class as its third argument, it behaves like eq with respect to the first two arguments. +eq-key-situation+ [constant] This constant contains an instance of the class eq-key-situation. eql-key-situation [class] This class is a subclass of builtin-key-situation. When eqv is called with an instance of this class as its third argument, it behaves like eql with respect to the first two arguments. +eql-key-situation+ [constant] This constant contains an instance of the class eql-key-situation. equal-key-situation [class] This class is a subclass of builtin-key-situation. When eqv is called with an instance of this class as its third argument, it behaves like equal with respect to the first two arguments. +equal-key-situation+ [constant] This constant contains an instance of the class equal-key-situation. equalp-key-situation [class] This class is a subclass of builtin-key-situation. When eqv is called with an instance of this class as its third argument, it behaves like equalp with respect to the first two arguments. +equalp-key-situation+ [constant] This constant contains an instance of the class equalp-key-situation. case-sensitive-key-situation [class] This class is a subclass of builtin-key-situation. It is defined only when both object arguments are string designators. When eqv is called with an instance of this class, then it behaves like string=. +case-sensitive-key-situation+ [constant] This constant contains an instance of the class case-sensitive-key-situation. case-insensitive-key-situation [class] This class is a subclass of builtin-key-situation. It is defined only when both object arguments string designators. When eqv is called with an instance of this class, then it behaves like string-equal. +case-insensitive-key-situation+ [constant] This constant contains an instance of the class case-insensitive-key-situation. The proposal calls for a new type of hash table to be introduced: make-generalized-hash-table situation [function] returns a hash table that will call the `hash' generic function to hash the keys that are inserted in the table, and `eqv' to compare them. The situation that was passed to make-generalized-hash-table is used as the last argument to these functions. Two new functions are needed to access elements in the table, say: htref table key [function] (setf htref) object table key [function] Acknowledgments --------------- Thanks to Bruno Haible, Christophe Rhodes, Rudi Schlatte, and Aleksandar Bakic for their invaluable comments about many aspects of this proposal. Notes ----- [1] In most cases, the size of a fixnum is the size of a native integer minus 2 or 3 bits, and a native integer is usually capable of expressing the entire address space. It is therefore unlikely that we would need more different hash codes that the number of objects that will fit in the address space of the machine. And it is handy to be able to assume that a nonnegative fixnum is returned for performance reasons.cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/cl-automaton/eqv-hash.lisp0000640000175000017500000001036110562110261022661 0ustar pdmpdm;;; -*- Mode: Lisp; Package: AUTOMATON -*- ;;; ;;; (c) copyright 2005-2007 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; A naive attempt at implementing the protocol proposed by Robert ;;; Strandh (see eqv-hash.txt). (in-package :eqv-hash) ;;; Perhaps the term 'intention' is better than 'situation' (as in ;;; extensional vs. intentional equality, see ;;; http://www.htdp.org/2003-09-26/Book/curriculum-Z-H-52.html#node_chap_42). (defgeneric eqv (object1 object2 situation)) (defgeneric hash (object situation)) (defclass key-situation () ()) (defclass builtin-key-situation (key-situation) ()) (defclass eq-key-situation (builtin-key-situation) ()) (defparameter +eq-key-situation+ (make-instance 'eq-key-situation)) (defclass eql-key-situation (builtin-key-situation) ()) (defparameter +eql-key-situation+ (make-instance 'eql-key-situation)) (defclass equal-key-situation (builtin-key-situation) ()) (defparameter +equal-key-situation+ (make-instance 'equal-key-situation)) (defclass equalp-key-situation (builtin-key-situation) ()) (defparameter +equalp-key-situation+ (make-instance 'equalp-key-situation)) (defclass case-sensitive-key-situation (builtin-key-situation) ()) (defparameter +case-sensitive-key-situation+ (make-instance 'case-sensitive-key-situation)) (defclass case-insensitive-key-situation (builtin-key-situation) ()) (defparameter +case-insensitive-key-situation+ (make-instance 'case-insensitive-key-situation)) (defclass generalized-hash-table () ((ht :initform (make-hash-table) :reader ht) (cnt :initform 0 :accessor cnt) (situation :initarg :situation :reader situation))) (defun make-generalized-hash-table (situation) (make-instance 'generalized-hash-table :situation situation)) (defun htref (table key) (let* ((s (situation table)) (pair (assoc key (gethash (hash key s) (ht table)) :test #'(lambda (o1 o2) (eqv o1 o2 s))))) (if pair (values (cdr pair) t) (values nil nil)))) (defun (setf htref) (object table key) (let* ((ht (ht table)) (s (situation table)) (h (hash key s)) (p (assoc key (gethash h ht) :test #'(lambda (o1 o2) (eqv o1 o2 s))))) (if p (progn (rplaca p key) (rplacd p object)) (progn (push (cons key object) (gethash h ht)) (incf (cnt table))))) object) (defun htadd (table key) (setf (htref table key) t)) (defun htremove (table key) (let* ((ht (ht table)) (s (situation table)) (h (hash key s)) (b (remove key (gethash h ht) :key #'car :test #'(lambda (o1 o2) (eqv o1 o2 s))))) (if (eq b (gethash h ht)) nil (progn (decf (cnt table)) (if b (setf (gethash h ht) b) (remhash h ht)))))) (defun htpresent (table key) (multiple-value-bind (v v-p) (htref table key) (declare (ignore v)) v-p)) (defmacro with-ht ((key value) table &body body) (let ((bucket (gensym "BUCKET"))) `(loop for ,bucket being the hash-values of (ht ,table) do (loop for (,key . ,value) in ,bucket do ,@body)))) (defmacro with-ht-collect ((key value) table &body body) (let ((bucket (gensym "BUCKET"))) `(loop for ,bucket being the hash-values of (ht ,table) nconc (loop for (,key . ,value) in ,bucket collect ,@body)))) ;; By Bruno Haible: ;; (let ((hashcode-table ;; (make-hash-table :test #'eq ;; :key-type 't :value-type 'fixnum ;; :weak :key))) ;; (defmethod hash (obj (situation (eql +eq-key-situation))) ;; (or (gethash obj hashcode-table) ;; (setf (gethash obj hashcode-table) (random (+ most-positive-fixnum ;; 1))))))cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/cl-automaton/regexp.lisp0000640000175000017500000003567010705412617022462 0ustar pdmpdm;;; -*- Mode: Lisp; Package: AUTOMATON -*- ;;; ;;; (c) copyright 2005-2007 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Derived from dk.brics.automaton v1.8.1, (c) 2001-2005 by Anders M/oller ;;; - Some comments have been copied verbatim from the original code. ;;; Regular expressions are built from the following abstract syntax: ;;; regexp ::= unionexp ;;; unionexp ::= interexp | unionexp (union) ;;; | interexp ;;; interexp ::= concatexp & interexp (intersection) [OPTIONAL] ;;; | concatexp ;;; concatexp ::= repeatexp concatexp (concatenation) ;;; | repeatexp ;;; repeatexp ::= repeatexp ? (zero or one occurrence) ;;; | repeatexp * (zero or more occurrences) ;;; | repeatexp + (one or more occurrences) ;;; | repeatexp {n} (n occurrences) ;;; | repeatexp {n,} (n or more occurrences) ;;; | repeatexp {n,m} (n to m occurrences, including both) ;;; | complexp ;;; complexp ::= ~ complexp (complement) [OPTIONAL] ;;; | charclassexp ;;; charclassexp ::= [ charclasses ] (character class) ;;; | [^ charclasses ] (negated character class) ;;; | simpleexp ;;; charclasses ::= charclass charclasses ;;; | charclass ;;; charclass ::= charexp - charexp (character range, including end-points) ;;; | charexp ;;; simpleexp ::= charexp ;;; | . (any single character) ;;; | # (the empty language) [OPTIONAL] ;;; | @ (any string) [OPTIONAL] ;;; | " " (a string) ;;; | ( ) (the empty string) ;;; | ( unionexp ) (precedence override) ;;; | < > (named automaton) [OPTIONAL] ;;; | (numerical interval) [OPTIONAL] ;;; charexp ::= (a single non-reserved character) ;;; | \ (a single character) ;;; The productions marked [OPTIONAL] are only allowed if specified by ;;; the syntax flags passed to the string-regexp constructor. The ;;; reserved characters used in the (enabled) syntax must be escaped ;;; with backslash (\) or double-quotes ("..."). (In contrast to other ;;; regexp syntaxes, this is required also in character classes.) Be ;;; aware that dash (-) has a special meaning in charclass ;;; expressions. An identifier is a string not containing right angle ;;; bracket (>) or dash (-). Numerical intervals are specified by ;;; non-negative decimal integers and include both end points, and if ;;; n and m have the same number of digits, then the conforming ;;; strings must have that length (i.e. prefixed by 0's). (in-package :automaton) (deftype kind () '(member nil :union :concatenation :intersection :optional :repeat :repeat-min :repeat-minmax :complement :char :char-range :anychar :empty :string :anystring :automaton :interval)) (defconstant +intersection+ #x0001) ; enables intersection (&) (defconstant +complement+ #x0002) ; enables complement (~) (defconstant +empty+ #x0004) ; enables empty language (#) (defconstant +anystring+ #x0008) ; enables anystring (@) (defconstant +automaton+ #x0010) ; enables named automaton () (defconstant +interval+ #x0020) ; enables numerical intervals (n-m) (defconstant +all+ #xffff) ; enables all optional syntax (defconstant +none+ #x0000) ; enables no optional syntax (deftype flags-type () `(integer ,+none+ ,+all+)) (defclass regexp () ((kind :initform nil :initarg :kind :reader kind :type kind) (exp1 :initform nil :initarg :exp1 :reader exp1 :type (or null regexp)) (exp2 :initform nil :initarg :exp2 :reader exp2 :type (or null regexp)) (text :initform nil :initarg :text :reader text :type (or null string)) (s :initform nil :initarg :s :reader s :type (or null string)) (c :initform nil :initarg :c :reader c :type (or null character)) (minr :initform nil :initarg :minr :reader minr :type (or null fixnum)) (maxr :initform nil :initarg :maxr :reader maxr :type (or null fixnum)) (digits :initform nil :initarg :digits :reader digits :type (or null fixnum)) (from :initform nil :initarg :from :reader from :type (or null character)) (to :initform nil :initarg :to :reader to :type (or null character)) (flags :initform +all+ :initarg :flags :reader flags :type flags-type) (pos :initform 0 :initarg :pos :accessor pos :type integer))) (defun regexp-equal (r1 r2) ; for testing (or (eq r1 r2) (and (eq (kind r1) (kind r2)) (regexp-equal (exp1 r1) (exp1 r2)) (regexp-equal (exp2 r1) (exp2 r2)) (equal (s r1) (s r2)) (eql (c r1) (c r2)) (eql (minr r1) (minr r2)) (eql (maxr r1) (maxr r2)) (eql (digits r1) (digits r2)) (eql (from r1) (from r2)) (eql (to r1) (to r2)) (eql (flags r1) (flags r2))))) (defun string-regexp (s &optional fs) "Returns a new regexp object corresponding to regular expression string S. FS is a logior or optional syntax flags." (let* ((r (make-instance 'regexp :text s :flags (or fs +all+))) (e (parse-union-exp r))) (when (more r) (error "end of string expected at position ~A" (pos r))) e)) (defun regexp-automaton (r &optional as) "Returns a new automaton object corresponding to regexp R. AS is a hash table mapping from identifiers to auxiliary named automata. (An error is signaled if R uses an identifier not in AS.) The constructed automaton is deterministic and minimal, and has no transitions to dead states." (let ((a (ecase (kind r) (:union (aunion (regexp-automaton (exp1 r) as) (regexp-automaton (exp2 r) as))) (:concatenation (aconcatenate (regexp-automaton (exp1 r) as) (regexp-automaton (exp2 r) as))) (:intersection (aintersection (regexp-automaton (exp1 r) as) (regexp-automaton (exp2 r) as))) (:optional (optional (regexp-automaton (exp1 r) as))) (:repeat (repeat (regexp-automaton (exp1 r) as))) (:repeat-min (repeat-min (regexp-automaton (exp1 r) as) (minr r))) (:repeat-minmax (repeat-minmax (regexp-automaton (exp1 r) as) (minr r) (maxr r))) (:complement (acomplement (regexp-automaton (exp1 r) as))) (:char (char-automaton (char-code (c r)))) (:char-range (char-range-automaton (char-code (from r)) (char-code (to r)))) (:anychar (any-char-automaton)) (:empty (empty-automaton)) (:string (string-automaton (s r))) (:anystring (any-string-automaton)) (:automaton (let ((aa (gethash (s r) as))) (if aa (clone aa) (error "~A not found" (s r))))) (:interval (interval-automaton (minr r) (maxr r) (digits r)))))) (minimize a))) (defmethod print-object ((r regexp) s) (ecase (kind r) (:union (princ "(" s) (print-object (exp1 r) s) (princ "\|" s) (print-object (exp2 r) s) (princ ")" s)) (:concatenation (print-object (exp1 r) s) (print-object (exp2 r) s)) (:intersection (princ "(" s) (print-object (exp1 r) s) (princ "&" s) (print-object (exp2 r) s) (princ ")" s)) (:optional (princ "(" s) (print-object (exp1 r) s) (princ ")?" s)) (:repeat (princ "(" s) (print-object (exp1 r) s) (princ ")*" s)) (:repeat-min (princ "(" s) (print-object (exp1 r) s) (princ "){" s) (princ (minr r) s) (princ ",}" s)) (:repeat-minmax (princ "(" s) (print-object (exp1 r) s) (princ "){" s) (princ (minr r) s) (princ "," s) (princ (maxr r) s) (princ "}" s)) (:complement (princ "~(" s) (print-object (exp1 r) s) (princ ")" s)) (:char (princ "\\" s) (princ (c r) s)) (:char-range (princ "[\\" s) (princ (from r) s) (princ "-\\" s) (princ (to r) s) (princ "]" s)) (:anychar (princ "." s)) (:empty (princ "#" s)) (:string (princ "\"" s) (princ (s r) s) (princ "\"" s)) (:anystring (princ "@" s)) (:automaton (princ "<" s) (princ (s r) s) (princ ">" s)) (:interval (princ "<" s) (format s "~V,'0D" (digits r) (minr r)) (princ "-" s) (format s "~V,'0D" (digits r) (maxr r)) (princ ">" s)))) (defun more (r) (< (pos r) (length (text r)))) (defun peek (r s) (and (more r) (position (aref (text r) (pos r)) s))) (defun match (r c) (and (more r) (char= (aref (text r) (pos r)) c) (incf (pos r)))) (defun next (r) (if (more r) (prog1 (aref (text r) (pos r)) (incf (pos r))) (error "unexpected end of string"))) (defun check (r flag) (not (= (logand (flags r) flag) 0))) (defun make-regexp (kind &optional e1 e2) (make-instance 'regexp :kind kind :exp1 e1 :exp2 e2)) (defun parse-union-exp (r) (let ((e (parse-intersection-exp r))) (if (match r #\|) (make-regexp :union e (parse-union-exp r)) e))) (defun parse-intersection-exp (r) (let ((e (parse-concatenation-exp r))) (if (and (check r +intersection+) (match r #\&)) (make-regexp :intersection e (parse-intersection-exp r)) e))) (defun parse-concatenation-exp (r) (let ((e (parse-repeat-exp r))) (if (and (more r) (not (peek r ")&\|"))) (let* ((ee (parse-concatenation-exp r)) (ee1 (exp1 ee))) (cond ; optimizations? ((and (member (kind e) '(:string :char)) (eq (kind ee) :concatenation) (member (kind ee1) '(:string :char))) (let ((ss (format nil "~A~A" (if (eq (kind e) :string) (s e) (c e)) (if (eq (kind ee1) :string) (s ee1) (c ee1))))) (if (position #\" ss) (make-regexp :concatenation (make-instance 'regexp :kind :string :s ss) (exp2 ee)) (make-regexp :concatenation e ee)))) ((and (member (kind e) '(:string :char)) (member (kind ee) '(:string :char))) (let ((ss (format nil "~A~A" (if (eq (kind e) :string) (s e) (c e)) (if (eq (kind ee) :string) (s ee) (c ee))))) (if (position #\" ss) (make-regexp :concatenation e ee) (make-instance 'regexp :kind :string :s ss)))) (t (make-regexp :concatenation e ee)))) e))) (defun parse-repeat-exp (r) (let ((e (parse-complement-exp r))) (loop while (peek r "?*+{") do (cond ((match r #\?) (setq e (make-regexp :optional e))) ((match r #\*) (setq e (make-regexp :repeat e))) ((match r #\+) (setq e (make-instance 'regexp :kind :repeat-min :exp1 e :minr 1))) ((match r #\{) (let ((start (pos r))) (loop while (peek r "0123456789") do (next r)) (when (= start (pos r)) (error "integer expected at position ~A" (pos r))) (let ((n (parse-integer (text r) :start start :end (pos r))) (m nil)) (if (match r #\,) (let ((start (pos r))) (loop while (peek r "0123456789") do (next r)) (when (/= start (pos r)) (setq m (parse-integer (text r) :start start :end (pos r))))) (setq m n)) (unless (match r #\}) (error "expected '}' at positiion ~A" (pos r))) (return-from parse-repeat-exp (if m (make-instance 'regexp :kind :repeat-minmax :exp1 e :minr n :maxr m) (make-instance 'regexp :kind :repeat-min :exp1 e :minr n))))))) finally (return e)))) (defun parse-complement-exp (r) (if (and (check r +complement+) (match r #\~)) (make-regexp :complement (parse-complement-exp r)) (parse-char-class-exp r))) (defun parse-char-class-exp (r) (if (match r #\[) (let ((negate (match r #\^)) (e (parse-char-classes r))) (unless (match r #\]) (error "expected ']' at position ~A" (pos r))) (if negate (make-regexp :intersection (make-regexp :anychar) (make-regexp :complement e)) e)) (parse-simple-exp r))) (defun parse-char-classes (r) (let ((e (parse-char-class r))) (loop while (and (more r) (not (peek r "]"))) do (setq e (make-regexp :union e (parse-char-class r))) finally (return e)))) (defun parse-char-class (r) (let ((c (parse-char-exp r))) (if (match r #\-) (make-instance 'regexp :kind :char-range :from c :to (parse-char-exp r)) (make-instance 'regexp :kind :char :c c)))) (defun parse-simple-exp (r) (cond ((match r #\.) (make-regexp :anychar)) ((and (check r +empty+) (match r #\#)) (make-regexp :empty)) ((and (check r +anystring+) (match r #\@)) (make-regexp :anystring)) ((match r #\") (let ((start (pos r))) (loop while (and (more r) (not (peek r "\""))) do (next r)) (unless (match r #\") (error "expected '\"' at position ~A" (pos r))) (make-instance 'regexp :kind :string :s (subseq (text r) start (1- (pos r)))))) ((match r #\() (if (match r #\)) (make-instance 'regexp :kind :string :s "") (let ((e (parse-union-exp r))) (unless (match r #\)) (error "expected ')' at position ~A" (pos r))) e))) ((and (or (check r +automaton+) (check r +interval+)) (match r #\<)) (let ((start (pos r))) (loop while (and (more r) (not (peek r ">"))) do (next r)) (unless (match r #\>) (error "expected '>' at position ~A" (pos r))) (let* ((s (subseq (text r) start (1- (pos r)))) (i (position #\- s))) (if i (progn (unless (check r +interval+) (error "illegal identifier at position ~A" (1- (pos r)))) (handler-bind ((error #'(lambda (c) (error "interval syntax error at position ~A (~A)" (1- (pos r)) c)))) (when (or (= i 0) (= i (length s)) (/= i (position #\- s :from-end t))) (error "number format exception")) (let* ((smin (subseq s 0 i)) (smax (subseq s (1+ i))) (imin (parse-integer smin)) (imax (parse-integer smax)) (digs (if (= (length smin) (length smax)) (length smin) 0))) (when (> imin imax) (rotatef imin imax)) (make-instance 'regexp :kind :interval :minr imin :maxr imax :digits digs)))) (if (check r +automaton+) (make-instance 'regexp :kind :automaton :s s) (error "interval syntax error at position ~A" (1- (pos r)))))))) (t (make-instance 'regexp :kind :char :c (parse-char-exp r))))) (defun parse-char-exp (r) (match r #\\) (next r))cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/cl-automaton/state-and-transition.lisp0000640000175000017500000001762010705412617025233 0ustar pdmpdm;;; -*- Mode: Lisp; Package: AUTOMATON -*- ;;; ;;; (c) copyright 2005-2007 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Derived from dk.brics.automaton v1.8.1, (c) 2001-2005 by Anders M/oller (in-package :automaton) (defconstant +min-char-code+ 0) (defconstant +max-char-code+ (1- char-code-limit)) ;;; In Allegro (for one), defconstants aren't available as values at compile ;;; time. (deftype char-code-type () `(integer 0 ,(1- char-code-limit))) (defclass state () ((accept :initform nil :accessor accept :type boolean) (transitions :accessor transitions :type generalized-hash-table) (num :initform 0 :accessor num :type fixnum) (id :accessor id :type fixnum) (next-id :allocation :class :initform -1 :accessor next-id :type fixnum))) (declaim (special *state-ht*)) (defun state-equal (s1 s2) ; for testing, assuming minimization (multiple-value-bind (se se-p) (gethash (cons s1 s2) *state-ht*) ; TODO: consider (cons s2 s1), too (if se-p se (setf (gethash (cons s1 s2) *state-ht*) t ; bound recursion temporarily (gethash (cons s1 s2) *state-ht*) (and (eq (accept s1) (accept s2)) (transitions-equal (transitions s1) (transitions s2))))))) (declaim (special *to-first*)) (defun transitions-equal (ts1 ts2) ; for testing, assuming minimization (let* ((*to-first* nil) (tss1 (sort (with-ht-collect (t1 nil) ts1 t1) #'transition<)) (tss2 (sort (with-ht-collect (t2 nil) ts2 t2) #'transition<))) (flet ((%transition-equal (t1 t2) (with-slots ((minc1 minc) (maxc1 maxc) (to1 to)) t1 (with-slots ((minc2 minc) (maxc2 maxc) (to2 to)) t2 (and (= minc1 minc2) (= maxc1 maxc2) (state-equal to1 to2)))))) (and (= (length tss1) (length tss2)) (loop for t1 in tss1 and t2 in tss2 always (%transition-equal t1 t2)))))) (defclass state-pair () ((s :initarg :s :accessor s :type (or null state)) (s1 :initarg :s1 :accessor s1 :type state) (s2 :initarg :s2 :accessor s2 :type state))) (defclass transition () ((minc :initarg :minc :accessor minc :type char-code-type) (maxc :initarg :maxc :accessor maxc :type char-code-type) (to :initarg :to :accessor to :type state))) (defclass state-set () ((ht :initform (make-hash-table) :initarg :ht :accessor ht :type hash-table))) (defmethod initialize-instance :after ((s state) &rest initargs) (declare (ignorable initargs)) (with-slots (transitions id next-id) s (setf transitions (make-generalized-hash-table +equalp-key-situation+) id (incf next-id)))) (defmethod initialize-instance :after ((tr transition) &rest initargs) (declare (ignorable initargs)) (with-slots (minc maxc to) tr (cond ((not minc) (assert maxc nil "MINC or MAXC required") (setf minc maxc)) ((not maxc) (assert minc nil "MINC or MAXC required") (setf maxc minc)) ((> minc maxc) (rotatef minc maxc))) (assert to nil "TO required"))) (defmethod eqv ((sp1 state-pair) (sp2 state-pair) (s (eql +equalp-key-situation+))) (and (eq (s1 sp1) (s1 sp2)) (eq (s2 sp1) (s2 sp2)))) (defmethod hash ((sp state-pair) (s (eql +equalp-key-situation+))) "Returns the hash code for state-pair SP." (the fixnum (mod (+ (sxhash (s1 sp)) (sxhash (s2 sp))) most-positive-fixnum))) (defmethod eqv ((tr1 transition) (tr2 transition) (s (eql +equalp-key-situation+))) "Returns true if transitions TR1 and TR2 have equal interval and same (eq) destination state." (with-slots ((minc1 minc) (maxc1 maxc) (to1 to)) tr1 (with-slots ((minc2 minc) (maxc2 maxc) (to2 to)) tr2 (and (= minc1 minc2) (= maxc1 maxc2) (eq to1 to2))))) (defmethod hash ((tr transition) (s (eql +equalp-key-situation+))) "Returns the hash code for transition TR." (with-slots (minc maxc) tr (the fixnum (mod (+ (* 2 minc) (* 3 maxc)) most-positive-fixnum)))) (defmethod clone ((tr transition)) "Returns a clone of TR." (with-slots (minc maxc to) tr (make-instance 'transition :minc minc :maxc maxc :to to))) (defmethod eqv ((ss1 state-set) (ss2 state-set) (s (eql +equalp-key-situation+))) "Returns true if state-set objects SS1 and SS2 contain the same (eql) state objects." (and (= (hash-table-count (ht ss1)) (hash-table-count (ht ss2))) (loop for st being the hash-keys of (ht ss1) always (gethash st (ht ss2))))) (defmethod hash ((ss state-set) (s (eql +equalp-key-situation+))) "Returns the hash code for state-set SS." (the fixnum (mod (loop for st being the hash-keys of (ht ss) sum (sxhash st)) most-positive-fixnum))) (defvar *escape-unicode-chars* nil) ; true may be useful in Slime (defun escaped-char (c) (if (or (not *escape-unicode-chars*) (and (<= #x21 c #x7e) (/= c (char-code #\\)))) (code-char c) (format nil "\\u~4,'0O" c))) (defmethod print-object ((st state) s) (with-slots (accept transitions num) st (format s "~@~:>" num (if accept "accept" "reject") (with-ht-collect (tr nil) transitions tr))) st) (defmethod print-object ((tr transition) s) (with-slots (minc maxc to) tr (format s "~@<~A~:[~*~;-~A~] -> ~A~:>" (escaped-char minc) (/= minc maxc) (escaped-char maxc) (num to)) tr)) (defun transition< (tr1 tr2) "Returns true if TR1 is strictly less than TR2. If *TO-FIRST* special variable is bound to true, the values of the destination states' NUM slots are compared first, followed by the intervals comparison. The intervals comparison is done as follows: the lower interval bounds are compared first, followed by reversed upper interval bounds comparisons. If *TO-FIRST* is bound to nil, the interval comparison is done first, followed by the NUM comparisons." (with-slots ((minc1 minc) (maxc1 maxc) (to1 to)) tr1 (with-slots ((minc2 minc) (maxc2 maxc) (to2 to)) tr2 (let ((to< (< (num to1) (num to2))) (to= (= (num to1) (num to2))) (min-rmax< (or (< minc1 minc2) (and (= minc1 minc2) (> maxc1 maxc2)))) (min-rmax= (and (= minc1 minc2) (= maxc1 maxc2)))) (if *to-first* (or to< (and to= min-rmax<)) (or min-rmax< (and min-rmax= to<))))))) (defun reset-transitions (s) (setf (transitions s) (make-generalized-hash-table +equalp-key-situation+))) (defun sstep (s c) "Returns a state reachable from S, given the input character code C." (with-ht (tr nil) (transitions s) (when (<= (minc tr) (char-code c) (maxc tr)) (return-from sstep (to tr))))) (defun add-epsilon (s to) "Adds transitions of state TO to state S. Also, if TO accepts, so does S." (when (accept to) (setf (accept s) t)) (let ((s-table (transitions s))) (with-ht (tr nil) (transitions to) (htadd s-table tr)))) (defun sorted-transition-vector (s *to-first*) "Returns a vector of all transitions of S, sorted using TRANSITION< and *TO-FIRST*." (let ((v (make-array `(,(cnt (transitions s))) :element-type '(or null transition))) (i -1)) (sort (progn (with-ht (tr nil) (transitions s) (setf (aref v (incf i)) tr)) v) #'transition<))) (defun sorted-transition-list (s *to-first*) "Returns a list of all transitions of S, sorted using TRANSITION< and *TO-FIRST*." (sort (with-ht-collect (tr nil) (transitions s) tr) #'transition<))cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/lisp-syntax-swine.lisp0000644000175000017500000016304511345155772022214 0ustar pdmpdm;;; -*- Mode: Lisp; Package: DREI-LISP-SYNTAX -*- ;;; (c) copyright 2005 by ;;; Robert Strandh (strandh@labri.fr) ;;; (c) copyright 2006-2007 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Functionality designed to aid development of Common Lisp code. (in-package :drei-lisp-syntax) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Compiler note hyperlinking (defun make-compiler-note (note-list) (let ((severity (getf note-list :severity)) (message (getf note-list :message)) (location (getf note-list :location)) (references (getf note-list :references)) (short-message (getf note-list :short-message))) (make-instance (ecase severity (:error 'error-compiler-note) (:read-error 'read-error-compiler-note) (:warning 'warning-compiler-note) (:style-warning 'style-warning-compiler-note) (:note 'note-compiler-note)) :message message :location location :references references :short-message short-message))) (defclass compiler-note () ((message :initarg :message :initform nil :accessor message) (location :initarg :location :initform nil :accessor location) (references :initarg :references :initform nil :accessor references) (short-message :initarg :short-message :initform nil :accessor short-message)) (:documentation "The base for all compiler-notes.")) (defclass error-compiler-note (compiler-note) ()) (defclass read-error-compiler-note (compiler-note) ()) (defclass warning-compiler-note (compiler-note) ()) (defclass style-warning-compiler-note (compiler-note) ()) (defclass note-compiler-note (compiler-note) ()) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Code interrogation/form analysis (defgeneric parameter-match-p (parameter arg-indices &key &allow-other-keys) (:method ((parameter parameter) (arg-indices list) &key) nil) (:method :around ((parameter parameter) (arg-indices null) &key) nil)) (defmethod parameter-match-p ((parameter named-parameter) (arg-indices list) &key) (and (= (caar arg-indices) (min-arg-index parameter)) (null (rest arg-indices)))) (defmethod parameter-match-p ((parameter rest-parameter) (arg-indices list) &key) (and (>= (caar arg-indices) (min-arg-index parameter)) (null (rest arg-indices)))) (defmethod parameter-match-p ((parameter keyword-parameter) (arg-indices list) &key allow-other-keys) (let* ((index (caar arg-indices)) (preceding-arg-p (rest (first arg-indices))) (preceding-arg (first preceding-arg-p))) (and (>= index (min-arg-index parameter)) preceding-arg-p (or allow-other-keys (eq (keyword-name parameter) preceding-arg))))) (defmethod parameter-match-p ((parameter destructuring-parameter) (arg-indices list) &key) (and (= (caar arg-indices) (min-arg-index parameter)) (not (null (rest arg-indices))))) (defmethod parameter-match-p ((parameter destructuring-keyword-parameter) (arg-indices list) &key allow-other-keys) (let* ((index (caar arg-indices)) (preceding-arg-p (rest (first arg-indices))) (preceding-arg (first preceding-arg-p))) (and (>= index (min-arg-index parameter)) preceding-arg-p (or allow-other-keys (eq (keyword-name parameter) preceding-arg))))) (defun find-affected-parameters (lambda-list arg-indices) "Find the parameters of `lambda-list' that would be affected if an argument was entered at index `arg-indices' in the argument list of the form with lambda list `lambda-list'. If `arg-indices' is nil, no calculation will be done (this function will just return NIL). This function returns two values: The primary value is a list of symbols that should be emphasized, the secondary value is a list of symbols that should be highlighted." (let ((affected-parameters '())) (loop for parameter in (all-parameters lambda-list) do (etypecase parameter (destructuring-keyword-parameter (when (parameter-match-p parameter arg-indices) (if (null (rest arg-indices)) (push parameter affected-parameters) (setf affected-parameters (nconc (list parameter) (find-affected-parameters (inner-lambda-list parameter) (rest arg-indices)) affected-parameters))))) (keyword-parameter (when (parameter-match-p parameter arg-indices) (push parameter affected-parameters))) (destructuring-parameter (when (parameter-match-p parameter arg-indices) (setf affected-parameters (nconc (find-affected-parameters (inner-lambda-list parameter) (rest arg-indices)) affected-parameters)))) (rest-parameter (when (parameter-match-p parameter arg-indices) (push parameter affected-parameters))) (named-parameter (when (parameter-match-p parameter arg-indices) (push parameter affected-parameters)))) finally (return affected-parameters)))) (defgeneric analyze-lambda-list (lambda-list current-arg-indices) (:documentation "Analyze lambda list and information about provided arguments, and provide information for highlighting it. `Arglist' is the argument list that is to be analyzed, `current-arg-index' is the argument index where the next argument would be written (0 is just after the operator). A single value is returned: a list of parameters that should be highlighted.")) (defmethod analyze-lambda-list ((lambda-list lambda-list) (current-arg-indices list)) (find-affected-parameters lambda-list current-arg-indices)) (defun find-argument-indices-for-operand (syntax operand-form full-form) "Return a list of argument indices for `argument-form' relative to the operator of `full-form'. These lists take the form of ((n x1) (m x2) (p x3)), which means (list-aref form-operand-list n m p), and where x1...xN is the argument preceding the argument at the index. If there is no preceding argument, this list may have just a single element. A list of argument indices can have arbitrary length (but they are practically always at most 2 elements long)." (let ((operator-form (first-form (children full-form)))) (labels ((worker (operand-form) ;; Cannot find index for top-level-form. (unless (or (eq operand-form operator-form) (form-at-top-level-p operand-form)) (let* ((parent-operator (first-form (children (parent operand-form)))) (form-operand-list (remove-if #'(lambda (form) (or (not (formp form)) (eq form operator-form))) (children (parent operand-form)))) (operand-position (or (position operand-form form-operand-list) (count-if #'(lambda (form) (<= (start-offset form) (start-offset operand-form))) form-operand-list)))) ;; If we find anything, we have to increment the ;; position by 1, since we consider the existance ;; of a first operand to mean point is at operand ;; 2. Likewise, a position of nil is interpreted ;; as 0. (cons (cons (or operand-position 0) (when (and operand-position (plusp operand-position)) (list (form-to-object syntax (elt form-operand-list (1- operand-position)))))) (when (not (eq operator-form parent-operator)) (worker (parent operand-form)))))))) (nreverse (worker operand-form))))) (defclass placeholder-form (form) ((start-offset :accessor start-offset) (end-offset :accessor end-offset))) (defun find-operand-info (syntax mark-or-offset full-form) "Returns the path from the operator of `full-form' to the operand at `mark-or-offset'. If there is no operand at this position, pretend there is and calculate the path." (as-offsets ((offset mark-or-offset)) (let ((indexing-start-arg (let ((candidate (form-around syntax offset))) (if (or (and (form-list-p candidate) (not (or (eq candidate (form-before syntax offset)) (eq candidate (form-after syntax offset))))) (null candidate)) (let ((obj (make-instance 'placeholder-form))) (setf (parent obj) candidate (start-offset obj) offset (end-offset obj) offset) obj) candidate)))) (find-argument-indices-for-operand syntax indexing-start-arg full-form)))) (defun valid-operator-p (operator) "Check whether or not `operator' is a valid operator. `Operator' is considered a valid operator if it is a symbol bound to a function, or if it is a lambda expression." (cond ((symbolp operator) (or (fboundp operator) (macro-function operator) (special-operator-p operator))) ((listp operator) (and (eq (first operator) 'cl:lambda) (not (null (rest operator))) (listp (second operator)))))) (defgeneric indices-match-arglist (lambda-list arg-indices) (:documentation "Check whether the argument indices `arg-indices' could refer to a direct argument for the operator with the lambda list `lambda-list'. Returns T if they could, NIL otherwise. Does not check for the validity of keyword arguments.")) (defmethod indices-match-arglist ((lambda-list semiordinary-lambda-list) (arg-indices list)) (and arg-indices (null (rest arg-indices)) (or (> (+ (length (required-parameters lambda-list)) (length (optional-parameters lambda-list))) (caar arg-indices)) (rest-parameter lambda-list) (keyword-parameters lambda-list)) t)) (defmethod indices-match-arglist ((lambda-list macro-lambda-list) (arg-indices list)) (or (some #'(lambda (parameter) (and (parameter-match-p parameter arg-indices :allow-other-keys t) (or (not (typep parameter 'destructuring-parameter)) (null (rest arg-indices)) (indices-match-arglist (inner-lambda-list parameter) (rest arg-indices))))) (all-parameters lambda-list)) (call-next-method))) (defun direct-arg-p (syntax full-form arg-form) "Is `arg-form' a direct argument to the operator in `full-form'? A \"direct argument\" is defined as an argument that would be directly bound to a symbol when evaluating the operators body, or as an argument that would be a direct component of a &body or &rest argument, or as an argument that would be a destructuring argument." (let* ((operator-form (first-form (children full-form))) (operator (form-to-object syntax operator-form))) (and ;; An operator is not an argument to itself. (not (eq arg-form operator-form)) ;; An operator must be valid. (valid-operator-p operator) ;; The argument must match the operators argument list. (indices-match-arglist (arglist-for-form syntax operator) (find-operand-info syntax (start-offset arg-form) full-form))))) (defun find-direct-operator (syntax arg-form) "Check whether `arg-form' is a direct argument to one of its parents. If it is, return the form with the operator that `arg-form' is a direct argument to. If not, return NIL." (labels ((recurse (form) ;; Check whether `arg-form' is a direct argument to ;; the operator of `form'. (when (parent form) (if (direct-arg-p syntax form arg-form) form (recurse (parent form)))))) (recurse (parent arg-form)))) (defun find-applicable-form (syntax arg-form) "Find the enclosing form that has `arg-form' as a valid argument. Return NIL if none can be found." ;; The algorithm for finding the applicable form: ;; ;; From `arg-form', we wander up the tree looking at enclosing ;; forms, until we find a a form with an operator, the ;; form-operator, that has `arg-form' as a direct argument (this is ;; checked by comparing argument indices for `arg-form', relative to ;; form-operator, with the arglist ofform-operator). However, if ;; form-operator itself is a direct argument to one of its parents, ;; we ignore it (unless form-operators form-operator is itself a ;; direct argument, etc). This is so we can properly handle ;; nested/destructuring argument lists such as those found in ;; macros. (labels ((recurse (candidate-form) (if (and (direct-arg-p syntax candidate-form arg-form) (not (find-applicable-form syntax (first-form (children candidate-form))))) candidate-form (unless (form-at-top-level-p candidate-form) (recurse (parent candidate-form)))))) (unless (form-at-top-level-p arg-form) (recurse (parent arg-form))))) (defgeneric relevant-keywords (lambda-list arg-indices) (:documentation "Return a list of the keyword arguments that it would make sense to use at the position `arg-indices' relative to the operator that has the argument list `arglist'.")) (defmethod relevant-keywords ((lambda-list semiordinary-lambda-list) (arg-indices list)) (let ((keyword-parameters (keyword-parameters lambda-list))) (when (and (null (rest arg-indices)) keyword-parameters (>= (caar arg-indices) (min-arg-index (first keyword-parameters)))) (mapcar #'keyword-name keyword-parameters)))) (defmethod relevant-keywords ((lambda-list macro-lambda-list) (arg-indices list)) (or (call-next-method) (unless (null (rest arg-indices)) (let ((parameter (find-if #'(lambda (parameter) (parameter-match-p parameter arg-indices)) (append (required-parameters lambda-list) (optional-parameters lambda-list) (keyword-parameters lambda-list))))) (when parameter (relevant-keywords (inner-lambda-list parameter) (rest arg-indices))))))) (defgeneric possible-completions (syntax operator string package operands indices) (:documentation "Get the applicable completions for completing `string' (which should a string of the, possibly partial, symbol name to be completed) in `package', which is part of a form with the operator `operator' (which should be a valid operator object), and which has the operands `operands'. `Indices' should be the argument indices from the operator to `token' (see `find-argument-indices-for-operands').") (:method ((syntax lisp-syntax) operator (string string) (package package) (operands list) (indices list)) (let ((completions (first (simple-completions (get-usable-image syntax) string package)))) ;; Welcome to the ugly mess! Part of the uglyness is that we ;; depend on Swank do to our nonobvious completion (m-v-b -> ;; multiple-value-bind). (or (when (valid-operator-p operator) (let* ((relevant-keywords (relevant-keywords (arglist-for-form syntax operator operands) indices)) (keyword-completions (mapcar #'(lambda (a) (string-downcase (format nil ":~A" a))) relevant-keywords))) (when relevant-keywords ;; We need Swank to get the concrete list of ;; possibilities, but after that, we need to filter ;; out anything that is not a relevant keyword ;; argument. ALSO, if `string' is blank, Swank will ;; "helpfully" not put any keyword symbols in ;; `completions', thus ruining this entire scheme. SO, ;; we have to force Swank to give us a list of keyword ;; symbols and use that instead of `completions'. Joy! (intersection (mapcar #'string-downcase (if (string= string "") (first (simple-completions (get-usable-image syntax) ":" package)) completions)) keyword-completions :key #'string-downcase :test #'string=)))) completions)))) (defgeneric complete-argument-of-type (argument-type syntax string all-completions) (:documentation "") (:method (argument-type syntax string all-completions) all-completions)) (defgeneric modify-argument-list (argument-type syntax arglist arguments arg-position) (:documentation "") (:method (syntax argument-type arglist arguments arg-position) arglist)) (defmacro define-argument-type (name (&optional inherit-from) &rest options) "Define an argument type for use in `define-form-traits'." (let ((completion-code (rest (assoc :completion options))) (modification-code (rest (assoc :arglist-modification options)))) (assert (or (null completion-code) (= (length (first completion-code)) 3))) (assert (or (null modification-code) (= (length (first modification-code)) 4))) `(progn ,(if (or completion-code inherit-from) (let ((lambda-list (if completion-code (first completion-code) '(argument-type syntax token all-completions)))) `(defmethod complete-argument-of-type ((argument-type (eql ',name)) ,@lambda-list) ,@(or (rest completion-code) `((complete-argument-of-type ',inherit-from ,@lambda-list))))) ;; If no completion rule has been specified for this ;; type, we must check whether an earlier definition had ;; completion rules - if so, remove the method ;; implementing the rules. `(let ((method (find-method #'complete-argument-of-type nil `((eql ,name) t t t) nil))) (when method (remove-method #'complete-argument-of-type method)))) ,(if (or modification-code inherit-from) (let ((lambda-list (if modification-code (first modification-code) '(syntax arglist arguments arg-position)))) `(defmethod modify-argument-list ((argument-type (eql ',name)) ,@lambda-list) ,@(or (rest modification-code) `((modify-argument-list ',inherit-from ,@lambda-list))))) ;; If no arglist modification rule has been specified ;; for this type, we must check whether an earlier ;; definition had arglist modification rules - if so, ;; remove the method implementing the rules. `(let ((method (find-method #'modify-argument-list nil '((eql ,name) t t t t) nil))) (when method (remove-method #'modify-argument-list method))))))) (define-argument-type class-name () (:completion (syntax string all-completions) (let ((all-lower (every #'lower-case-p string))) (loop for completion in all-completions when (find-class (ignore-errors (read-from-string completion)) nil) collect (if all-lower (string-downcase completion) completion)))) (:arglist-modification (syntax arglist arguments arg-position) (if (and (> (length arguments) arg-position) (listp (elt arguments arg-position)) (> (length (elt arguments arg-position)) 1) (eq (first (elt arguments arg-position)) 'cl:quote) (find-class (second (elt arguments arg-position)) nil)) (make-lambda-list :defaults arglist :keyword-parameters (mapcar #'(lambda (parameter-data) (make-&key-parameter parameter-data (positional-parameter-count arglist))) (get-class-keyword-parameters (get-usable-image syntax) (elt arguments arg-position)))) arglist))) (define-argument-type package-designator () (:completion (syntax string all-completions) (declare (ignore all-completions)) (let ((keyworded (and (plusp (length string)) (char= (aref string 0) #\:))) (all-upper (every #'upper-case-p string))) (loop for package in (list-all-packages) for package-name = (if keyworded (concatenate 'string ":" (package-name package)) (package-name package)) when (search string package-name :test #'char-equal :end2 (min (length string) (length package-name))) collect (if all-upper package-name (string-downcase package-name)))))) (defmacro define-form-traits ((operator &rest arguments) &key no-typed-completion no-smart-arglist) "Define \"traits\" for a form with the operator that is eql to `operator'. Traits is a common designator for intelligent (type-aware) completion and intelligent modification of argument lists (for example, adding keyword arguments for the initargs of the class being instantiated to the arglist of `make-instance'). `Arguments' is a lambda-list-like list that describes the types of the operands of `operator'. You can use the lambda-list keywords `&rest' and `&key' to tie all, or specific keyword arguments, to types. If `no-typed-completion' or `no-smart-arglist' is non-NIL, no code for performing typed completion or smart arglist modification will be generated, respectively." ;; FIXME: This macro should also define indentation rules. (labels ((process-keyword-arg-descs (arguments) ;; We expect `arguments' to be a plist mapping keyword ;; symbols to type/class designators/names. `((t (let* ((keyword-indices (loop for (car . cdr) on indices if (null cdr) collect (1+ car) else collect (first car))) (keyword (apply #'list-aref operands keyword-indices)) (type (getf ',arguments keyword))) (if (null type) (call-next-method) (complete-argument-of-type type syntax string all-completions)))))) (process-arg-descs (arguments index) (let ((argument (first arguments))) (cond ((null argument) nil) ((eq argument '&rest) `(((>= (caar indices) ,index) (complete-argument-of-type ',(second arguments) syntax string all-completions)))) ((eq argument '&key) (process-keyword-arg-descs (rest arguments))) ((listp argument) (cons `((= (caar indices) ,index) ,(if (eq (first argument) 'quote) `(let ((selected-operand (apply #'list-aref operands (mapcar #'first indices)))) (cond ((and (listp selected-operand) (eq (first selected-operand) 'quote)) (complete-argument-of-type ',(second argument) syntax string all-completions)) (t (call-next-method)))) `(cond ((not (null (rest indices))) (pop indices) (cond ,@(build-completions-cond-body argument))) (t (call-next-method))))) (process-arg-descs (rest arguments) (1+ index)))) (t (cons `((= (caar indices) ,index) (complete-argument-of-type ',argument syntax string all-completions)) (process-arg-descs (rest arguments) (1+ index))))))) (build-completions-cond-body (arguments) (append (process-arg-descs arguments 0) '((t (call-next-method)))))) `(progn (defmethod possible-completions ((syntax lisp-syntax) (operator (eql ',operator)) string package operands indices) ,(if no-typed-completion '(call-next-method) `(let* ((*package* package) (all-completions (call-next-method))) (cond ,@(build-completions-cond-body arguments))))) ,(unless no-smart-arglist `(defmethod arglist-for-form ((syntax lisp-syntax) (operator (eql ',operator)) &optional arguments) (declare (ignorable arguments)) (let ((arglist (call-next-method)) (arg-position 0)) (declare (ignorable arg-position)) ,@(loop for arg in arguments collect `(setf arglist (modify-argument-list ',(unlisted arg #'second) syntax arglist arguments arg-position)) collect '(incf arg-position)) arglist)))))) (defun invoke-with-code-insight (syntax offset continuation) "Call `continuation' with argument-values containing interesting details about the code at `offset'. If `offset' is not within a form, everything will be bound to nil. The values provided are, in order: the form, the forms operator, the indices to the operand at `offset', or the indices to an operand entered at that position if none is there, and the operands in the form." (update-parse syntax) (let* ((form ;; Find a form with a valid (fboundp) operator. (let ((immediate-form (or (form-before syntax offset) (form-around syntax offset)))) (unless (null immediate-form) (find-applicable-form syntax immediate-form) (or (find-applicable-form syntax immediate-form) ;; If nothing else can be found, and `arg-form' ;; is the operator of its enclosing form, we use ;; the enclosing form. (when (and (not (form-at-top-level-p immediate-form)) (eq (first-form (children (parent immediate-form))) immediate-form)) (parent immediate-form)))))) ;; If we cannot find a form, there's no point in looking ;; up any of this stuff. (operator (when (and form (form-list-p form)) (form-to-object syntax (form-operator form)))) (operands (when (and form (form-list-p form)) (mapcar #'(lambda (operand) (when operand (form-to-object syntax operand))) (form-operands form)))) (current-operand-indices (when form (find-operand-info syntax offset form)))) (funcall continuation form operator current-operand-indices operands))) (defmacro with-code-insight (mark-or-offset syntax (&key operator form this-operand-indices operands) &body body) "Evaluate `body' with the provided symbols lexically bound to interesting details about the code at `mark-or-offset'. If `mark-or-offset' is not within a form, everything will be bound to nil." (check-type operator symbol) (check-type form symbol) (check-type this-operand-indices symbol) (check-type operands symbol) (let ((operator-sym (or operator (gensym))) (operands-sym (or operands (gensym))) (form-sym (or form (gensym))) (this-operand-indices-sym (or this-operand-indices (gensym)))) `(as-offsets ((offset ,mark-or-offset)) (invoke-with-code-insight ,syntax offset #'(lambda (,form-sym ,operator-sym ,this-operand-indices-sym ,operands-sym) (declare (ignore ,@(append (unless operator (list operator-sym)) (unless operands (list operands-sym)) (unless form (list form-sym)) (unless this-operand-indices (list this-operand-indices-sym))))) ,@body))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Form trait definitions (define-form-traits (make-instance 'class-name)) (define-form-traits (find-class 'class-name) :no-smart-arglist t) (define-form-traits (change-class t 'class-name)) (define-form-traits (make-pane 'class-name)) (define-form-traits (make-instances-obsolete 'class-name) :no-smart-arglist t) (define-form-traits (typep t 'class-name)) (define-form-traits (in-package package-designator)) (define-form-traits (clim-lisp:defclass t (&rest class-name)) :no-smart-arglist t) (define-form-traits (cl:defclass t (&rest class-name)) :no-smart-arglist t) (define-form-traits (define-application-frame t (&rest class-name))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Parameter hinting (defgeneric operator-for-display (operator) (:documentation "Return what should be displayed whenever `operator' is displayed as an operator.") (:method (operator) operator)) (defmethod operator-for-display ((operator list)) (case (first operator) ('cl:lambda '|Lambda-Expression|))) (defun display-lambda-list-to-stream (stream operator lambda-list &optional highlighted-parameters) "Display the operator and lambda list to stream, format as appropriate." (labels ((show (parameter format-string &rest format-args) (with-text-face (stream (if (member parameter highlighted-parameters) :bold :roman)) (apply #'format stream format-string format-args))) (show-parameters (parameters) (loop for (parameter . next-parameters) on parameters do (etypecase parameter (destructuring-keyword-parameter (show parameter ":~A " (keyword-name parameter)) (format stream "(") (show-lambda-list (inner-lambda-list parameter)) (format stream ")")) (keyword-parameter (show parameter ":~A" (keyword-name parameter))) (destructuring-parameter (format stream "(") (show-lambda-list (inner-lambda-list parameter)) (format stream ")")) (named-parameter (show parameter "~A" (name parameter)))) do (when next-parameters (princ #\Space stream)))) (show-lambda-list (lambda-list) (let ((space-needed (not (null (required-parameters lambda-list))))) (show-parameters (required-parameters lambda-list)) (when (optional-parameters lambda-list) (when space-needed (princ #\Space stream)) (format stream "&OPTIONAL ") (show-parameters (optional-parameters lambda-list)) (setf space-needed t)) (when (rest-parameter lambda-list) (when space-needed (princ #\Space stream)) (format stream "&REST ") (show (rest-parameter lambda-list) "~A" (name (rest-parameter lambda-list))) (setf space-needed t)) (when (body-parameter lambda-list) (when space-needed (princ #\Space stream)) (format stream "&BODY ") (show (body-parameter lambda-list) "~A" (name (body-parameter lambda-list))) (setf space-needed t)) (when (keyword-parameters lambda-list) (when space-needed (princ #\Space stream)) (format stream "&KEY ") (show-parameters (keyword-parameters lambda-list)))))) (format stream "(~A" operator) (when (all-parameters lambda-list) (princ #\Space stream)) (show-lambda-list lambda-list) (format stream ")"))) (defun show-arglist-silent (syntax operator &optional current-arg-indices arguments) "Display the arglist for `operator' in the minibuffer, do not complain if `operator' is not bound to, or is not, a function. `Current-arg-index' is used to add extra information to the arglist display. `Arguments' should be either nil or a list of provided arguments in the form housing symbol. Returns NIL if an arglist cannot be displayed." (let* ((lambda-list (arglist-for-form syntax operator arguments)) (highlighted-parameters (analyze-lambda-list lambda-list current-arg-indices))) (esa:with-minibuffer-stream (minibuffer) (display-lambda-list-to-stream minibuffer operator lambda-list highlighted-parameters)))) (defun show-arglist (syntax symbol) (unless (and (fboundp symbol) (show-arglist-silent syntax symbol)) (esa:display-message "Function ~a not found." symbol))) (defun show-arglist-for-form-at-mark (mark syntax) "Display the argument list for the operator of `form'. The list need not be complete. If an argument list cannot be retrieved for the operator, nothing will be displayed." (with-code-insight mark syntax (:operator operator :this-operand-indices this-operand-indices :operands operands) (when (valid-operator-p operator) (show-arglist-silent syntax operator this-operand-indices operands)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Symbol completion ;;; The following helper stuff is from Swank. (defun longest-completion (completions) "Return the longest completion of `completions', which must be a list of sequences." (untokenize-completion (mapcar #'longest-common-prefix (transpose-lists (mapcar #'tokenize-completion completions))))) (defun tokenize-completion (string) "Return all substrings of STRING delimited by #\-." (loop with end for start = 0 then (1+ end) until (> start (length string)) do (setq end (or (position #\- string :start start) (length string))) collect (subseq string start end))) (defun untokenize-completion (tokens) (format nil "~{~A~^-~}" tokens)) (defun longest-common-prefix (strings) "Return the longest string that is a common prefix of STRINGS." (if (null strings) "" (flet ((common-prefix (s1 s2) (let ((diff-pos (mismatch s1 s2))) (if diff-pos (subseq s1 0 diff-pos) s1)))) (reduce #'common-prefix strings)))) (defun transpose-lists (lists) "Turn a list-of-lists on its side. If the rows are of unequal length, truncate uniformly to the shortest. For example: \(transpose-lists '((ONE TWO THREE) (1 2))) => ((ONE 1) (TWO 2))" (cond ((null lists) '()) ((some #'null lists) '()) (t (cons (mapcar #'car lists) (transpose-lists (mapcar #'cdr lists)))))) ;;; The interface used by the commands. (defgeneric frame-clear-completions (frame) (:documentation "Clear the display completions for `frame'.") (:method (frame) nil)) (defun clear-completions () (frame-clear-completions *application-frame*)) (defun find-completions (syntax mark-or-offset string) "Find completions for the symbol denoted by the string `string' at `mark-or-offset'. Two values will be returned: the common leading string of the completions and a list of the possible completions as strings." (let* ((result (with-code-insight mark-or-offset syntax (:operator operator :operands operands :this-operand-indices indices) (let ((completions (possible-completions syntax operator string (package-at-mark syntax mark-or-offset) operands indices))) (list completions (longest-completion completions))))) (set (first result)) (longest (second result))) (values longest set))) (defun find-fuzzy-completions (syntax mark-or-offset string) "Find completions for the symbol denoted by the string `string' at `mark-or-offset'. Two values will be returned: the common leading string of the completions and a list of the possible completions as strings. This function uses fuzzy logic to find completions based on `string'." (let* ((set (fuzzy-completions (get-usable-image syntax) string (package-at-mark syntax mark-or-offset) 10)) (best (caar set))) (values best set))) (defun complete-symbol-at-mark-with-fn (syntax mark &key (completion-finder #'find-completions) (complete-blank t)) "Attempt to find and complete the symbol at `mark' using the function `completion-finder' to get the list of completions. If the completion is ambiguous, a list of possible completions will be displayed. If no symbol can be found at `mark', return NIL. If there is no symbol at `mark' and `complete-blank' is true (the default), all symbols available in the current package will be shown. If `complete-blank' is false, nothing will be shown and the function will return NIL." (let* ((token (form-around syntax (offset mark))) (useful-token (and (not (null token)) (form-token-p token) (not (= (start-offset token) (offset mark)))))) (when (or useful-token complete-blank) (multiple-value-bind (longest completions) (funcall completion-finder syntax (cond (useful-token (start-offset (fully-quoted-form token))) ((and (form-quoted-p token) (form-incomplete-p token)) (start-offset token)) (t (offset mark))) (if useful-token (form-string syntax token) "")) (cond ((null completions) (esa:display-message "No completions found") nil) ((endp (rest completions)) (replace-symbol-at-mark syntax mark longest) t) (t (replace-symbol-at-mark syntax mark (or (when (or useful-token (accept 'boolean :prompt "You are asking for a list of all exported symbols, proceed?") (return-from complete-symbol-at-mark-with-fn nil)) (frame-manager-menu-choose (find-frame-manager) (mapcar #'(lambda (completion) (if (listp completion) (cons completion (first completion)) completion)) completions) :label "Possible completions" :scroll-bars :vertical)) longest)) t)))))) (defun complete-symbol-at-mark (syntax mark &optional (complete-blank t)) "Attempt to find and complete the symbol at `mark'. If the completion is ambiguous, a list of possible completions will be displayed. If no symbol can be found at `mark', return nil." (complete-symbol-at-mark-with-fn syntax mark :complete-blank complete-blank)) (defun fuzzily-complete-symbol-at-mark (syntax mark &optional (complete-blank t)) "Attempt to find and complete the symbol at `mark' using fuzzy completion. If the completion is ambiguous, a list of possible completions will be displayed. If no symbol can be found at `mark', return nil." (complete-symbol-at-mark-with-fn syntax mark :completion-finder #'find-fuzzy-completions :complete-blank complete-blank)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Evaluation and compilation (defun eval-string (syntax string) "Evaluate all expressions in STRING and return a list of results." (with-input-from-string (stream string) (loop for form = (read stream nil stream) while (not (eq form stream)) collecting (multiple-value-list (eval-form-for-drei (get-usable-image syntax) form))))) (defun eval-region (start end syntax) ;; Must be (mark>= end start). (with-syntax-package (syntax start) (let ((*read-base* (base syntax))) (let* ((string (buffer-substring (buffer start) (offset start) (offset end))) (values (multiple-value-list (eval-string syntax string))) ;; Enclose each set of values in {}. (result (apply #'format nil "~{{~:[No values~;~:*~{~S~^,~}~]}~}" values))) (esa:display-message result))))) (defclass undefiner () () (:documentation "A base class for classes that contain logic for undefining Lisp constructs. Subclasses of `undefiner' must implement the undefiner protocol. An instance of `undefiner' works on a specific kind of definition (a `defun', `defclass', `defgeneric', etc).")) (defgeneric undefiner-type (undefiner) (:documentation "Return the kind of definition undefined by `undefiner'. The return value is a string - a textual, user-oriented description.")) (defgeneric definition-name (undefiner syntax definition-form) (:documentation "Return the name of the definition described by `definition-form', as per the kind of definition `undefiner' handles. `Syntax' is the Lisp syntax object that has `definition-form'. The name returned is an actual Lisp object. `Form-conversion-error' is signalled if the form describing the name cannot be converted to an object, or if the form is otherwise inappropriate.")) (defgeneric undefine (undefiner syntax definition-form) (:documentation "Undefine whatever `definition-form' defines, provided `definition-form' is the kind of definition handled by `undefiner'. If it isn't, the results are undefined. `Syntax' is the Lisp syntax object that has `definition-form'.")) (defvar *undefiners* (make-hash-table) "A hash table mapping operators to undefiners. The undefiners are instances of `undefiner'.") (defun get-undefiner (definition-type) "Return the undefiner for `definition-type', which must be a symbol. Returns NIL if there is no undefiner of the given type." (values (gethash definition-type *undefiners*))) (defun invalid-form-for-type (syntax form type-name) "Signal a `form-conversion-error' describing the fact that `form' cannot define a `type-name'." (form-conversion-error syntax form "Form cannot define a ~A." type-name)) (defun invalid-form (undefiner syntax form) "Signal a `form-conversion-error' describing the fact that `form' cannot define whatever kind of definition `undefiner' handles." (invalid-form-for-type syntax form (undefiner-type undefiner))) (defclass simple-undefiner (undefiner) ((%undefiner-type :reader undefiner-type :initform (error "A description must be provided.") :type string :documentation "A textual, user-oriented name for the type of definition handled by this undefiner." :initarg :undefiner-type) (%undefiner-function :reader undefiner-function :initform (error "An undefiner function must be provided.") :documentation "A function of three arguments: the syntax object, the name of the definition to be undefined and the form to be undefined." :initarg :undefiner-function))) (defmethod definition-name ((undefiner simple-undefiner) (syntax lisp-syntax) (form form)) (invalid-form undefiner syntax form)) (defmethod definition-name ((undefiner simple-undefiner) (syntax lisp-syntax) (form list-form)) (if (>= (length (form-children form)) 2) (form-to-object syntax (second-form (children form))) (call-next-method))) (defmethod undefine ((undefiner simple-undefiner) (syntax lisp-syntax) (form form)) (funcall (undefiner-function undefiner) syntax (definition-name undefiner syntax form) form)) (defmacro define-simple-undefiner (definition-spec (syntax-sym name-sym form-sym) &body body) "Define a way to undefine some definition. `Definition-spec' is the operator (like `defun', `defclass', etc), and `syntax-sym', `name-sym' and `form-sym' will be bound to the Lisp syntax instance, the name of the definition to be undefined and the entire form of the definition, when the undefinition is invoked by the user. Syntactical problems (such as an incomplete or invalid `form') should be signalled via `form-conversion-error'." (check-type definition-spec (or list symbol)) (let* ((definition-type (unlisted definition-spec)) (undefiner-name (if (listp definition-spec) (second definition-spec) (string-downcase definition-type)))) (check-type definition-type symbol) `(setf (gethash ',definition-type *undefiners*) (make-instance 'simple-undefiner :undefiner-type ,undefiner-name :undefiner-function #'(lambda (,syntax-sym ,name-sym ,form-sym) (declare (ignorable ,syntax-sym ,name-sym ,form-sym)) ,@body))))) (defclass generic-undefiner (undefiner) ((%undefiner-type :reader undefiner-type :initform (error "A description must be provided.") :type string :documentation "A textual, user-oriented name for the type of definition handled by this undefiner." :initarg :undefiner-type) (%name-function :reader name-function :initform (error "A name retrieval function must be provided.") :documentation "A function of three arguments: the syntax object and the form to retrieve a name from. Should return the name as a Lisp object (probably a symbol). Should signal a `form-conversion-error' if the form cannot define whatever type this undefiner handles." :initarg :name-function) (%undefiner-function :reader undefiner-function :initform (error "An undefiner function must be provided.") :documentation "A function of three arguments: the syntax object, the name of the definition to be undefined and the form to be undefined." :initarg :undefiner-function))) (defmethod definition-name ((undefiner generic-undefiner) (syntax lisp-syntax) (form form)) (funcall (name-function undefiner) syntax form)) (defmethod undefine ((undefiner generic-undefiner) (syntax lisp-syntax) (form form)) (funcall (undefiner-function undefiner) syntax (definition-name undefiner syntax form) form)) (defmacro define-undefiner (definition-spec ((name-syntax-sym name-form-sym) &body name-body) ((undef-syntax-sym undef-name-sym undef-form-sym) &body undefiner-body)) "Define a way to undefine definitions. `Definition-spec' is the operator (like `defun', `defclass', etc) and may optionally be a list, in which case the first element is the operator, and the second a user-oriented name for the kind of thing defined by the operator. `Name-body' and `Undefiner-body' will be evaluated to retrieve the name and perform the undefinition, respectively. `Name-syntax-sym' and `name-form-sym' will be bound to the Lisp syntax instance and the entire form of the definition during evaluation of `name-body'. Syntactical problems (such as an incomplete or invalid form) should be signalled by an invocation `(invalid)' `undef-syntax-sym', `undef-name-sym' and `undef-form-sym' will be bound to the Lisp syntax instance, the name of the definition to be undefined and the entire form of the definition when `undefiner-body' is evaluated. Syntactical problems (such as an incomplete or invalid form) should be signalled by an invocation `(invalid)'." (check-type definition-spec (or list symbol)) (let* ((definition-type (unlisted definition-spec)) (undefiner-name (if (listp definition-spec) (second definition-spec) (string-downcase definition-type)))) (check-type definition-type symbol) `(setf (gethash ',definition-type *undefiners*) (make-instance 'generic-undefiner :undefiner-type ,undefiner-name :name-function #'(lambda (,name-syntax-sym ,name-form-sym) (declare (ignorable ,name-syntax-sym ,name-form-sym)) (flet ((invalid () (invalid-form-for-type ,name-syntax-sym ,name-form-sym ,undefiner-name))) (declare (ignorable #'invalid)) ,@name-body)) :undefiner-function #'(lambda (,undef-syntax-sym ,undef-name-sym ,undef-form-sym) (declare (ignorable ,undef-syntax-sym ,undef-name-sym ,undef-form-sym)) (flet ((invalid () (invalid-form-for-type ,undef-syntax-sym ,undef-form-sym ,undef-name-sym))) (declare (ignorable #'invalid)) ,@undefiner-body)))))) (define-simple-undefiner (defun "function") (syntax name form) (fmakunbound name)) (define-simple-undefiner (defgeneric "generic function") (syntax name form) (fmakunbound name)) (define-simple-undefiner (defmacro "macro") (syntax name form) (fmakunbound name)) (define-simple-undefiner (cl:defclass "class") (syntax name form) (setf (find-class name nil) nil)) (define-simple-undefiner (clim-lisp:defclass "class") (syntax name form) (setf (find-class name nil) nil)) (define-simple-undefiner (defmethod "method") (syntax name form) (let ((function (fdefinition name))) (labels ((get-qualifiers (maybe-qualifiers) (unless (or (null maybe-qualifiers) (form-list-p (first maybe-qualifiers))) (cons (form-to-object syntax (first maybe-qualifiers)) (get-qualifiers (rest maybe-qualifiers))))) (get-specializers (maybe-specializers) (cond ((null maybe-specializers) (form-conversion-error syntax form "~A form invalid." 'defmethod)) ;; Map across the elements in the lambda list. ((form-list-p (first maybe-specializers)) (mapcar #'(lambda (ll-form) (if (and (form-list-p ll-form) (second-form (children ll-form))) (form-to-object syntax (second-form (children ll-form))) t)) (form-children (first maybe-specializers)))) ;; Skip the qualifiers to get the lambda-list. (t (get-specializers (rest maybe-specializers)))))) (remove-method function (find-method function (get-qualifiers (cddr (form-children form))) (get-specializers (cddr (form-children form))) nil))))) (define-simple-undefiner (defvar "special variable") (syntax name form) (makunbound name)) (define-simple-undefiner (defparameter "special variable") (syntax name form) (makunbound name)) (define-simple-undefiner (defconstant "constant") (syntax name form) (makunbound name)) (define-simple-undefiner (defpackage "package") (syntax name form) (delete-package name)) (defun get-listed-name (syntax form) "Retrieve the name of `form' under the assumption that the name is the second element of `form', and if this is a list, the first element of that list. The secondary value will be true if a name can be found, false otherwise." (if (and (form-list-p form) (>= (length (form-children form)) 2)) (let ((name-form (second (form-children form)))) (cond ((and (form-list-p name-form) (form-children name-form)) (values (form-to-object syntax (first (form-children name-form))) t)) ((form-token-p name-form) (values (form-to-object syntax name-form) t)) (t (values nil nil)))) (values nil nil))) ;; Cannot recognize the common define-FOO-command macros. (define-undefiner (define-command "command") ((syntax form) (multiple-value-bind (name success) (get-listed-name syntax form) (if success name (invalid)))) ((syntax name form) ;; Pick out the command table from the define-command form. The ;; command may also be in other command tables, but we can't find ;; those. (let ((name-form (listed (form-to-object syntax (second (form-children form)))))) (destructuring-bind (ignore &key command-table keystroke &allow-other-keys) name-form (declare (ignore ignore)) (when command-table (remove-command-from-command-table name command-table :errorp nil) (remove-keystroke-from-command-table command-table keystroke :errorp nil)))) (fmakunbound name))) (define-undefiner (define-undefiner "undefiner") ((syntax form) (multiple-value-bind (name success) (get-listed-name syntax form) (if success name (invalid)))) ((syntax name form) (remhash name *undefiners*))) (define-undefiner (define-simple-undefiner "simple undefiner") ((syntax form) (multiple-value-bind (name success) (get-listed-name syntax form) (if success name (invalid)))) ((syntax name form) (remhash name *undefiners*))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/lr-syntax.lisp0000644000175000017500000007051111345155772020532 0ustar pdmpdm;; -*- Mode: Lisp; Package: DREI-LR-SYNTAX -*- ;;; (c) copyright 2005 by ;;; Robert Strandh (strandh@labri.fr) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; (c) copyright 2007 by ;;; John Q Splittist (splittist@gmail.com) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Base lexing and parsing functionality of ;;; syntax modules for analysing languages (in-package :drei-lr-syntax) (defclass lr-syntax-mixin () ((stack-top :initform nil :accessor stack-top) (potentially-valid-trees) (lookahead-lexeme :initform nil :accessor lookahead-lexeme) (current-state) (initial-state :initarg :initial-state) (current-start-mark) (current-size) (scan :accessor scan))) (defmethod initialize-instance :after ((syntax lr-syntax-mixin) &rest args) (declare (ignore args)) (with-accessors ((buffer buffer) (scan scan)) syntax (setf scan (make-buffer-mark buffer 0 :left)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; lexer (defgeneric skip-inter (syntax state scan) (:documentation "advance scan until the beginning of a new lexeme. Return T if one can be found and NIL otherwise.")) (defgeneric lex (syntax state scan) (:documentation "Return the next lexeme starting at scan.")) (defmethod lex :around (syntax state scan) (when (skip-inter syntax state scan) (let* ((start-offset (offset scan)) (lexeme (call-next-method)) (new-size (- (offset scan) start-offset))) (with-slots (start-mark size) lexeme (setf (offset scan) start-offset) (setf start-mark scan size new-size)) lexeme))) (defclass lexer-state () () (:documentation "These states are used to determine how the lexer should behave.")) (defmacro define-lexer-state (name superclasses &body body) `(defclass ,name (,@superclasses lexer-state) ,@body)) (define-lexer-state lexer-error-state () () (:documentation "In this state, the lexer returns error lexemes consisting of entire lines of text")) (define-lexer-state lexer-toplevel-state () () (:documentation "In this state, the lexer assumes it can skip whitespace and should recognize ordinary lexemes of the language.")) (defclass parser-symbol () ((start-mark :initform nil :initarg :start-mark :reader start-mark) (size :initform nil :initarg :size :reader size) (parent :initform nil :accessor parent) (children :initform '() :initarg :children :reader children) (preceding-parse-tree :initform nil :reader preceding-parse-tree) (parser-state :initform nil :initarg :parser-state :reader parser-state))) (defmethod print-object ((object parser-symbol) stream) (print-unreadable-object (object stream :type t :identity t) (format stream "~s ~s" (start-offset object) (end-offset object)))) (defclass literal-object-mixin () () (:documentation "Mixin for parser symbols representing literal (non-character) objects in the buffer.")) (defun literal-object-p (parser-symbol) "Return true if `parser-symbol' is of type `literal-object-mixin'." (typep parser-symbol 'literal-object-mixin)) (defmethod start-offset ((state parser-symbol)) (let ((mark (start-mark state))) (when mark (offset mark)))) (defmethod end-offset ((state parser-symbol)) (with-slots (start-mark size) state (when start-mark (+ (offset start-mark) size)))) (defgeneric action (syntax state lexeme)) (defgeneric new-state (syntax state parser-symbol)) (defclass parser-state () ()) (defmacro define-parser-state (name superclasses &body body) `(progn (defclass ,name ,superclasses ,@body) (defvar ,name (make-instance ',name)))) (defclass lexeme (parser-symbol) ()) (defclass nonterminal (parser-symbol) ()) (defmethod initialize-instance :after ((parser-symbol nonterminal) &rest args) (declare (ignore args)) (with-slots (children start-mark size) parser-symbol (loop for child in children do (setf (parent child) parser-symbol)) (let ((start (find-if-not #'null children :key #'start-offset)) (end (find-if-not #'null children :key #'end-offset :from-end t))) (when start (setf start-mark (slot-value start 'start-mark) size (- (end-offset end) (start-offset start))))))) (defun pop-one (syntax) (with-slots (stack-top current-state) syntax (with-slots (preceding-parse-tree parser-state) stack-top (prog1 stack-top (setf current-state parser-state stack-top preceding-parse-tree))))) (defun pop-number (syntax how-many) (loop with result = '() repeat how-many do (push (pop-one syntax) result) finally (return result))) (defmacro reduce-fixed-number (symbol nb-children) `(let ((result (make-instance ',symbol :children (pop-number syntax ,nb-children)))) (when (zerop ,nb-children) (with-slots (scan) syntax (with-slots (start-mark size) result (setf start-mark (clone-mark scan :right) size 0)))) result)) (defun pop-until-type (syntax type) (with-slots (stack-top) syntax (loop with result = '() for child = stack-top do (push (pop-one syntax) result) until (typep child type) finally (return result)))) (defmacro reduce-until-type (symbol type &optional end-of-buffer) `(let ((result (make-instance ',symbol :children (pop-until-type syntax ',type)))) (with-slots (start-mark size) result (when (null (children result)) (with-slots (scan) syntax (setf start-mark (clone-mark scan :right) size 0))) (when ,end-of-buffer (setf size (- (size (buffer syntax)) (start-offset result))))) result)) (defun pop-all (syntax) (with-slots (stack-top) syntax (loop with result = '() until (null stack-top) do (push (pop-one syntax) result) finally (return result)))) (defmacro reduce-all (symbol) `(let ((result (make-instance ',symbol :children (pop-all syntax)))) (when (null (children result)) (with-slots (scan) syntax (with-slots (start-mark size) result (setf start-mark (clone-mark scan :right) size 0)))) result)) (define-parser-state error-state (lexer-error-state parser-state) ()) (define-parser-state error-reduce-state (lexer-toplevel-state parser-state) ()) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; parser step (defgeneric parser-step (syntax)) (defmethod parser-step ((syntax lr-syntax-mixin)) (with-slots (lookahead-lexeme stack-top current-state scan) syntax (setf lookahead-lexeme (lex syntax current-state (clone-mark scan :right))) (let* ((new-parser-symbol (action syntax current-state lookahead-lexeme)) (new-state (new-state syntax current-state new-parser-symbol))) (with-slots (parser-state parser-symbol preceding-parse-tree children) new-parser-symbol (setf parser-state current-state current-state new-state preceding-parse-tree stack-top stack-top new-parser-symbol))) (setf (offset scan) (end-offset stack-top)))) (defun prev-tree (tree) (assert (not (null tree))) (if (null (children tree)) (preceding-parse-tree tree) (car (last (children tree))))) (defun next-tree (tree) (assert (not (null tree))) (if (null (parent tree)) nil (let* ((parent (parent tree)) (siblings (children parent))) (cond ((null parent) nil) ((eq tree (car (last siblings))) parent) (t (loop with new-tree = (cadr (member tree siblings :test #'eq)) until (null (children new-tree)) do (setf new-tree (car (children new-tree))) finally (return new-tree))))))) (defun find-last-valid-lexeme (parse-tree offset) (cond ((or (null parse-tree) (null (start-offset parse-tree))) nil) ((> (start-offset parse-tree) offset) (find-last-valid-lexeme (preceding-parse-tree parse-tree) offset)) ((not (typep parse-tree 'lexeme)) (find-last-valid-lexeme (car (last (children parse-tree))) offset)) ((>= (end-offset parse-tree) offset) (find-last-valid-lexeme (preceding-parse-tree parse-tree) offset)) (t parse-tree))) (defun find-first-potentially-valid-lexeme (parse-trees offset) (cond ((null parse-trees) nil) ((or (null (start-offset (car parse-trees))) (< (end-offset (car parse-trees)) offset)) (find-first-potentially-valid-lexeme (cdr parse-trees) offset)) ((not (typep (car parse-trees) 'lexeme)) (find-first-potentially-valid-lexeme (children (car parse-trees)) offset)) ((<= (start-offset (car parse-trees)) offset) (loop with tree = (next-tree (car parse-trees)) until (or (null tree) (> (start-offset tree) offset)) do (setf tree (next-tree tree)) finally (return tree))) (t (car parse-trees)))) (defun parse-tree-equal (tree1 tree2) (and (eq (class-of tree1) (class-of tree2)) (eq (parser-state tree1) (parser-state tree2)) (= (end-offset tree1) (end-offset tree2)))) (defmethod print-object ((mark mark) stream) (print-unreadable-object (mark stream :type t :identity t) (format stream "~s" (offset mark)))) (defun parse-patch (syntax) (with-slots (current-state stack-top scan potentially-valid-trees) syntax (parser-step syntax) (finish-output *trace-output*) (cond ((parse-tree-equal stack-top potentially-valid-trees) (unless (or (null (parent potentially-valid-trees)) (eq potentially-valid-trees (car (last (children (parent potentially-valid-trees)))))) (loop for tree = (cadr (member potentially-valid-trees (children (parent potentially-valid-trees)) :test #'eq)) then (car (children tree)) until (null tree) do (setf (slot-value tree 'preceding-parse-tree) stack-top)) (setf stack-top (prev-tree (parent potentially-valid-trees)))) (setf potentially-valid-trees (parent potentially-valid-trees)) (setf current-state (new-state syntax (parser-state stack-top) stack-top)) (setf (offset scan) (end-offset stack-top))) (t (loop until (or (null potentially-valid-trees) (>= (start-offset potentially-valid-trees) (end-offset stack-top))) do (setf potentially-valid-trees (next-tree potentially-valid-trees))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Utility functions (defun invoke-do-parse-symbols-forward (start-offset nearby-symbol fn) "Loop across the parse symbols of the syntax, calling `fn' on any parse symbol that starts at or after `start-offset'. `Nearby-symbol' is the symbol at which the iteration will start. First, if `nearby-symbol' is at or after `start-offset', `fn' will be called on `nearby-symbol'. Afterwards, the children of `nearby-symbol' will be looped over. Finally, the process will be repeated for each sibling of `nearby-symbol'. It is guaranteed that `fn' will not be called twice for the same parser symbol." (labels ((act (parse-symbol previous) (when (>= (end-offset parse-symbol) start-offset) (when (>= (start-offset parse-symbol) start-offset) (funcall fn parse-symbol)) (loop for child in (children parse-symbol) unless (eq child previous) do (act child parse-symbol))) (unless (or (null (parent parse-symbol)) (eq (parent parse-symbol) previous)) (act (parent parse-symbol) parse-symbol)))) (act nearby-symbol nearby-symbol))) (defmacro do-parse-symbols-forward ((symbol start-offset enclosing-symbol) &body body) "Loop across the parse symbols of the syntax, evaluating `body' with `symbol' bound for each parse symbol that starts at or after `start-offset'. `enclosing-symbol' is the symbol at which the iteration will start. First, if `enclosing-symbol' is at or after `start-offset', `symbol' will be bound to `enclosing-symbol'. Afterwards, the children of `enclosing-symbol' will be looped over. Finally, the process will be repeated for each sibling of `nearby-symbol'. It is guaranteed that `symbol' will not bound to the same parser symbol twice." `(invoke-do-parse-symbols-forward ,start-offset ,enclosing-symbol #'(lambda (,symbol) ,@body))) (defun parser-symbol-containing-offset (syntax offset) "Find the most specific (leaf) parser symbol in `syntax' that contains `offset'. If there is no such parser symbol, return the stack-top of `syntax'." (labels ((check (parser-symbol) (cond ((or (and (<= (start-offset parser-symbol) offset) (< offset (end-offset parser-symbol))) (= offset (start-offset parser-symbol))) (return-from parser-symbol-containing-offset (if (null (children parser-symbol)) parser-symbol (or (check-children (children parser-symbol)) parser-symbol)))) (t nil))) (check-children (children) (find-if #'check children))) (or (check-children (children (stack-top syntax))) (stack-top syntax)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; update syntax (defmethod update-syntax values-max-min ((syntax lr-syntax-mixin) prefix-size suffix-size &optional (begin 0) (end (size (buffer syntax)))) (declare (ignore begin end)) (let* ((low-mark-offset prefix-size) (high-mark-offset (- (size (buffer syntax)) suffix-size))) (when (<= low-mark-offset high-mark-offset) (catch 'done (with-slots (current-state stack-top scan potentially-valid-trees initial-state) syntax (setf potentially-valid-trees (if (null stack-top) nil (find-first-potentially-valid-lexeme (children stack-top) high-mark-offset))) (setf stack-top (find-last-valid-lexeme stack-top low-mark-offset)) (setf (offset scan) (if (null stack-top) 0 (end-offset stack-top)) current-state (if (null stack-top) initial-state (new-state syntax (parser-state stack-top) stack-top))) (loop do (parse-patch syntax))))) (values 0 (size (buffer syntax))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; General redisplay for LR syntaxes, subclasses of `lr-syntax-mixin' ;;; should be able to easily define some syntax rules, and need not ;;; bother with all this complexity. ;;; ;;; _______________ ;;; / \ ;;; / \ ;;; / \ ;;; | XXXX XXXX | ;;; | XXXX XXXX | ;;; | XXX XXX | ;;; | X | ;;; \__ XXX __/ ;;; |\ XXX /| ;;; | | | | ;;; | I I I I I I I | ;;; | I I I I I I | ;;; \_ _/ ;;; \_ _/ ;;; \_______/ ;;; XXX XXX ;;; XXXXX XXXXX ;;; XXXXXXXXX XXXXXXXXXX ;;; XXXXX XXXXX ;;; XXXXXXX ;;; XXXXX XXXXX ;;; XXXXXXXXX XXXXXXXXXX ;;; XXXXX XXXXX ;;; XXX XXX (defmacro define-syntax-highlighting-rules (name &body rules) "Define a set of rules for highlighting a syntax. `Name', which must be a symbol, is the name of this set of rules, and will be bound to a function implementing the rules. `Rules' is a list of rules of the form `(parser-symbol (type args...))', where `parser-symbol' is a type that might be encountered in a parse tree for the syntax. The rule specifies how to highlight that kind of object (and all its children). `Type' can be one of three special symbols. `:face', in which case `args' will be used as arguments to a call to `make-face'. The resulting face will be used to draw the parsersymbol. `:options', in which case `args' will be used as arguments to `make-drawing-options'. The resulting options will be used to draw the parser symbol. `:function', in which case `args' must be a single element, a function that takes two arguments. These arguments are the view of the syntax and the parser symbol, and the return value of this function is the `drawing-options' object that will be used to draw the parser-symbol. Alternatively, `type' can be any object (usually a dynamically bound symbol), in which case it will be evaluated to get the drawing options. `Type' can also be a list, in which case the first element will be interpreted as described above, and the remaining elements will be considered keyword arguments. The following keyword arguments are supported: `:sticky': if true, the syntax highlighting options defined by this rule will apply to all children as well, effectively overriding their options. The default is false. For a `:function', `:sticky' will not work. Instead, return a true secondary value from the function." (check-type name symbol) `(progn (fmakunbound ',name) (defgeneric ,name (view parser-symbol) (:method (view (parser-symbol parser-symbol)) nil)) ,@(flet ((make-rule-exp (type args) (let ((actual-type (first (listed type)))) (destructuring-bind (&key sticky) (rest (listed type)) (case actual-type (:face `(let ((options (make-drawing-options :face (make-face ,@args)))) #'(lambda (view parser-symbol) (declare (ignore view parser-symbol)) (values options ,sticky)))) (:options `#'(lambda (view parser-symbol) (declare (ignore view parser-symbol)) (values (make-drawing-options ,@args) ,sticky))) (:function (first args)) (t `#'(lambda (view parser-symbol) (declare (ignore view parser-symbol)) (values ,actual-type ,sticky)))))))) (loop for (parser-symbol (type . args)) in rules collect `(let ((rule ,(make-rule-exp type args))) (defmethod ,name (view (parser-symbol ,parser-symbol)) (funcall rule view parser-symbol))))))) (define-syntax-highlighting-rules default-syntax-highlighting) (defgeneric syntax-highlighting-rules (syntax) (:documentation "Return the drawing options that should be used for displaying `parser-symbol's for `syntax'. A method should be defined on this function for any syntax that wants syntax highlighting.") (:method ((syntax lr-syntax-mixin)) 'default-syntax-highlighting)) (defun get-drawing-options (highlighting-rules view parse-symbol) "Get the drawing options with which `parse-symbol' should be drawn. If `parse-symbol' or the stack-top of syntax, return NIL. `View' must be a `drei-syntax-view' containing a syntax that `highlighting-rules' supports." (when (and parse-symbol (not (eq (stack-top (syntax view)) parse-symbol))) (funcall highlighting-rules view parse-symbol))) (defstruct (pump-state (:constructor make-pump-state (parser-symbol offset drawing-options highlighting-rules))) "A pump state object used in the LR syntax module. `parser-symbol' is the a parse symbol object `offset' is in. `Drawing-options' is a stack with elements `(end-offset drawing-options)', where `end-offset' specifies there the drawing options specified by `drawing-options' stop. `Highlighting-rules' is the rules that are used for syntax highlighting." parser-symbol offset drawing-options highlighting-rules) (defstruct (drawing-options-frame (:constructor make-drawing-options-frame (end-offset drawing-options sticky-p)) (:conc-name frame-)) "An entry in the drawing options stack maintained by the `pump-state' structure. `End-offset' is the end buffer offset for the frame, `drawing-options' is the drawing options that should be used until that offset, and if `sticky-p' is true it will not be possible to put other frames on top of this one in the stack." end-offset drawing-options sticky-p) (defmethod pump-state-for-offset-with-syntax ((view textual-drei-syntax-view) (syntax lr-syntax-mixin) (offset integer)) (update-parse syntax 0 (size (buffer view))) (let ((parser-symbol (parser-symbol-containing-offset syntax offset)) (highlighting-rules (syntax-highlighting-rules syntax))) (labels ((initial-drawing-options (parser-symbol) (if (null parser-symbol) (make-drawing-options-frame (size (buffer view)) +default-drawing-options+ nil) (multiple-value-bind (drawing-options sticky) (get-drawing-options highlighting-rules view parser-symbol) (if (null drawing-options) (initial-drawing-options (parent parser-symbol)) (make-drawing-options-frame (end-offset parser-symbol) drawing-options sticky)))))) (make-pump-state parser-symbol offset (list (initial-drawing-options parser-symbol) (make-drawing-options-frame (1+ (size (buffer view))) +default-drawing-options+ nil)) highlighting-rules)))) (defun find-next-stroke-end (view pump-state) "Assuming that `pump-state' contains the previous pump state, find out where the next stroke should end, and possibly push some drawing options onto `pump-state'." (with-accessors ((start-symbol pump-state-parser-symbol) (offset pump-state-offset) (drawing-options pump-state-drawing-options) (highlighting-rules pump-state-highlighting-rules)) pump-state (let* ((line (line-containing-offset view offset)) (line-end-offset (end-offset line))) (flet ((finish (new-offset symbol &optional stroke-drawing-options sticky-p) (setf start-symbol symbol) (loop until (> (frame-end-offset (first drawing-options)) new-offset) do (pop drawing-options)) (unless (null stroke-drawing-options) (push (if (frame-sticky-p (first drawing-options)) (make-drawing-options-frame (end-offset symbol) (frame-drawing-options (first drawing-options)) t) (make-drawing-options-frame (end-offset symbol) stroke-drawing-options sticky-p)) drawing-options)) (return-from find-next-stroke-end new-offset))) (cond ((null start-symbol) ;; This means that all remaining lines are blank. (finish line-end-offset nil)) ((and (typep start-symbol 'literal-object-mixin) (= offset (start-offset start-symbol))) (finish (end-offset start-symbol) start-symbol nil)) (t (or (let* ((current-frame (first drawing-options)) (currently-used-options (frame-drawing-options current-frame))) (do-parse-symbols-forward (symbol offset start-symbol) (multiple-value-bind (symbol-drawing-options sticky) (get-drawing-options highlighting-rules view symbol) ;; Remove frames that are no longer applicable... (loop until (> (frame-end-offset (first drawing-options)) (start-offset symbol)) do (pop drawing-options)) (let ((options-to-be-used (if (frame-sticky-p (first drawing-options)) (frame-drawing-options (first drawing-options)) symbol-drawing-options))) (cond ((> (start-offset symbol) line-end-offset) (finish line-end-offset start-symbol)) ((and (typep symbol 'literal-object-mixin)) (finish (start-offset symbol) symbol (or symbol-drawing-options (make-drawing-options :function (object-drawer))))) ((and (> (start-offset symbol) offset) (not (drawing-options-equal (or options-to-be-used +default-drawing-options+) currently-used-options)) (if (null symbol-drawing-options) (>= (start-offset symbol) (frame-end-offset current-frame)) t)) (finish (start-offset symbol) symbol symbol-drawing-options sticky)) ((and (= (start-offset symbol) offset) symbol-drawing-options (not (drawing-options-equal options-to-be-used (frame-drawing-options (first drawing-options))))) (finish (start-offset symbol) symbol symbol-drawing-options sticky))))))) ;; If there are no more parse symbols, we just go ;; line-by-line from here. This should mean that all ;; remaining lines are blank. (finish line-end-offset nil)))))))) (defmethod stroke-pump-with-syntax ((view textual-drei-syntax-view) (syntax lr-syntax-mixin) stroke (pump-state pump-state)) ;; `Pump-state' will be destructively modified. (prog1 pump-state (with-accessors ((offset pump-state-offset) (current-drawing-options pump-state-drawing-options)) pump-state (let ((old-drawing-options (frame-drawing-options (first current-drawing-options))) (end-offset (find-next-stroke-end view pump-state)) (old-offset offset)) (setf (stroke-start-offset stroke) offset (stroke-end-offset stroke) end-offset (stroke-drawing-options stroke) old-drawing-options offset (if (offset-end-of-line-p (buffer view) end-offset) (1+ end-offset) end-offset)) ;; Don't use empty strokes, try again... (when (= old-offset offset) (stroke-pump-with-syntax view syntax stroke pump-state)))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/views.lisp0000644000175000017500000014164611345155772017736 0ustar pdmpdm;;; -*- Mode: Lisp; Package: DREI -*- ;;; (c) copyright 2007 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; ;;; This file contains definitions for Dreis "views", objects that are ;;; used as the actual content of a Drei instance. Drei displays a ;;; view of something, most commonly a buffer, and this view imposes ;;; its own rules on how it sees the buffer contents, the typical ;;; example being parsing it and displaying it with syntax ;;; highlighting. The special buffer classes used by views are also ;;; defined in this file. (in-package :drei) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Conditions. (define-condition user-condition-mixin () () (:documentation "Conditions of this type are caught by the Drei command loop and their report displayed to the user in the minibuffer, instead of being propagated further (and possibly invoking the debugger).")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Tabify (defvar *use-tabs-for-indentation* nil "If non-NIL, use tabs when indenting lines. Otherwise, use spaces.") (defclass tabify-mixin () ((%tab-space-count :initform 8 :accessor tab-space-count :initarg :tab-space-count) ;; We save the old values for performance. Doesn't take text-style ;; into account (for performance!) (%space-width :accessor recorded-space-width :initform nil) (%tab-width :accessor recorded-tab-width :initform nil) (%recorded-stream :accessor recorded-stream :initform nil) (%use-tabs :accessor use-tabs :initform *use-tabs-for-indentation* :initarg :use-tabs) (%tab-stops :accessor tab-stops :initform '() :initarg :tab-stops :documentation "A list of tab-stops in device units. If empty, tabs every TAB-WIDTH are assumed."))) (defun maybe-update-recordings (stream tabify) (with-accessors ((space-width recorded-space-width) (tab-width recorded-tab-width) (recorded-stream recorded-stream)) tabify (unless (eq stream recorded-stream) ;; Update the recorded values. (setf space-width (stream-character-width stream #\Space) tab-width (stream-character-width stream #\Tab) recorded-stream stream)))) (defgeneric space-width (stream tabify) (:documentation "Return the width of a space character on `stream' in device units (most likely pixels).") (:method ((stream extended-output-stream) (tabify tabify-mixin)) (maybe-update-recordings stream tabify) (recorded-space-width tabify))) (defgeneric tab-width (stream tabify) (:documentation "Return the width of a tab character on `stream' in device units (most likely pixels).") (:method ((stream extended-output-stream) (tabify tabify-mixin)) (if (tab-space-count tabify) (* (tab-space-count tabify) (space-width stream tabify)) (recorded-tab-width tabify)))) (defgeneric next-tab-stop (stream tabify x) (:documentation "Return the distance to the next tab-stop after `x' on `stream' in device units (most likely pixels).") (:method ((stream extended-output-stream) (tabify tabify-mixin) x) (flet ((round-up (x width) (- width (mod x width)))) (if (tab-stops tabify) (let ((next (find-if (lambda (pos) (> pos x)) (tab-stops tabify)))) (or (and next (- next x)) (round-up x (space-width stream tabify)))) (round-up x (tab-width stream tabify)))))) (defgeneric (setf tab-stop-columns) (column-list tabify) (:documentation "Set the TAB-STOPS of view at the character column offsets in `column-list'.") (:method (column-list (tabify tabify-mixin)) (setf (tab-stops tabify) (and column-list (sort (mapcar (lambda (col) (* col (space-width (recorded-stream tabify) tabify))) column-list) #'<))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Undo (defgeneric undo-tree (buffer) (:documentation "The undo-tree object associated with the buffer. This usually contains a record of every change that has been made to the buffer since it was created.")) (defgeneric undo-accumulate (buffer) (:documentation "A list of the changes that have been made to `buffer' since the last time undo was added to the undo tree for the buffer. The list returned by this function is initially NIL (the empty list). The :before methods on `insert-buffer-object', `insert-buffer-sequence', and `delete-buffer-range' push undo records on to this list.")) (defgeneric performing-undo (buffer) (:documentation "If true, the buffer is currently performing an undo operation. The :before methods on `insert-buffer-object', `insert-buffer-sequence', and `delete-buffer-range' push undo records onto the undo accumulator only if `performing-undo' is false, so that no undo information is added as a result of an undo operation.")) (defclass undo-mixin () ((tree :initform (make-instance 'standard-undo-tree) :reader undo-tree :documentation "Returns the undo-tree of the buffer.") (undo-accumulate :initform '() :accessor undo-accumulate :documentation "The undo records created since the start of the undo context.") (performing-undo :initform nil :accessor performing-undo :documentation "True if we are currently performing undo, false otherwise.")) (:documentation "This is a mixin class that buffer classes can inherit from. It contains an undo tree, an undo accumulator and a flag specifyng whether or not it is currently performing undo. The undo tree and undo accumulators are initially empty.")) (defclass drei-undo-record (standard-undo-record) ((buffer :initarg :buffer :documentation "The buffer to which the record belongs.")) (:documentation "A base class for all output records in Drei.")) (defclass simple-undo-record (drei-undo-record) ((offset :initarg :offset :reader undo-offset :documentation "The offset that determines the position at which the undo operation is to be executed.")) (:documentation "A base class for output records that modify buffer contents at a specific offset.")) (defclass insert-record (simple-undo-record) ((objects :initarg :objects :documentation "The sequence of objects that are to be inserted whenever flip-undo-record is called on an instance of insert-record.")) (:documentation "Whenever objects are deleted, the sequence of objects is stored in an insert record containing a mark.")) (defclass delete-record (simple-undo-record) ((length :initarg :length :documentation "The length of the sequence of objects to be deleted whenever `flip-undo-record' is called on an instance of `delete-record'.")) (:documentation "Whenever objects are inserted, a `delete-record' containing a mark is created and added to the undo tree.")) (defclass change-record (simple-undo-record) ((objects :initarg :objects :documentation "The sequence of objects that are to replace the records that are currently in the buffer at the offset whenever flip-undo-record is called on an instance of change-record")) (:documentation "Whenever objects are modified, a `change-record' containing a mark is created and added to the undo tree.")) (defclass compound-record (drei-undo-record) ((records :initform '() :initarg :records :documentation "The undo records contained by this compound record.")) (:documentation "This record simply contains a list of other records.")) (defmethod print-object ((object delete-record) stream) (with-slots (offset length) object (format stream "[offset: ~a length: ~a]" offset length))) (defmethod print-object ((object insert-record) stream) (with-slots (offset objects) object (format stream "[offset: ~a inserted objects: ~a]" offset objects))) (defmethod print-object ((object change-record) stream) (with-slots (offset objects) object (format stream "[offset: ~a changed objects: ~a]" offset objects))) (defmethod print-object ((object compound-record) stream) (with-slots (records) object (format stream "[records: ~a]" records))) (defmethod insert-buffer-object :before ((buffer undo-mixin) offset object) (declare (ignore object)) (unless (performing-undo buffer) (push (make-instance 'delete-record :buffer buffer :offset offset :length 1) (undo-accumulate buffer)))) (defmethod insert-buffer-sequence :before ((buffer undo-mixin) offset sequence) (unless (performing-undo buffer) (push (make-instance 'delete-record :buffer buffer :offset offset :length (length sequence)) (undo-accumulate buffer)))) (defmethod delete-buffer-range :before ((buffer undo-mixin) offset n) (unless (performing-undo buffer) (push (make-instance 'insert-record :buffer buffer :offset offset :objects (buffer-sequence buffer offset (+ offset n))) (undo-accumulate buffer)))) (defmethod (setf buffer-object) :before (new-object (buffer undo-mixin) offset) (unless (performing-undo buffer) (push (make-instance 'change-record :buffer buffer :offset offset :objects (buffer-sequence buffer offset (1+ offset))) (undo-accumulate buffer)))) (defmacro with-undo ((get-buffers-exp) &body body) "This macro executes the forms of `body', registering changes made to the list of buffers retrieved by evaluating `get-buffers-exp'. When `body' has run, for each buffer it will call `add-undo' with an undo record and the undo tree of the buffer. If the changes done by `body' to the buffer has resulted in only a single undo record, it is passed as is to `add-undo'. If it contains several undo records, a compound undo record is constructed out of the list and passed to `add-undo'. Finally, if the buffer has no undo records, `add-undo' is not called at all." (with-gensyms (buffer) `(progn (dolist (,buffer ,get-buffers-exp) (setf (undo-accumulate ,buffer) '())) (unwind-protect (progn ,@body) (dolist (,buffer ,get-buffers-exp) (cond ((null (undo-accumulate ,buffer)) nil) ((null (cdr (undo-accumulate ,buffer))) (add-undo (car (undo-accumulate ,buffer)) (undo-tree ,buffer))) (t (add-undo (make-instance 'compound-record :buffer ,buffer :records (undo-accumulate ,buffer)) (undo-tree ,buffer))))))))) (defmethod flip-undo-record :around ((record drei-undo-record)) (with-slots (buffer) record (let ((performing-undo (performing-undo buffer))) (setf (performing-undo buffer) t) (unwind-protect (call-next-method) (setf (performing-undo buffer) performing-undo))))) (defmethod flip-undo-record ((record insert-record)) (with-slots (buffer offset objects) record (change-class record 'delete-record :length (length objects)) (insert-buffer-sequence buffer offset objects))) (defmethod flip-undo-record ((record delete-record)) (with-slots (buffer offset length) record (change-class record 'insert-record :objects (buffer-sequence buffer offset (+ offset length))) (delete-buffer-range buffer offset length))) (defmethod flip-undo-record ((record change-record)) (with-slots (buffer offset objects) record (loop for i from 0 below (length objects) do (rotatef (aref objects i) (buffer-object buffer (+ i offset)))))) (defmethod flip-undo-record ((record compound-record)) (with-slots (records) record (mapc #'flip-undo-record records) (setf records (nreverse records)))) (defgeneric clear-undo-history (undo-maintainer) (:documentation "Clear the undo history for `undo-maintainer', preventing the undoing to before the state of whatever `undo-maintainer' is maintaining undo for.")) (defmethod clear-undo-history ((undo-maintainer undo-mixin)) (setf (slot-value undo-maintainer 'tree) (make-instance 'standard-undo-tree) (undo-accumulate undo-maintainer) '())) ;;; undo-mixin delegation (here because of the package) (defmethod undo-tree ((buffer delegating-buffer)) (undo-tree (implementation buffer))) (defmethod undo-accumulate ((buffer delegating-buffer)) (undo-accumulate (implementation buffer))) (defmethod (setf undo-accumulate) (object (buffer delegating-buffer)) (setf (undo-accumulate (implementation buffer)) object)) (defmethod performing-undo ((buffer delegating-buffer)) (performing-undo (implementation buffer))) (defmethod (setf performing-undo) (object (buffer delegating-buffer)) (setf (performing-undo (implementation buffer)) object)) (defmethod clear-undo-history ((buffer delegating-buffer)) (clear-undo-history (implementation buffer))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Readonly (defclass read-only-mixin () ((read-only-p :initform nil :accessor read-only-p :initarg :read-only))) (define-condition buffer-read-only (user-condition-mixin simple-error) ((buffer :reader condition-buffer :initarg :buffer)) (:report (lambda (condition stream) (format stream "Attempt to change read only buffer: ~a" (condition-buffer condition)))) (:documentation "This condition is signalled whenever an attempt is made to alter a buffer which has been set read only.")) (defmethod insert-buffer-object ((buffer read-only-mixin) offset object) (if (read-only-p buffer) (error 'buffer-read-only :buffer buffer) (call-next-method))) (defmethod insert-buffer-sequence ((buffer read-only-mixin) offset sequence) (if (read-only-p buffer) (error 'buffer-read-only :buffer buffer) (call-next-method))) (defmethod delete-buffer-range ((buffer read-only-mixin) offset n) (if (read-only-p buffer) (error 'buffer-read-only :buffer buffer) (call-next-method))) (defmethod (setf buffer-object) (object (buffer read-only-mixin) offset) (if (read-only-p buffer) (error 'buffer-read-only :buffer buffer) (call-next-method))) (defmethod read-only-p ((buffer delegating-buffer)) (read-only-p (implementation buffer))) (defmethod (setf read-only-p) (flag (buffer delegating-buffer)) (setf (read-only-p (implementation buffer)) flag)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Single-line buffer. (defclass single-line-mixin () ((%single-line-p :initform nil :accessor single-line-p :initarg :single-line)) (:documentation "Prevent the insertion of #\Newline characters into the buffer if `single-line-p' is true.")) (define-condition buffer-single-line (user-condition-mixin simple-error) ((buffer :reader condition-buffer :initarg :buffer)) (:report "Attempt to insert newline into single-line buffer.") (:documentation "This condition is signalled whenever an attempt is made to insert a #\Newline character into a single-line buffer.")) (defmethod insert-buffer-object :before ((buffer single-line-mixin) offset (object (eql #\Newline))) (when (single-line-p buffer) (error 'buffer-single-line :buffer buffer))) (defmethod insert-buffer-sequence :before ((buffer single-line-mixin) offset sequence) (when (and (single-line-p buffer) (find #\Newline sequence)) (error 'buffer-single-line :buffer buffer))) (defmethod (setf buffer-object) :before ((object (eql #\Newline)) (buffer single-line-mixin) offset) (when (single-line-p buffer) (error 'buffer-single-line :buffer buffer))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; The Drei buffer. (defclass extended-standard-buffer (single-line-mixin read-only-mixin standard-buffer undo-mixin abbrev-mixin observable-buffer-mixin) () (:documentation "Extensions accessible via marks.")) (defclass extended-binseq2-buffer (single-line-mixin read-only-mixin binseq2-buffer p-undo-mixin abbrev-mixin observable-buffer-mixin) () (:documentation "Extensions accessible via marks.")) (defclass drei-buffer (delegating-buffer esa-buffer-mixin observable-buffer-mixin) ((point :initarg :point :initform nil :accessor point-of)) (:default-initargs :implementation (make-instance 'extended-standard-buffer))) (defmethod initialize-instance :after ((buffer drei-buffer) &rest args &key read-only single-line initial-contents) (declare (ignore args)) (with-accessors ((point point) (implementation implementation)) buffer (when initial-contents (check-type initial-contents array) (insert-buffer-sequence buffer 0 initial-contents)) (setf point (make-buffer-mark buffer 0 :right)) (setf (read-only-p implementation) read-only (single-line-p implementation) single-line) ;; Hack: we need to be told whenever the undo facilities in the ;; implementation buffer changes the buffer contents. (add-observer (implementation buffer) buffer))) (defmethod observer-notified ((observer drei-buffer) (observable observable-buffer-mixin) data) (notify-observers observer (constantly data))) (defmethod notify-observers :after ((buffer drei-buffer) &optional data-fn) (declare (ignore data-fn)) ;; This means that any buffer modification sets the needs-saving ;; flag to true. It might be nice if undo back to the last saved ;; state would set it to false. (setf (needs-saving buffer) t)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; View classes. (defclass drei-view (tabify-mixin subscriptable-name-mixin) ((%active :accessor active :initform t :initarg :active :type boolean :documentation "A boolean value indicating whether the view is \"active\". This should control highlighting when redisplaying.") (%modified-p :accessor modified-p :initform nil :initarg :modified-p :documentation "This value is true if the view contents have been modified since the last time this value was set to false.") (%no-cursors :accessor no-cursors :initarg :no-cursors :initform nil :documentation "True if the view does not display cursors.") (%full-redisplay-p :accessor full-redisplay-p :initform nil :documentation "True if the view should be fully redisplayed the next time it is redisplayed.") (%use-editor-commands :accessor use-editor-commands-p :initarg :use-editor-commands :initform nil :documentation "If the view is supposed to support standard editor commands (for inserting objects, moving cursor, etc), this will be true. If you want your view to support standard editor commands, you should *not* inherit from `editor-table' - the command tables containing the editor commands will be added automatically, as long as this value is true.") (%extend-pane-bottom :accessor extend-pane-bottom :initarg :extend-pane-bottom :initform nil :documentation "Resize the output pane vertically during redisplay (using `change-space-requirements'), in order to fit the whole buffer. If this value is false, redisplay will stop when the bottom of the pane is reached.")) (:metaclass modual-class) (:documentation "The base class for all Drei views. A view observes some other object and provides a visual representation for Drei.") (:default-initargs :name "*scratch*")) (defmethod print-object ((view drei-view) stream) (print-unreadable-object (view stream :type t :identity t) (format stream "name: ~a ~a" (name view) (subscript view)))) (defmethod available-modes append ((modual drei-view)) *global-modes*) (defmethod mode-applicable-p or ((modual drei-view) mode-name) (mode-applicable-p (syntax modual) mode-name)) (defgeneric synchronize-view (view &key &allow-other-keys) (:documentation "Synchronize the view with the object under observation - what exactly this entails, and what keyword arguments are supported, is up to the individual view subclass.") (:method ((view drei-view) &key) nil)) (defgeneric view-command-tables (view) (:documentation "Return a list of command tables containing commands relevant for `view'.") (:method-combination append) (:method append ((view drei-view)) '(view-table))) (defgeneric create-view-cursors (output-stream view) (:documentation "Create cursors for `view' that are to be displayed on `output-stream'.") (:method nconc (output-stream (view drei-view)) '()) (:method :around (output-stream (view drei-view)) (unless (no-cursors view) (call-next-method))) (:method-combination nconc)) (defgeneric clear-redisplay-information (view) (:documentation "Clear any redisplay information `view' may retain, so that a full redisplay will be performed the next time it is redisplayed.")) (defgeneric clone-view (view &rest initargs) (:documentation "Clone the view object `view'. `Initargs' can be used to supply different values to the initargs of the class. A default method doing slot-by-slot copying of `view' has been defined that should be appropriate for most view classes.") (:method ((view view) &rest initargs) ;; We iterate over the slots of `view', remembering the value and ;; initarg for any slot with an initarg, and use this to create ;; the new `make-instance' form. We assume that any slot with no ;; initarg will get its value from an `initialize-instance' method ;; or similar. (apply #'make-instance (class-of view) (append initargs (loop for slot in (clim-mop:class-slots (class-of view)) for slot-initarg = (first (clim-mop:slot-definition-initargs slot)) for slot-name = (clim-mop:slot-definition-name slot) for slot-boundp = (slot-boundp view slot-name) when (and slot-initarg slot-boundp) nconc (list slot-initarg (slot-value view slot-name))))))) (defgeneric page-down (pane view) (:documentation "Scroll `view', which is displayed on `pane', a page up.")) (defgeneric page-up (pane view) (:documentation "Scroll `view', which is displayed on `pane', a page up.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Buffer view (defclass drei-buffer-view (drei-view) ((%buffer :accessor buffer :initarg :buffer :type drei-buffer :accessor buffer :documentation "The buffer that is observed by this buffer view.") (%top :accessor top :documentation "The top of the displayed buffer, that is, the mark indicating the first visible object in the buffer.") (%bot :accessor bot :documentation "The bottom of the displayed buffer, that is, the mark indicating the last visible object in the buffer.") (%cache-string :reader cache-string :initform (make-array 0 :element-type 'character :adjustable t :fill-pointer 0) :documentation "A string used during redisplay to reduce consing. Instead of consing up a new string every time we need to pull out a buffer region, we put it in this string. The fill pointer is automatically set to zero whenever the string is accessed through the reader.") (%displayed-lines :accessor displayed-lines :initform (make-array 0 :element-type 'displayed-line :initial-element (make-displayed-line)) :type array :documentation "An array of the `displayed-line' objects displayed by the view. Not all of these are live.") (%displayed-lines-count :accessor displayed-lines-count :initform 0 :type integer :documentation "The number of lines in the views `displayed-lines' array that are actually live, that is, used for display right now.") (%max-line-width :accessor max-line-width :initform 0 :type number :documentation "The width of the longest displayed line in device units.") (%lines :initform (make-instance 'standard-flexichain) :reader lines :documentation "The lines of the buffer, stored in a format that makes it easy to retrieve information about them.") (%lines-prefix :accessor lines-prefix-size :documentation "The number of unchanged objects at the start of the buffer since the list of lines was last updated.") (%lines-suffix :accessor lines-suffix-size :documentation "The number of unchanged objects at the end of the buffer since since the list of lines was last updated.") (%last-seen-buffer-size :accessor last-seen-buffer-size :documentation "The buffer size the last time a change to the buffer was registered.")) (:metaclass modual-class) (:documentation "A view that contains a `drei-buffer' object. The buffer is displayed on a simple line-by-line basis, with top and bot marks delimiting the visible region. These marks are automatically set if applicable.")) (defmethod initialize-instance :after ((view drei-buffer-view) &rest initargs &key buffer single-line read-only initial-contents) (declare (ignore initargs)) (with-accessors ((top top) (bot bot) (lines-prefix lines-prefix-size) (lines-suffix lines-suffix-size) (buffer-size last-seen-buffer-size)) view (unless buffer ;; So many fun things are defined on (setf buffer) that we use ;; slot-value here. This is just a glorified initform anyway. (setf (slot-value view '%buffer) (make-instance 'drei-buffer :single-line single-line :read-only read-only :initial-contents initial-contents))) (setf top (make-buffer-mark (buffer view) 0 :left) bot (clone-mark top :right) lines-prefix 0 lines-suffix 0 buffer-size (size (buffer view))) (update-line-data view))) (defmethod (setf top) :after (new-value (view drei-buffer-view)) (invalidate-all-strokes view)) (defmethod (setf bot) :after (new-value (view drei-buffer-view)) (invalidate-all-strokes view)) (defmethod (setf buffer) :after (buffer (view drei-buffer-view)) (invalidate-all-strokes view) (with-accessors ((top top) (bot bot) (lines lines) (lines-prefix lines-prefix-size) (lines-suffix lines-suffix-size) (buffer-size last-seen-buffer-size)) view (setf top (make-buffer-mark buffer 0 :left) bot (clone-mark top :right) lines-prefix 0 lines-suffix 0 buffer-size 0) (delete-elements* lines 0 (nb-elements lines)) (update-line-data view))) (defmethod cache-string :around ((view drei-buffer-view)) (let ((string (call-next-method))) (setf (fill-pointer string) 0) string)) (defun buffer-view-p (view) "Return true if `view' is a `drei-buffer-view'." (typep view 'drei-buffer-view)) (defmethod clear-redisplay-information ((view drei-buffer-view)) (invalidate-all-strokes view)) (defun overlaps (x1 x2 y1 y2) "Return true if the x1/x2 region overlaps with y1/y2." (or (<= x1 y1 x2) (<= y1 x1 y2) (<= y1 x1 x2 y2) (<= x1 y1 y1 x2))) (defclass buffer-line () ((%start-mark :reader start-mark :initarg :start-mark :documentation "The mark at which this line starts.") (%end-mark :reader end-mark :initarg :end-mark :documentation "The mark at which this line ends.") (%chunks :accessor chunks :initform (make-array 5 :adjustable t :fill-pointer 0) :documentation "A list of cons-cells, with the car being a buffer offset relative to the `start-mark' of the line, and the cdr being T if the chunk covers a non-character, and NIL if it covers a character sequence.")) (:documentation "An object describing a single line in the buffer associated with a `drei-buffer-view'")) (defmethod initialize-instance :after ((line buffer-line) &rest initargs) (declare (ignore initargs)) (loop with buffer = (buffer (start-mark line)) with line-start-offset = (offset (start-mark line)) with line-end-offset = (+ line-start-offset (line-length line)) with chunk-start-offset = line-start-offset for chunk-info = (get-chunk buffer line-start-offset chunk-start-offset line-end-offset) do (vector-push-extend chunk-info (chunks line)) (setf chunk-start-offset (+ (car chunk-info) line-start-offset)) when (= chunk-start-offset line-end-offset) do (loop-finish))) (defmethod start-offset ((line buffer-line)) (offset (start-mark line))) (defmethod end-offset ((line buffer-line)) (offset (end-mark line))) (defun line-length (line) "Return the length of the `buffer-line' object `line'." (- (end-offset line) (start-offset line))) (defvar *maximum-chunk-size* 100 "The maximum amount of objects put into a single chunk by a `drei-buffer-view'. Actual chunks may be smaller if a #\Newline character is encountered.") (defun get-chunk (buffer line-start-offset chunk-start-offset line-end-offset) "Return a chunk in the form of a cons cell. The chunk will start at `chunk-start-offset' and extend no further than `line-end-offset'." (let* ((chunk-end-offset (buffer-find-nonchar buffer chunk-start-offset (min (+ *maximum-chunk-size* chunk-start-offset) line-end-offset)))) (cond ((= chunk-start-offset line-end-offset) (cons (- chunk-end-offset line-start-offset) nil)) ((or (not (= chunk-end-offset chunk-start-offset)) (and (offset-beginning-of-line-p buffer chunk-start-offset) (offset-end-of-line-p buffer chunk-end-offset))) (cons (- chunk-end-offset line-start-offset) nil)) ((not (characterp (buffer-object buffer chunk-end-offset))) (cons (- (1+ chunk-end-offset) line-start-offset) t))))) (defun update-line-data (view) "Update the sequence of lines stored by the `drei-buffer-view' `view'." (with-accessors ((prefix-size lines-prefix-size) (suffix-size lines-suffix-size)) view (when (<= prefix-size (- (size (buffer view)) suffix-size)) (let ((low-mark (make-buffer-mark (buffer view) prefix-size :left)) (high-mark (make-buffer-mark (buffer view) (- (size (buffer view)) suffix-size) :left))) (beginning-of-line low-mark) (end-of-line high-mark) (with-accessors ((lines lines)) view (let ((low-index 0) (high-index (nb-elements lines))) ;; Binary search for the start of changed lines. (loop while (< low-index high-index) do (let* ((middle (floor (+ low-index high-index) 2)) (line-start (start-mark (element* lines middle)))) (cond ((mark> low-mark line-start) (setf low-index (1+ middle))) (t (setf high-index middle))))) ;; Discard lines that have to be re-analyzed. (loop while (and (< low-index (nb-elements lines)) (mark<= (start-mark (element* lines low-index)) high-mark)) do (delete* lines low-index)) ;; Analyze new lines. (loop while (mark<= low-mark high-mark) for i from low-index do (progn (let ((line-start-mark (clone-mark low-mark :left)) (line-end-mark (clone-mark (end-of-line low-mark) :right))) (insert* lines i (make-instance 'buffer-line :start-mark line-start-mark :end-mark line-end-mark)) (if (end-of-buffer-p low-mark) (loop-finish) ;; skip newline (forward-object low-mark))))))))) (setf prefix-size (size (buffer view)) suffix-size (size (buffer view))))) (defmethod observer-notified ((view drei-buffer-view) (buffer drei-buffer) changed-region) (destructuring-bind (start-offset . end-offset) changed-region (with-accessors ((prefix-size lines-prefix-size) (suffix-size lines-suffix-size) (buffer-size last-seen-buffer-size)) view ;; Figure out whether the change involved insertion or deletion of ;; a newline. (let* ((line-index (index-of-line-containing-offset view start-offset)) (line (element* (lines view) line-index)) (newline-change (or (loop for index from start-offset below end-offset when (equal (buffer-object (buffer view) index) #\Newline) return t) ;; If the line is joined with the one before or ;; after it, a newline object has been removed. (or (when (< (1+ line-index) (nb-elements (lines view))) (= (start-offset (element* (lines view) (1+ line-index))) (end-offset line))) (when (plusp line-index) (= (end-offset (element* (lines view) (1- line-index))) (start-offset line))))))) ;; If the line structure changed, everything after the newline is suspect. (invalidate-strokes-in-region view start-offset (if newline-change (max start-offset (offset (bot view))) end-offset) :modified t :to-line-end t) (setf prefix-size (min start-offset prefix-size) suffix-size (min (- (size buffer) end-offset) suffix-size) buffer-size (size buffer)) ;; If the line structure changed, we need to update the line ;; data, or we can't pick up future changes correctly. (when newline-change (update-line-data view)))))) (defmethod synchronize-view ((view drei-buffer-view) &key) (update-line-data view)) ;;; Exploit the stored line information. (defun offset-in-line-p (line offset) "Return true if `offset' is in the buffer region delimited by `line'." (<= (offset (start-mark line)) offset (end-offset line))) (defun index-of-line-containing-offset (view mark-or-offset) "Return the index of the line `mark-or-offset' is in for `view'. `View' must be a `drei-buffer-view'." ;; Perform binary search looking for line containing `offset1'. (as-offsets ((offset mark-or-offset)) (with-accessors ((lines lines)) view (loop with low-index = 0 with high-index = (nb-elements lines) for middle = (floor (+ low-index high-index) 2) for this-line = (element* lines middle) for line-start = (start-mark this-line) do (cond ((offset-in-line-p this-line offset) (loop-finish)) ((mark> offset line-start) (setf low-index (1+ middle))) ((mark< offset line-start) (setf high-index middle))) finally (return middle))))) (defun line-containing-offset (view mark-or-offset) "Return the line `mark-or-offset' is in for `view'. `View' must be a `drei-buffer-view'." ;; Perform binary search looking for line containing `offset1'. (as-offsets ((offset mark-or-offset)) (with-accessors ((lines lines)) view (element* lines (index-of-line-containing-offset view offset))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Syntax views (defclass drei-syntax-view (drei-buffer-view) ((%syntax :accessor syntax :documentation "An instance of the syntax class used for this syntax view.") (%prefix-size :accessor prefix-size :initform 0 :documentation "The number of unchanged objects at the beginning of the buffer.") (%suffix-size :accessor suffix-size :initform 0 :documentation "The number of unchanged objects at the end of the buffer.") (%recorded-buffer-size :accessor buffer-size :initform -1 :documentation "The size of the buffer the last time the view was synchronized.")) (:metaclass modual-class) (:documentation "A buffer-view that maintains a parse tree of the buffer, or otherwise pays attention to the syntax of the buffer.")) (defmethod initialize-instance :after ((view drei-syntax-view) &rest args &key (syntax *default-syntax*)) (declare (ignore args)) (check-type syntax (or symbol syntax)) (with-accessors ((buffer buffer) (suffix-size suffix-size) (prefix-size prefix-size)) view (setf (slot-value view '%syntax) (if (symbolp syntax) (make-syntax-for-view view syntax) syntax)) (add-observer (syntax view) view) (add-observer buffer view))) (defmethod (setf buffer) :before ((buffer drei-buffer) (view drei-syntax-view)) ;; Remove the observation of the old buffer. (with-accessors ((old-buffer buffer)) view (remove-observer old-buffer view))) (defmethod (setf buffer) :after ((buffer drei-buffer) (view drei-syntax-view)) ;; Add observation of the new buffer. (add-observer buffer view) ;; We need a new syntax object of the same type as the old one, and ;; to zero out the unchanged-prefix-values. (with-accessors ((view-syntax syntax)) view (setf view-syntax (make-syntax-for-view view (class-of view-syntax))))) (defmethod (setf syntax) :before (syntax (view drei-syntax-view)) (remove-observer (syntax view) view)) (defmethod (setf syntax) :after (syntax (view drei-syntax-view)) (add-observer syntax view) (setf (prefix-size view) 0 (suffix-size view) 0 (buffer-size view) -1)) (defun syntax-view-p (view) "Return true if `view' is a `drei-syntax-view'." (typep view 'drei-syntax-view)) (defmethod mode-enabled-p or ((modual drei-syntax-view) mode-name) (mode-enabled-p (syntax modual) mode-name)) (defmethod enable-mode ((modual drei-syntax-view) mode-name &rest initargs) (if (mode-applicable-p (syntax modual) mode-name) (apply #'enable-mode (syntax modual) mode-name initargs) (call-next-method))) (defmethod disable-mode ((modual drei-syntax-view) mode-name) (if (mode-applicable-p (syntax modual) mode-name) (disable-mode (syntax modual) mode-name) (call-next-method))) (defmethod observer-notified ((view drei-syntax-view) (buffer drei-buffer) changed-region) (destructuring-bind (start-offset . end-offset) changed-region (with-accessors ((prefix-size prefix-size) (suffix-size suffix-size) (modified-p modified-p)) view (setf prefix-size (min start-offset prefix-size) suffix-size (min (- (size buffer) end-offset) suffix-size) modified-p t))) (call-next-method)) (defmethod observer-notified ((view drei-syntax-view) (syntax syntax) changed-region) (destructuring-bind (start-offset . end-offset) changed-region (invalidate-strokes-in-region view start-offset end-offset :modified t))) (defun needs-resynchronization (view) "Return true if the the view of the buffer of `view' is potentially out of date. Return false otherwise." (not (= (prefix-size view) (suffix-size view) (buffer-size view) (size (buffer view))))) (defmethod synchronize-view ((view drei-syntax-view) &key (begin 0) (end (size (buffer view))) force-p) "Synchronize the syntax view with the underlying buffer. `Begin' and `end' are offsets specifying the region of the buffer that must be synchronised, defaulting to 0 and the size of the buffer respectively." (assert (>= end begin)) ;; If nothing changed, then don't call the other methods. (when (or (needs-resynchronization view) force-p) (let ((prefix-size (prefix-size view)) (suffix-size (suffix-size view))) ;; Set some minimum values here so if `update-syntax' calls ;; `update-parse' itself, we won't end with infinite recursion. (setf (prefix-size view) (max (if (> begin prefix-size) prefix-size end) prefix-size) (suffix-size view) (max (if (>= end (- (size (buffer view)) suffix-size)) (max (- (size (buffer view)) begin) suffix-size) suffix-size) suffix-size) (buffer-size view) (size (buffer view))) (multiple-value-bind (parsed-start parsed-end) (update-syntax (syntax view) prefix-size suffix-size begin end) (assert (>= parsed-end parsed-start)) ;; Now set the proper new values for prefix-size and ;; suffix-size. (setf (prefix-size view) (max (if (>= prefix-size parsed-start) parsed-end prefix-size) prefix-size) (suffix-size view) (max (if (>= parsed-end (- (size (buffer view)) suffix-size)) (- (size (buffer view)) parsed-start) suffix-size) suffix-size))))) (call-next-method)) (defun make-syntax-for-view (view syntax-symbol &rest args) (apply #'make-instance syntax-symbol :buffer (buffer view) :updater-fns (list (lambda (begin end) (synchronize-view view :begin begin :end end))) args)) (defgeneric pump-state-for-offset-with-syntax (view syntax offset) (:documentation "Return a pump state that will enable pumping strokes from `offset' in the buffer of `view' as specified by `syntax' (via `stroke-pump-for-syntax'). The pump state is not guaranteed to be valid past the next call to `stroke-pump-for-syntax' or `synchronize-view'. The results are undefined if `offset' is not at the beginning of a line.")) (defgeneric stroke-pump-with-syntax (view syntax stroke pump-state) (:documentation "Put stroke information in `stroke' as specified by `syntax', returns new pump-state. `Pump-state' must either be the result of a call to `pump-state-for-offset-with-syntax' or be the return value of an earlier call to `stroke-pump-with-syntax'. A pump state is not guaranteed to be valid past the next call to `stroke-pump-with-syntax' or `synchronize-view'. It is permissible for `pump-state' to be destructively modified by this function.")) (defclass point-mark-view (drei-buffer-view) ((%point :initform nil :initarg :point :accessor point-of) (%mark :initform nil :initarg :mark :accessor mark-of) (%goal-column :initform nil :accessor goal-column :documentation "The column that point will be attempted to be positioned in when moving by line.")) (:metaclass modual-class) (:documentation "A view class containing a point and a mark into its buffer.")) (defmethod initialize-instance :after ((view point-mark-view) &rest args) (declare (ignore args)) (with-accessors ((point point) (mark mark) (buffer buffer)) view (setf point (clone-mark (point buffer))) (setf mark (clone-mark (point buffer))))) (defmethod (setf buffer) :before ((buffer drei-buffer) (view point-mark-view)) ;; Set the point of the old buffer to the current point of the view, ;; so the next time the buffer is revealed, it will remember its ;; point. (setf (point (buffer view)) (point view))) (defmethod (setf buffer) :after ((buffer drei-buffer) (view point-mark-view)) (with-accessors ((point point) (mark mark)) view (setf point (clone-mark (point buffer)) mark (clone-mark (point buffer) :right)))) (defun point-mark-view-p (view) "Return true if `view' is a `point-mark-view'" (typep view 'point-mark-view)) (defclass textual-drei-syntax-view (drei-syntax-view point-mark-view textual-view) ((%auto-fill-mode :initform nil :accessor auto-fill-mode) (%auto-fill-column :initform 70 :accessor auto-fill-column) (%region-visible-p :initform nil :accessor region-visible-p) ;; for dynamic abbrev expansion (%original-prefix :initform nil :accessor original-prefix) (%prefix-start-offset :initform nil :accessor prefix-start-offset) (%dabbrev-expansion-mark :initform nil :accessor dabbrev-expansion-mark) (%overwrite-mode :initform nil :accessor overwrite-mode)) (:metaclass modual-class) (:default-initargs :use-editor-commands t) (:documentation "The \"default\" Drei view class. It displays a textual representation of the buffer, possibly with syntax highlighting, and maintains point and mark marks into the buffer, in order to permit useful editing commands.")) (defgeneric invalidate-strokes (view syntax) (:documentation "Called just before redisplay of the `textual-drei-syntax-view' `view' in order to give `syntax', which is the syntax of `view', a chance to mark part of the display as invalid due to do something not caused by buffer modification (for example, parenthesis matching). This function should return a list of pairs of buffer offsets, each pair delimiting a buffer region that should be redrawn.") (:method ((view textual-drei-syntax-view) (syntax syntax)) nil)) (defun invalidate-as-appropriate (view invalid-regions) "Invalidate strokes of `view' overlapping regions in `invalid-regions'. `Invalid-regions' is a list of conses of buffer offsets delimiting regions." (loop with top-offset = (offset (top view)) with bot-offset = (offset (bot view)) for (start . end) in invalid-regions do (as-region (start end) (when (overlaps start end top-offset bot-offset) (invalidate-strokes-in-region view start end :modified t :to-line-end t))))) (defmethod display-drei-view-contents :around (stream (view textual-drei-syntax-view)) (let ((invalid-regions (invalidate-strokes view (syntax view)))) (invalidate-as-appropriate view invalid-regions) (call-next-method) ;; We do not expect whatever ephemeral state that caused ;; invalidation to stick around until the next redisplay, so ;; whatever it imposed on us, mark as dirty immediately. (invalidate-as-appropriate view invalid-regions))) (defmethod create-view-cursors nconc ((output-stream extended-output-stream) (view textual-drei-syntax-view)) (unless (no-cursors view) (list (make-instance 'point-cursor :view view :output-stream output-stream) (make-instance 'mark-cursor :view view :output-stream output-stream)))) (defmethod view-command-tables append ((view textual-drei-syntax-view)) (syntax-command-tables (syntax view))) (defmethod use-editor-commands-p ((view textual-drei-syntax-view)) t) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/drawing-options.lisp0000644000175000017500000000771611345155772021724 0ustar pdmpdm;;; -*- Mode: Lisp; Package: DREI -*- ;;; (c) copyright 2008 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; A bunch of predefined drawing options, styles and faces to make ;;; syntax highlighting rules more elegant. (in-package :drei) ;;; Some general styles. (defvar +roman-face+ (make-face :style (make-text-style nil :roman nil)) "A face specifying a roman style, but with unspecified family and size.") (defvar +italic-face+ (make-face :style (make-text-style nil :italic nil)) "A face specifying an italic style, but with unspecified family and size.") (defvar +bold-face+ (make-face :style (make-text-style nil :bold nil)) "A face specifying a boldface style, but with unspecified family and size.") (defvar +bold-italic-face+ (make-face :style (make-text-style nil :bold nil)) "A face specifying an italic boldface style, but with unspecified family and size.") ;;; ...and their drawing options. (defvar +roman-face-drawing-options+ (make-drawing-options :face +roman-face+) "Options used for drawing with a roman face.") (defvar +italic-face-drawing-options+ (make-drawing-options :face +italic-face+) "Options used for drawing with an italic face.") (defvar +bold-face-drawing-options+ (make-drawing-options :face +bold-face+) "Options used for drawing with boldface.") (defvar +bold-italic-face-drawing-options+ (make-drawing-options :face +bold-italic-face+) "Options used for drawing with italic boldface.") ;;; Some drawing options for specific syntactical elements, ;;; approximately like GNU Emacs. These are not constants, as users ;;; may want to change them to fit their colour scheme. Of course, ;;; syntax highlighting rules are free to ignore these, but I think ;;; the default rules should at least use these. (defvar *keyword-drawing-options* (make-drawing-options :face (make-face :ink +red3+)) "The drawing options used for drawing the syntactical equivalent of keyword symbols. In Lisp, this is used for keyword symbols.") (defvar *special-operator-drawing-options* (make-drawing-options :face (make-face :ink +steel-blue+ :style (make-text-style nil :bold nil))) "The drawing options used for drawing the syntactical equivalent of special operators. In Lisp, this is used for macros and special operators, in most other languages, it should probably be used for language keywords.") (defvar *special-variable-drawing-options* (make-drawing-options :face (make-face :ink +darkgoldenrod4+)) "The drawing options used for drawing variables that are somehow special. In Lisp, this is used for globally bound non-constant variables with dynamic scope. In other language, it should probably be used for global variables or similar.") (defvar *string-drawing-options* (make-drawing-options :face (make-face :ink +green4+)) "The drawing options used for syntax-highlighting strings.") (defvar *comment-drawing-options* (make-drawing-options :face (make-face :ink +maroon+ :style (make-text-style nil :bold nil))) "The drawing options used for drawing comments in source code.") (defvar *error-drawing-options* (make-drawing-options :face (make-face :ink +red+)) "The drawing options used for drawing syntax errors.") cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/search-commands.lisp0000644000175000017500000005612611345155772021643 0ustar pdmpdm;;; -*- Mode: Lisp; Package: DREI-COMMANDS -*- ;;; (c) copyright 2004-2005 by ;;; Robert Strandh (strandh@labri.fr) ;;; (c) copyright 2004-2005 by ;;; Elliott Johnson (ejohnson@fasl.info) ;;; (c) copyright 2005 by ;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr) ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) ;;; (c) copyright 2007 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Search commands for Drei. (in-package :drei-commands) (defun simple-search (drei-instance search-function targets more-targets-predicate more-targets-fn) (let ((old-buffer (buffer (view drei-instance))) (old-offset (offset (point (view drei-instance))))) (activate-target-specification targets) (or (loop until (funcall search-function (point (view drei-instance))) if (funcall more-targets-predicate targets) do (funcall more-targets-fn targets) else return nil finally (return t)) (setf (buffer (view drei-instance)) old-buffer (offset (point (view drei-instance))) old-offset)))) (defun simple-search-forward (drei-instance search-function &optional (targets (funcall *default-target-creator* drei-instance))) (simple-search drei-instance search-function targets #'subsequent-targets-p #'next-target)) (defun simple-search-backward (drei-instance search-function &optional (targets (funcall *default-target-creator* drei-instance))) (simple-search drei-instance search-function targets #'preceding-targets-p #'previous-target)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; String search (define-command (com-string-search :name t :command-table search-table) ((string 'string :prompt "String Search")) "Prompt for a string and search forward for it. If found, leaves point after string. If not, leaves point where it is." (simple-search-forward (drei-instance) #'(lambda (mark) (search-forward mark string :test (case-relevant-test string))))) (define-command (com-reverse-string-search :name t :command-table search-table) ((string 'string :prompt "Reverse String Search")) "Prompt for a string and search backward for it. If found, leaves point before string. If not, leaves point where it is." (simple-search-backward (drei-instance) #'(lambda (mark) (search-backward mark string :test (case-relevant-test string))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Word search (define-command (com-word-search :name t :command-table search-table) ((word 'string :prompt "Search word")) "Prompt for a whitespace delimited word and search forward for it. If found, leaves point after the word. If not, leaves point where it is." (simple-search-forward (drei-instance) #'(lambda (mark) (search-word-forward mark word)))) (define-command (com-reverse-word-search :name t :command-table search-table) ((word 'string :prompt "Search word")) "Prompt for a whitespace delimited word and search backward for it. If found, leaves point before the word. If not, leaves point where it is." (simple-search-backward (drei-instance) #'(lambda (mark) (search-backward mark word)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Incremental search (make-command-table 'isearch-drei-table :errorp nil) (defun isearch-command-loop (drei-instance forwardp) (let ((point (point (view drei-instance)))) (unless (endp (isearch-states drei-instance)) (setf (isearch-previous-string drei-instance) (search-string (first (isearch-states drei-instance))))) (setf (isearch-mode drei-instance) t) (setf (isearch-states drei-instance) (list (make-instance 'isearch-state :search-string "" :search-mark (clone-mark point) :search-forward-p forwardp :search-success-p t :targets (funcall *default-target-creator* drei-instance)))) (activate-target-specification (targets (first (isearch-states drei-instance)))) (simple-command-loop 'isearch-drei-table (isearch-mode drei-instance) ((display-message "Mark saved where search started") (deactivate-target-specification (targets (first (isearch-states drei-instance)))) (setf (isearch-mode drei-instance) nil)) ((display-message "Returned point to original location") (deactivate-target-specification (targets (first (isearch-states drei-instance)))) (setf (isearch-mode drei-instance) nil) (signal 'abort-gesture :event *current-gesture*))))) (defun isearch-from-mark (drei-instance mark string forwardp) (let* ((mark2 (clone-mark mark)) (success (funcall (if forwardp #'search-forward #'search-backward) mark2 string :test (case-relevant-test string))) (state (first (isearch-states drei-instance)))) (if success (setf (offset (point)) (offset mark2) (offset mark) (if forwardp (- (offset mark2) (length string)) (+ (offset mark2) (length string)))) (when (funcall (if forwardp #'subsequent-targets-p #'preceding-targets-p) (targets state)) (funcall (if forwardp #'next-target #'previous-target) (targets state)) (if (isearch-from-mark drei-instance (clone-mark (point)) string forwardp) (return-from isearch-from-mark t) (progn (pop (isearch-states drei-instance)) (funcall (if forwardp #'previous-target #'next-target) (targets state)) (setf (offset (point)) (offset (search-mark state))) nil)))) (display-message "~:[Failing ~;~]Isearch~:[ backward~;~]: ~A" success forwardp (display-string string)) (push (make-instance 'isearch-state :search-string string :search-mark mark :search-forward-p forwardp :search-success-p success :targets (targets state)) (isearch-states drei-instance)) (unless success (beep)) success)) (define-command (com-isearch-forward :name t :command-table search-table) () (display-message "Isearch: ") (isearch-command-loop (drei-instance) t)) (set-key 'com-isearch-forward 'search-table '((#\s :control))) (define-command (com-isearch-backward :name t :command-table search-table) () (display-message "Isearch backward: ") (isearch-command-loop (drei-instance) nil)) (set-key 'com-isearch-backward 'search-table '((#\r :control))) (defun isearch-append-char (char) (let* ((states (isearch-states (drei-instance))) (string (concatenate 'string (search-string (first states)) (string char))) (mark (clone-mark (search-mark (first states)))) (forwardp (search-forward-p (first states)))) (unless (or forwardp (end-of-buffer-p mark)) (incf (offset mark))) (isearch-from-mark (drei-instance) mark string forwardp))) (define-command (com-isearch-append-char :name t :command-table isearch-drei-table) () (isearch-append-char *current-gesture*)) (define-command (com-isearch-append-newline :name t :command-table isearch-drei-table) () (isearch-append-char #\Newline)) (defun isearch-append-text (movement-function) (let* ((states (isearch-states (drei-instance))) (start (clone-mark (point))) (mark (clone-mark (search-mark (first states)))) (forwardp (search-forward-p (first states)))) (funcall movement-function (point)) (let* ((start-offset (offset start)) (point-offset (offset (point))) (string (concatenate 'string (search-string (first states)) (buffer-substring (current-buffer) start-offset point-offset)))) (unless (or forwardp (end-of-buffer-p mark)) (incf (offset mark) (- point-offset start-offset))) (isearch-from-mark (drei-instance) mark string forwardp)))) (define-command (com-isearch-append-word :name t :command-table isearch-drei-table) () (isearch-append-text #'(lambda (mark) (forward-word mark (current-syntax))))) (define-command (com-isearch-append-line :name t :command-table isearch-drei-table) () (isearch-append-text #'end-of-line)) (define-command (com-isearch-append-kill :name t :command-table isearch-drei-table) () (let* ((states (isearch-states (drei-instance))) (yank (handler-case (kill-ring-yank *kill-ring*) (empty-kill-ring () ""))) (string (concatenate 'string (search-string (first states)) yank)) (mark (clone-mark (search-mark (first states)))) (forwardp (search-forward-p (first states)))) (unless (or forwardp (end-of-buffer-p mark)) (incf (offset mark) (length yank))) (isearch-from-mark (drei-instance) mark string forwardp))) (define-command (com-isearch-delete-char :name t :command-table isearch-drei-table) () (cond ((null (second (isearch-states (drei-instance)))) (display-message "Isearch: ") (beep)) (t (pop (isearch-states (drei-instance))) (loop until (endp (rest (isearch-states (drei-instance)))) until (search-success-p (first (isearch-states (drei-instance)))) do (pop (isearch-states (drei-instance)))) (let ((state (first (isearch-states (drei-instance))))) (setf (offset (point (view (drei-instance)))) (if (search-forward-p state) (+ (offset (search-mark state)) (length (search-string state))) (- (offset (search-mark state)) (length (search-string state))))) (display-message "Isearch~:[ backward~;~]: ~A" (search-forward-p state) (display-string (search-string state))))))) (define-command (com-isearch-search-forward :name t :command-table isearch-drei-table) () (let* ((states (isearch-states (drei-instance))) (string (if (null (second states)) (isearch-previous-string (drei-instance)) (search-string (first states)))) (mark (clone-mark (point)))) (isearch-from-mark (drei-instance) mark string t))) (define-command (com-isearch-search-backward :name t :command-table isearch-drei-table) () (let* ((states (isearch-states (drei-instance))) (string (if (null (second states)) (isearch-previous-string (drei-instance)) (search-string (first states)))) (mark (clone-mark (point)))) (isearch-from-mark (drei-instance) mark string nil))) (define-command (com-isearch-exit :name t :command-table isearch-drei-table) () (let* ((states (isearch-states (drei-instance))) (string (search-string (first states))) (search-forward-p (search-forward-p (first states)))) (setf (isearch-mode (drei-instance)) nil) (when (string= string "") (execute-frame-command *application-frame* (funcall *partial-command-parser* (frame-command-table *application-frame*) (frame-standard-input *application-frame*) (if search-forward-p `(com-string-search ,*unsupplied-argument-marker*) `(com-reverse-string-search ,*unsupplied-argument-marker*)) 0))))) (defun isearch-set-key (gesture command) (add-command-to-command-table command 'isearch-drei-table :keystroke gesture :errorp nil)) (loop for code from (char-code #\Space) to (char-code #\~) do (isearch-set-key (code-char code) 'com-isearch-append-char)) (isearch-set-key '(#\Newline) 'com-isearch-exit) (isearch-set-key '(#\Backspace) 'com-isearch-delete-char) (isearch-set-key '(#\s :control) 'com-isearch-search-forward) (isearch-set-key '(#\r :control) 'com-isearch-search-backward) (isearch-set-key '(#\j :control) 'com-isearch-append-newline) (isearch-set-key '(#\w :control) 'com-isearch-append-word) (isearch-set-key '(#\y :control) 'com-isearch-append-line) (isearch-set-key '(#\y :meta) 'com-isearch-append-kill) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Unconditional replace (define-command (com-replace-string :name t :command-table search-table) () "Replace all occurrences of `string' with `newstring'." (require-minibuffer) ;; We have to do it this way if we want to refer to STRING in NEWSTRING (let* ((string (accept 'string :prompt "Replace String")) (newstring (accept'string :prompt (format nil "Replace ~A with" string)))) (loop with point = (point) with length = (length string) with use-region-case = (no-upper-p string) for occurrences from 0 while (let ((offset-before (offset point))) (search-forward point string :test (case-relevant-test string)) (/= (offset point) offset-before)) do (backward-object point length) (replace-one-string point length newstring use-region-case) finally (display-message "Replaced ~A occurrence~:P" occurrences)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Query replace (make-command-table 'query-replace-drei-table :errorp nil) (defun query-replace-find-next-match (state) (with-accessors ((string string1) (targets targets)) state (let* ((mark (point (view (drei-instance (targets state))))) (offset-before (offset mark))) (search-forward mark string :test (case-relevant-test string)) (if (= (offset mark) offset-before) (when (subsequent-targets-p targets) (next-target targets) (beginning-of-buffer (point (buffer (drei-instance targets)))) (query-replace-find-next-match state)) t)))) (define-command (com-query-replace :name t :command-table search-table) () (require-minibuffer) (let* ((drei (drei-instance)) (old-state (query-replace-state drei)) (old-string1 (when old-state (string1 old-state))) (old-string2 (when old-state (string2 old-state))) (string1 (handler-case (if old-string1 (accept 'string :prompt "Query Replace" :default old-string1 :default-type 'string) (accept 'string :prompt "Query Replace")) (error () (progn (beep) (display-message "Empty string") (return-from com-query-replace nil))))) (string2 (handler-case (if old-string2 (accept 'string :prompt (format nil "Replace ~A with" string1) :default old-string2 :default-type 'string) (accept 'string :prompt (format nil "Replace ~A with" string1))) (error () (progn (beep) (display-message "Empty string") (return-from com-query-replace nil)))))) (setf (query-replace-state drei) (make-instance 'query-replace-state :string1 string1 :string2 string2 :targets (funcall *default-target-creator* drei))) (activate-target-specification (targets (query-replace-state drei))) (if (query-replace-find-next-match (query-replace-state drei)) (progn (setf (query-replace-mode drei) t) (display-message "Replace ~A with ~A:" string1 string2) (simple-command-loop 'query-replace-drei-table (query-replace-mode drei) ((setf (query-replace-mode drei) nil) (deactivate-target-specification (targets (query-replace-state drei))) (display-message "Replaced ~A occurence~:P" (occurrences (query-replace-state drei)))) ((setf (query-replace-mode drei) nil) (signal 'abort-gesture :event *current-gesture*)))) (display-message "Replaced 0 occurences")))) (set-key 'com-query-replace 'search-table '((#\% :meta))) (define-command (com-query-replace-replace :name t :command-table query-replace-drei-table) () (let ((state (query-replace-state (drei-instance)))) (with-accessors ((string1 string1) (string2 string2) (occurrences occurrences) (targets targets)) state (let ((string1-length (length string1)) (mark (point (view (drei-instance targets))))) (backward-object mark string1-length) (replace-one-string mark string1-length string2 (no-upper-p string1)) (incf occurrences) (if (query-replace-find-next-match state) (display-message "Replace ~A with ~A:" string1 string2) (setf (query-replace-mode (drei-instance)) nil)))))) (define-command (com-query-replace-replace-and-quit :name t :command-table query-replace-drei-table) () (let ((state (query-replace-state (drei-instance)))) (with-accessors ((string1 string1) (string2 string2) (occurrences occurrences) (targets targets)) state (let ((string1-length (length string1)) (mark (point (view (drei-instance targets))))) (backward-object mark string1-length) (replace-one-string mark string1-length string2 (no-upper-p string1)) (incf occurrences) (setf (query-replace-mode (drei-instance)) nil))))) (define-command (com-query-replace-replace-all :name t :command-table query-replace-drei-table) () (let ((state (query-replace-state (drei-instance)))) (with-accessors ((string1 string1) (string2 string2) (occurrences occurrences) (targets targets)) state (let ((string1-length (length string1)) (mark (point (view (drei-instance targets))))) (loop do (backward-object mark string1-length) (replace-one-string mark string1-length string2 (no-upper-p string1)) (incf occurrences) while (query-replace-find-next-match state) finally (setf (query-replace-mode (drei-instance)) nil)))))) (define-command (com-query-replace-skip :name t :command-table query-replace-drei-table) () (let ((state (query-replace-state (drei-instance)))) (with-accessors ((string1 string1) (string2 string2)) state (if (query-replace-find-next-match state) (display-message "Replace ~A with ~A:" string1 string2) (setf (query-replace-mode (drei-instance)) nil))))) (define-command (com-query-replace-exit :name t :command-table query-replace-drei-table) () (setf (query-replace-mode (drei-instance)) nil)) (defun query-replace-set-key (gesture command) (add-command-to-command-table command 'query-replace-drei-table :keystroke gesture :errorp nil)) (query-replace-set-key '(#\Newline) 'com-query-replace-exit) (query-replace-set-key '(#\Space) 'com-query-replace-replace) (query-replace-set-key '(#\Backspace) 'com-query-replace-skip) (query-replace-set-key '(#\Rubout) 'com-query-replace-skip) (query-replace-set-key '(#\q) 'com-query-replace-exit) (query-replace-set-key '(#\y) 'com-query-replace-replace) (query-replace-set-key '(#\n) 'com-query-replace-skip) (query-replace-set-key '(#\.) 'com-query-replace-replace-and-quit) (query-replace-set-key '(#\!) 'com-query-replace-replace-all) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Regex search (defparameter *whitespace-regex* (format nil "[~@{~A~}]+" #\Space #\Tab)) (defun normalise-minibuffer-regex (string) "Massages the regex STRING given to the minibuffer." (with-output-to-string (result) (loop for char across string if (char= char #\Space) do (princ *whitespace-regex* result) else do (princ char result)))) (define-command (com-regex-search-forward :name t :command-table search-table) () (require-minibuffer) (let ((string (accept 'string :prompt "RE search" :delimiter-gestures nil :activation-gestures '(:newline :return)))) (simple-search-forward (drei-instance) #'(lambda (mark) (re-search-forward mark (normalise-minibuffer-regex string)))))) (define-command (com-regex-search-backward :name t :command-table search-table) () (require-minibuffer) (let ((string (accept 'string :prompt "RE search backward" :delimiter-gestures nil :activation-gestures '(:newline :return)))) (simple-search-backward (drei-instance) #'(lambda (mark) (re-search-backward mark (normalise-minibuffer-regex string)))))) (define-command (com-how-many :name t :command-table search-table) ((regex 'string :prompt "How many matches for")) (let* ((re (normalise-minibuffer-regex regex)) (mark (clone-mark (point))) (occurrences (loop for count from 0 while (re-search-forward mark re) finally (return count)))) (display-message "~A occurrence~:P" occurrences))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/base.lisp0000644000175000017500000012054611345155772017507 0ustar pdmpdm;;; -*- Mode: Lisp; Package: DREI -*- ;;; (c) copyright 2004-2005 by ;;; Robert Strandh (strandh@labri.fr) ;;; (c) copyright 2004-2005 by ;;; Elliott Johnson (ejohnson@fasl.info) ;;; (c) copyright 2005 by ;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr) ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Basic functionality built on top of the buffer protocol. Here is ;;; where we define slightly higher level functions such as ;;; {previous,next}-line, {forward,backward}-word, etc. that can be ;;; directly implemented in terms of the buffer protocol, but that are ;;; not, strictly speaking, part of that protocol. (in-package :drei-base) (defgeneric invoke-as-region (mark1 mark2 continuation) (:documentation "Invoke `continuation' with two arguments ordering a proper region.")) (defmethod invoke-as-region ((mark1 integer) (mark2 integer) (continuation function)) (if (>= mark2 mark1) (funcall continuation mark1 mark2) (funcall continuation mark2 mark1))) (defmethod invoke-as-region ((mark1 mark) (mark2 mark) (continuation function)) (if (mark>= mark2 mark1) (funcall continuation mark1 mark2) (funcall continuation mark2 mark1))) (defmacro as-region ((mark1 mark2) &body body) "Rebind `mark1' and `mark2' to be a proper region. That is, `(mark>= mark2 mark1)' will hold. `Mark1' and `mark2' must be symbols bound to marks or integers (but they must be of the same type). It is a good idea to use this macro when dealing with regions." `(invoke-as-region ,mark1 ,mark2 #'(lambda (,mark1 ,mark2) ,@body))) (defmacro as-full-region ((mark1 mark2) &body body) "Bind `mark1' and `mark2' to marks that delimit a full region (a region where the beginning and end are at the beginning and end of their lines, respectively). The new marks will be copies of the marks `mark1' and `mark2' are already bound to. `Mark1' and `mark2' must be symbols bound to marks." `(as-region (,mark1 ,mark2) (let ((,mark1 (clone-mark ,mark1)) (,mark2 (clone-mark ,mark2))) (beginning-of-line ,mark1) (end-of-line ,mark2) ,@body))) (defmacro as-offsets ((&rest marks) &body body) "Bind the symbols in `marks' to the numeric offsets of the mark objects that the symbols are bound to. If a symbol in `mark' is already bound to an offset, just keep that binding. An element of `marks' may also be a list - in this case, the second element is used to get an offset, and the first element (which should be a symbol) will be bound to this offset. Evaluate `body' with these bindings." `(let ,(mapcar #'(lambda (mark-sym) (if (listp mark-sym) `(,(first mark-sym) (let ((value ,(second mark-sym))) (if (numberp value) value (offset value)))) `(,mark-sym (let ((value ,mark-sym)) (if (numberp value) ,mark-sym (offset value)))))) marks) ,@body)) (defmacro do-buffer-region ((object offset buffer offset1 offset2) &body body) "Iterate over the elements of the region delimited by offset1 and offset2. The body is executed for each element, with object being the current object \(setf-able), and offset being its offset." `(symbol-macrolet ((,object (buffer-object ,buffer ,offset))) (loop for ,offset from ,offset1 below ,offset2 do ,@body))) (defmacro do-buffer-region-lines ((line-var mark1 mark2) &body body) "Iterate over the lines in the region delimited by `mark1' and `mark2'. For each line, `line-var' will be bound to a mark positioned at the beginning of the line and `body' will be executed. Note that the iteration will always start from the mark specifying the earliest position in the buffer." (with-gensyms (mark-sym mark2-sym) `(progn (let* ((,mark-sym (clone-mark ,mark1)) (,mark2-sym (clone-mark ,mark2))) (as-region (,mark-sym ,mark2-sym) (loop while (and (mark<= ,mark-sym ,mark2-sym) (not (end-of-buffer-p ,mark-sym))) do (let ((,line-var (clone-mark ,mark-sym))) ,@body) (end-of-line ,mark-sym) (unless (end-of-buffer-p ,mark-sym) (forward-object ,mark-sym)))))))) (defgeneric previous-line (mark &optional column count) (:documentation "Move a mark up `count' lines conserving horizontal position. This is a relatively low-level function, you should probably use `drei-motion:backward-line' instead.")) (defmethod previous-line (mark &optional column (count 1)) (unless column (setf column (column-number mark))) (loop repeat count do (beginning-of-line mark) until (beginning-of-buffer-p mark) do (backward-object mark)) (end-of-line mark) (when (> (column-number mark) column) (beginning-of-line mark) (incf (offset mark) column))) (defmethod previous-line ((mark p-line-mark-mixin) &optional column (count 1)) (unless column (setf column (column-number mark))) (let* ((line (line-number mark)) (goto-line (max 0 (- line count)))) (setf (offset mark) (+ column (buffer-line-offset (buffer mark) goto-line))))) (defgeneric next-line (mark &optional column count) (:documentation "Move a mark down `count' lines conserving horizontal position. This is a relatively low-level function, you should probably use `drei-motion:forward-line' instead.")) (defmethod next-line (mark &optional column (count 1)) (unless column (setf column (column-number mark))) (loop repeat count do (end-of-line mark) until (end-of-buffer-p mark) do (forward-object mark)) (end-of-line mark) (when (> (column-number mark) column) (beginning-of-line mark) (incf (offset mark) column))) (defmethod next-line ((mark p-line-mark-mixin) &optional column (count 1)) (unless column (setf column (column-number mark))) (let* ((line (line-number mark)) (goto-line (min (number-of-lines (buffer mark)) (+ line count)))) (setf (offset mark) (+ column (buffer-line-offset (buffer mark) goto-line))))) (defgeneric open-line (mark &optional count) (:documentation "Create a new line in a buffer after the mark.")) (defmethod open-line ((mark left-sticky-mark) &optional (count 1)) (loop repeat count do (insert-object mark #\Newline))) (defmethod open-line ((mark right-sticky-mark) &optional (count 1)) (loop repeat count do (insert-object mark #\Newline) (decf (offset mark)))) (defun delete-line (mark &optional (count 1)) "Delete `count' lines at `mark' from the buffer." (dotimes (i count) (if (end-of-line-p mark) (unless (end-of-buffer-p mark) (delete-range mark)) (let ((offset (offset mark))) (end-of-line mark) (delete-region offset mark))))) (defgeneric extract-line (mark &key from-end whole-line) (:documentation "Destructively remove part of a line and return it. The line `mark' is in indicates which line to perform the extraction on. The line contents from the beginning of the line up to `mark' will be deleted and returned as a vector. If `from-end' is true, the line contents from the end of the line to `mark' will be affected instead. If `whole-line' is true, the entire line, including any single ending newline character, will be deleted and returned.")) (defun extract-whole-line (mark) "Extract the whole line `mark' is in, and remove any single trailing newline." (let* ((border-mark (clone-mark mark)) eol-offset) (end-of-line border-mark) (setf eol-offset (offset border-mark)) (unless (end-of-buffer-p border-mark) (incf eol-offset)) (beginning-of-line border-mark) (let ((sequence (region-to-sequence border-mark eol-offset))) (delete-region border-mark eol-offset) sequence))) (defmethod extract-line ((mark mark) &key from-end whole-line) (if whole-line (extract-whole-line mark) (let ((border-mark (clone-mark mark))) (if from-end (end-of-line border-mark) (beginning-of-line border-mark)) (as-region (mark border-mark) (let ((sequence (region-to-sequence mark border-mark))) (delete-region mark border-mark) sequence))))) (defgeneric lines-in-region (mark1 mark2) (:documentation "Return a list of all the lines (not including newline characters) in the full region delimited by `mark1' and `mark2'.")) (defmethod lines-in-region (mark1 mark2) (as-full-region (mark1 mark2) (let (result) (do-buffer-region-lines (line-mark mark1 mark2) (let ((bol-offset (offset line-mark))) (end-of-line line-mark) (push (region-to-sequence bol-offset line-mark) result))) result))) (defgeneric extract-lines-in-region (mark1 mark2) (:documentation "Delete the lines of the full region delimited by `mark1' and `mark2'")) (defmethod extract-lines-in-region ((mark1 mark) (mark2 mark)) (as-full-region (mark1 mark2) (let ((lines (lines-in-region mark1 mark2))) (delete-region mark1 mark2) lines))) (defun empty-line-p (mark) "Check whether the mark is in an empty line." (and (beginning-of-line-p mark) (end-of-line-p mark))) (defun line-indentation (mark tab-width) "Return the distance from the beginning of the line and the first constituent character of the line." (let ((mark2 (clone-mark mark))) (beginning-of-line mark2) (if (end-of-line-p mark2) 0 (loop with indentation = 0 as object = (object-after mark2) until (end-of-buffer-p mark2) while (or (eql object #\Space) (eql object #\Tab)) do (incf indentation (if (eql (object-after mark2) #\Tab) tab-width 1)) (incf (offset mark2)) finally (return indentation))))) (defmethod buffer-number-of-lines-in-region (buffer offset1 offset2) "Helper method for number-of-lines-in-region. Count newline characters in the region between offset1 and offset2." (loop while (< offset1 offset2) count (eql (buffer-object buffer offset1) #\Newline) do (incf offset1))) (defmethod buffer-number-of-lines-in-region ((buffer binseq2-buffer) offset1 offset2) "Helper method for NUMBER-OF-LINES-IN-REGION." (- (buffer-line-number buffer offset2) (buffer-line-number buffer offset1))) (defun buffer-display-column (buffer offset tab-width) (let ((line-start-offset (- offset (buffer-column-number buffer offset)))) (loop with column = 0 for i from line-start-offset below offset do (incf column (if (eql (buffer-object buffer i) #\Tab) (- tab-width (mod column tab-width)) 1)) finally (return column)))) (defgeneric number-of-lines-in-region (mark1 mark2) (:documentation "Return the number of lines (or rather the number of Newline characters) in the region between MARK and MARK2. An error is signaled if the two marks are positioned in different buffers. It is acceptable to pass an offset in place of one of the marks")) (defmethod number-of-lines-in-region ((mark1 mark) (mark2 mark)) (assert (eq (buffer mark1) (buffer mark2))) (let ((offset1 (offset mark1)) (offset2 (offset mark2))) (as-region (offset1 offset2) (buffer-number-of-lines-in-region (buffer mark1) offset1 offset2)))) (defmethod number-of-lines-in-region ((offset1 integer) (mark2 mark)) (let ((offset2 (offset mark2))) (as-region (offset1 offset2) (buffer-number-of-lines-in-region (buffer mark2) offset1 offset2)))) (defmethod number-of-lines-in-region ((mark1 mark) (offset2 integer)) (let ((offset1 (offset mark1))) (as-region (offset1 offset2) (buffer-number-of-lines-in-region (buffer mark1) offset1 offset2)))) (defun constituentp (obj) "A predicate to ensure that an object is a constituent character." (and (characterp obj) ;; #+sbcl (sb-impl::constituentp obj) (or (alphanumericp obj) (member obj '(#\! #\$ #\% #\& #\* #\+ #\- #\. #\/ #\: #\< #\= #\> #\? #\@ #\^ #\~ #\_ #\{ #\} #\[ #\] #\#))))) (defun buffer-whitespacep (obj) "Return T if `obj' is a basic whitespace character. This function does not respect the current syntax." (member obj '(#\Space #\Tab #\Newline #\Page #\Return))) (defun just-n-spaces (mark1 n) "Remove all spaces around `mark', leaving behind `n' spaces. `Mark' will be moved to after any spaces inserted." (let ((mark2 (clone-mark mark1))) (loop while (not (beginning-of-buffer-p mark2)) while (eql (object-before mark2) #\Space) do (backward-object mark2)) (loop while (not (end-of-buffer-p mark1)) while (eql (object-after mark1) #\Space) do (forward-object mark1)) (let ((existing-spaces (- (offset mark1) (offset mark2)))) (cond ((= n existing-spaces)) ((> n existing-spaces) (insert-sequence mark1 (make-array (- n existing-spaces) :initial-element #\Space))) ((< n existing-spaces) (delete-region (- (offset mark1) (- existing-spaces n)) mark1)))))) (defun move-to-column (mark column &optional force) "Move the position of `mark' to column number `column'. If the line is too short, put `mark' at end of line, unless `force' is non-NIL, in which case spaces will be added to the end of the line." (let ((set-column (setf (column-number mark) column))) (when (and (not (= set-column column)) force) (insert-sequence mark (make-string (- column set-column) :initial-element #\Space))))) (defun kill-region (mark1 mark2) "Kill the objects between `mark1' and `mark2', one of which may optionally be an offset. That is, push the objects of the delimited region onto `*kill-ring*', and delete them from the buffer." (kill-ring-standard-push *kill-ring* (region-to-sequence mark1 mark2)) (delete-region mark1 mark2)) (defun in-place-buffer-substring (buffer string offset1 offset2) "Copy from `offset1' to `offset2' in `buffer' to `string', which must be an adjustable vector of characters with a fill pointer. All objects in the buffer range must be characters. Returns `string'." (loop for offset from offset1 below offset2 for i upfrom 0 do (vector-push-extend (buffer-object buffer offset) string) finally (return string))) (defun fill-string-from-buffer (buffer string offset1 offset2) "Copy from `offset1' to `offset2' in `buffer' to `string', which must be an adjustable vector of characters with a fill pointer. Once the buffer region has been copied to `string', or a non-character object has been encountered in the buffer, the number of characters copied to `string' will be returned." (loop for offset from offset1 below offset2 for i upfrom 0 if (characterp (buffer-object buffer offset)) do (vector-push-extend (buffer-object buffer offset) string) else do (loop-finish) finally (return i))) (defun buffer-find-nonchar (buffer start-offset max-offset) "Search through `buffer' from `start-offset', returning the first offset at which a non-character object is found, or `max-offset', whichever comes first." (loop for offset from start-offset below max-offset unless (characterp (buffer-object buffer offset)) do (loop-finish) finally (return offset))) (defun offset-beginning-of-line-p (buffer offset) "Return true if `offset' is at the beginning of a line in `buffer' or at the beginning of `buffer'." (or (zerop offset) (eql (buffer-object buffer (1- offset)) #\Newline))) (defun offset-end-of-line-p (buffer offset) "Return true if `offset' is at the end of a line in `buffer' or at the end of `buffer'." (or (= (size buffer) offset) (eql (buffer-object buffer offset) #\Newline))) (defun end-of-line-offset (buffer start-offset) "Return the offset of the end of the line of `buffer' containing `start-offset'." (loop for offset from start-offset until (offset-end-of-line-p buffer offset) finally (return offset))) (defun extract-region (mark-or-offset1 mark-or-offset2) "Delete the region delimited by `mark-or-offset1' and `mark-or-offset2', returning the extracted sequence of objects." (prog1 (region-to-sequence mark-or-offset1 mark-or-offset2) (delete-region mark-or-offset1 mark-or-offset2))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Character case (defun buffer-region-case (buffer offset1 offset2) (let ((possibly-uppercase t) (possibly-lowercase t) (possibly-capitalized t)) (do-buffer-region (object offset buffer offset1 offset2) (unless (characterp object) (return-from buffer-region-case nil)) (when (lower-case-p object) (setf possibly-uppercase nil)) (when (upper-case-p object) (setf possibly-lowercase nil)) (when (plusp offset) (let ((previous-object (buffer-object buffer (1- offset)))) (when (and (characterp previous-object) (if (constituentp previous-object) (upper-case-p object) (lower-case-p object))) (setf possibly-capitalized nil))))) (cond (possibly-uppercase :upper-case) (possibly-lowercase :lower-case) (possibly-capitalized :capitalized) (t nil)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Search (defun buffer-looking-at (buffer offset vector &key (test #'eql)) "return true if and only if BUFFER contains VECTOR at OFFSET" (and (<= (+ offset (length vector)) (size buffer)) (loop for i from offset for obj across vector unless (funcall test (buffer-object buffer i) obj) return nil finally (return t)))) (defun looking-at (mark vector &key (test #'eql)) "return true if and only if BUFFER contains VECTOR after MARK" (buffer-looking-at (buffer mark) (offset mark) vector :test test)) (defun buffer-search-forward (buffer offset vector &key (test #'eql)) "return the smallest offset of BUFFER >= OFFSET containing VECTOR or NIL if no such offset exists" (loop for i from offset to (size buffer) when (buffer-looking-at buffer i vector :test test) return i finally (return nil))) (defun buffer-search-backward (buffer offset vector &key (test #'eql)) "return the largest offset of BUFFER <= (- OFFSET (length VECTOR)) containing VECTOR or NIL if no such offset exists" (loop for i downfrom (- offset (length vector)) to 0 when (buffer-looking-at buffer i vector :test test) return i finally (return nil))) (defun non-greedy-match-forward (a buffer i) (let ((p (automaton::initial a))) (loop for j from i below (size buffer) for q = (automaton::sstep p (buffer-object buffer j)) do (unless q (return nil)) (if (automaton::accept q) (return (1+ j)) (setq p q)) finally (return nil)))) (defun buffer-re-search-forward (a buffer offset) "Returns as the first value the smallest offset of BUFFER >= OFFSET with contents accepted by deterministic automaton A; otherwise, returns nil. If the first value is non-nil, the second value is the offset after the matched contents." (if (automaton::singleton a) (let ((result (buffer-search-forward buffer offset (automaton::singleton a)))) (when result (values result (+ result (length (automaton::singleton a)))))) (loop for i from offset below (size buffer) do (let ((j (non-greedy-match-forward a buffer i))) (when j (return (values i j)))) finally (return nil)))) (defun reversed-deterministic-automaton (a) "Reverses and determinizes A, then returns it." (if (automaton::singleton a) (progn (setf (automaton::singleton a) (reverse (automaton::singleton a))) a) (automaton::determinize2 a (make-instance 'automaton::state-set :ht (automaton::areverse a))))) (defun non-greedy-match-backward (a buffer i) (let ((p (automaton::initial a))) (loop for j downfrom i to 0 for q = (automaton::sstep p (buffer-object buffer j)) do (unless q (return nil)) (if (automaton::accept q) (return j) (setq p q)) finally (return nil)))) (defun buffer-re-search-backward (a buffer offset) "Returns as the first value the largest offset of BUFFER <= OFFSET with contents accepted by (reversed) deterministic automaton A; otherwise, returns nil. If the first value is non-nil, the second value is the offset after the matched contents." (if (automaton::singleton a) (let ((result (buffer-search-backward buffer offset (nreverse (automaton::singleton a))))) (when result (values result (+ result (length (automaton::singleton a)))))) (loop for i downfrom (min offset (1- (size buffer))) to 0 do (let ((j (non-greedy-match-backward a buffer i))) (when j (return (values j (1+ i))))) finally (return nil)))) (defun search-forward (mark vector &key (test #'eql)) "move MARK forward after the first occurence of VECTOR after MARK" (let ((offset (buffer-search-forward (buffer mark) (offset mark) vector :test test))) (when offset (setf (offset mark) (+ offset (length vector)))))) (defun search-backward (mark vector &key (test #'eql)) "move MARK backward before the first occurence of VECTOR before MARK" (let ((offset (buffer-search-backward (buffer mark) (offset mark) vector :test test))) (when offset (setf (offset mark) offset)))) (defun re-search-forward (mark re) "move MARK forward after the first occurence of string matching RE after MARK" (let ((a (automaton::determinize (automaton::regexp-automaton (automaton::string-regexp re))))) (multiple-value-bind (i j) (buffer-re-search-forward a (buffer mark) (offset mark)) (when i (setf (offset mark) j) (values mark i))))) (defun re-search-backward (mark re) "move MARK backward before the first occurence of string matching RE before MARK" (let ((a (reversed-deterministic-automaton (automaton::regexp-automaton (automaton::string-regexp re))))) (multiple-value-bind (i j) (buffer-re-search-backward a (buffer mark) (1- (offset mark))) (declare (ignorable j)) (when i (setf (offset mark) i) (values mark j))))) (defun buffer-search-word-backward (buffer offset word &key (test #'eql)) "return the largest offset of BUFFER <= (- OFFSET (length WORD)) containing WORD as a word or NIL if no such offset exists" (let ((wlen (length word)) (blen (size buffer))) (loop for i downfrom (- offset wlen) to 0 for j = (+ i wlen) when (and (or (zerop i) (buffer-whitespacep (buffer-object buffer (1- i)))) (buffer-looking-at buffer i word :test test) (not (and (< (+ i wlen) blen) (constituentp (buffer-object buffer (+ i wlen)))))) return i finally (return nil)))) (defun search-word-backward (mark word) (let ((offset (buffer-search-word-backward (buffer mark) (offset mark) word))) (when offset (setf (offset mark) offset)))) (defun buffer-search-word-forward (buffer offset word &key (test #'eql)) "Return the smallest offset of BUFFER >= OFFSET containing WORD as a word or NIL if no such offset exists" (let ((wlen (length word)) (blen (size buffer))) (loop for i upfrom offset to (- blen (max wlen 1)) for j = (+ i wlen) when (and (or (zerop i) (buffer-whitespacep (buffer-object buffer (1- i)))) (buffer-looking-at buffer i word :test test) (not (and (< j blen) (constituentp (buffer-object buffer j))))) ;; should this be (+ i wlen)? jqs 2006-05-14 return i finally (return nil)))) (defun search-word-forward (mark word) (let ((wlen (length word)) (offset (buffer-search-word-forward (buffer mark) (offset mark) word))) (when offset (setf (offset mark) (+ offset wlen))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Character case ;;; I'd rather have update-buffer-range methods spec. on buffer for this, ;;; for performance and history-size reasons --amb (defun downcase-buffer-region (buffer offset1 offset2) (do-buffer-region (object offset buffer offset1 offset2) (when (and (constituentp object) (upper-case-p object)) (setf object (char-downcase object))))) (defgeneric downcase-region (mark1 mark2) (:documentation "Convert all characters after mark1 and before mark2 to lowercase. An error is signaled if the two marks are positioned in different buffers. It is acceptable to pass an offset in place of one of the marks.")) (defmethod downcase-region ((mark1 mark) (mark2 mark)) (assert (eq (buffer mark1) (buffer mark2))) (let ((offset1 (offset mark1)) (offset2 (offset mark2))) (as-region (offset1 offset2) (downcase-buffer-region (buffer mark1) offset1 offset2)))) (defmethod downcase-region ((offset1 integer) (mark2 mark)) (let ((offset2 (offset mark2))) (as-region (offset1 offset2) (downcase-buffer-region (buffer mark2) offset1 offset2)))) (defmethod downcase-region ((mark1 mark) (offset2 integer)) (let ((offset1 (offset mark1))) (as-region (offset1 offset2) (downcase-buffer-region (buffer mark1) offset1 offset2)))) (defun upcase-buffer-region (buffer offset1 offset2) (do-buffer-region (object offset buffer offset1 offset2) (when (and (constituentp object) (lower-case-p object)) (setf object (char-upcase object))))) (defgeneric upcase-region (mark1 mark2) (:documentation "Convert all characters after mark1 and before mark2 to uppercase. An error is signaled if the two marks are positioned in different buffers. It is acceptable to pass an offset in place of one of the marks.")) (defmethod upcase-region ((mark1 mark) (mark2 mark)) (assert (eq (buffer mark1) (buffer mark2))) (let ((offset1 (offset mark1)) (offset2 (offset mark2))) (as-region (offset1 offset2) (upcase-buffer-region (buffer mark1) offset1 offset2)))) (defmethod upcase-region ((offset1 integer) (mark2 mark)) (let ((offset2 (offset mark2))) (as-region (offset1 offset2) (upcase-buffer-region (buffer mark2) offset1 offset2)))) (defmethod upcase-region ((mark1 mark) (offset2 integer)) (let ((offset1 (offset mark1))) (as-region (offset1 offset2) (upcase-buffer-region (buffer mark1) offset1 offset2)))) (defun capitalize-buffer-region (buffer offset1 offset2) (let ((previous-char-constituent-p nil)) (do-buffer-region (object offset buffer offset1 offset2) (when (constituentp object) (if previous-char-constituent-p (when (upper-case-p object) (setf object (char-downcase object))) (when (lower-case-p object) (setf object (char-upcase object))))) (setf previous-char-constituent-p (constituentp object))))) (defgeneric capitalize-region (mark1 mark2) (:documentation "Capitalize all words after mark1 and before mark2. An error is signaled if the two marks are positioned in different buffers. It is acceptable to pass an offset in place of one of the marks.")) (defmethod capitalize-region ((mark1 mark) (mark2 mark)) (assert (eq (buffer mark1) (buffer mark2))) (let ((offset1 (offset mark1)) (offset2 (offset mark2))) (as-region (offset1 offset2) (capitalize-buffer-region (buffer mark1) offset1 offset2)))) (defmethod capitalize-region ((offset1 integer) (mark2 mark)) (let ((offset2 (offset mark2))) (as-region (offset1 offset2) (capitalize-buffer-region (buffer mark2) offset1 offset2)))) (defmethod capitalize-region ((mark1 mark) (offset2 integer)) (let ((offset1 (offset mark1))) (as-region (offset1 offset2) (capitalize-buffer-region (buffer mark1) offset1 offset2)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Tabify (defun tabify-buffer-region (buffer offset1 offset2 tab-width) (flet ((looking-at-spaces (buffer offset count) (loop for i from offset repeat count unless (char= (buffer-object buffer i) #\Space) return nil finally (return t)))) (loop for offset = offset1 then (1+ offset) until (>= offset offset2) do (let* ((column (buffer-display-column buffer offset tab-width)) (count (- tab-width (mod column tab-width)))) (when (looking-at-spaces buffer offset count) (finish-output) (delete-buffer-range buffer offset count) (insert-buffer-object buffer offset #\Tab) (decf offset2 (1- count))))))) (defgeneric tabify-region (mark1 mark2 tab-width) (:documentation "Replace sequences of tab-width spaces with tabs in the region delimited by mark1 and mark2.")) (defmethod tabify-region ((mark1 mark) (mark2 mark) tab-width) (assert (eq (buffer mark1) (buffer mark2))) (let ((offset1 (offset mark1)) (offset2 (offset mark2))) (as-region (offset1 offset2) (tabify-buffer-region (buffer mark1) offset1 offset2 tab-width)))) (defmethod tabify-region ((offset1 integer) (mark2 mark) tab-width) (let ((offset2 (offset mark2))) (as-region (offset1 offset2) (tabify-buffer-region (buffer mark2) offset1 offset2 tab-width)))) (defmethod tabify-region ((mark1 mark) (offset2 integer) tab-width) (let ((offset1 (offset mark1))) (as-region (offset1 offset2) (tabify-buffer-region (buffer mark1) offset1 offset2 tab-width)))) (defun untabify-buffer-region (buffer offset1 offset2 tab-width) (loop for offset = offset1 then (1+ offset) until (>= offset offset2) when (char= (buffer-object buffer offset) #\Tab) do (let* ((column (buffer-display-column buffer offset tab-width)) (count (- tab-width (mod column tab-width)))) (delete-buffer-range buffer offset 1) (loop repeat count do (insert-buffer-object buffer offset #\Space)) (incf offset (1- count)) (incf offset2 (1- count))))) (defgeneric untabify-region (mark1 mark2 tab-width) (:documentation "Replace tabs with tab-width spaces in the region delimited by mark1 and mark2.")) (defmethod untabify-region ((mark1 mark) (mark2 mark) tab-width) (assert (eq (buffer mark1) (buffer mark2))) (let ((offset1 (offset mark1)) (offset2 (offset mark2))) (as-region (offset1 offset2) (untabify-buffer-region (buffer mark1) offset1 offset2 tab-width)))) (defmethod untabify-region ((offset1 integer) (mark2 mark) tab-width) (let ((offset2 (offset mark2))) (as-region (offset1 offset2) (untabify-buffer-region (buffer mark2) offset1 offset2 tab-width)))) (defmethod untabify-region ((mark1 mark) (offset2 integer) tab-width) (let ((offset1 (offset mark1))) (as-region (offset1 offset2) (untabify-buffer-region (buffer mark1) offset1 offset2 tab-width)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Narrowed marks (defclass narrowed-mark-mixin () ((low-border-mark :reader low-border-mark :initarg :low-mark :initform (error "A low border mark must be provided")) (high-border-mark :reader high-border-mark :initarg :high-mark :initform (error "A high border mark must be provided")))) (defmethod shared-initialize :after ((obj narrowed-mark-mixin) slot-names &key) (with-slots (low-border-mark high-border-mark) obj (check-type low-border-mark left-sticky-mark) (check-type high-border-mark right-sticky-mark))) (defgeneric make-narrowed-mark (mark &key low-mark high-mark) (:method :before (mark &key (low-mark mark) (high-mark mark)) (assert (mark>= mark low-mark)) (assert (mark>= high-mark mark)))) ;;; Destructively narrowing marks (the fun part!)... (defgeneric narrow-mark (mark low-mark high-mark) (:documentation "Change `mark' to be a narrowed mark. HIGHLY IMPORTANT WARNING: This is done **destructively** by modifying which class `mark' is an instance of.")) (defgeneric unnarrow-mark (mark) (:documentation "Change `mark' to be a standard, unnarrowed mark. HIGHLY IMPORTANT WARNING: This is done **destructively** by modifying which class `mark' is an instance of.")) ;;; Make some common narrowed mark operations easier to do. (defun make-backward-narrowed-mark (mark &optional (backward-mark mark)) (make-narrowed-mark mark :low-mark backward-mark :high-mark (let ((m (clone-mark mark :right))) (end-of-buffer m) m))) (defun make-forward-narrowed-mark (mark &optional (forward-mark mark)) (make-narrowed-mark mark :low-mark (let ((m (clone-mark mark :left))) (beginning-of-buffer m) m) :high-mark forward-mark)) (defclass narrowed-standard-left-sticky-mark (narrowed-mark-mixin standard-left-sticky-mark) ()) (defclass narrowed-standard-right-sticky-mark (narrowed-mark-mixin standard-right-sticky-mark) ()) (defmethod make-narrowed-mark ((mark standard-left-sticky-mark) &key (low-mark mark) (high-mark mark)) (make-instance 'narrowed-standard-left-sticky-mark :buffer (buffer mark) :offset (offset mark) :low-mark low-mark :high-mark high-mark)) (defmethod make-narrowed-mark ((mark standard-right-sticky-mark) &key (low-mark mark) (high-mark mark)) (make-instance 'narrowed-standard-right-sticky-mark :buffer (buffer mark) :offset (offset mark) :low-mark low-mark :high-mark high-mark)) (defmethod clone-mark ((mark narrowed-standard-left-sticky-mark) &optional stick-to) (cond ((or (null stick-to) (eq stick-to :left)) (make-instance 'narrowed-standard-left-sticky-mark :buffer (buffer mark) :offset (offset mark) :low-mark (low-border-mark mark) :high-mark (high-border-mark mark))) ((eq stick-to :right) (make-instance 'narrowed-standard-right-sticky-mark :buffer (buffer mark) :offset (offset mark) :low-mark (low-border-mark mark) :high-mark (high-border-mark mark))) (t (error "invalid value for stick-to")))) (defmethod clone-mark ((mark narrowed-standard-right-sticky-mark) &optional stick-to) (cond ((or (null stick-to) (eq stick-to :right)) (make-instance 'narrowed-standard-right-sticky-mark :buffer (buffer mark) :offset (offset mark) :low-mark (low-border-mark mark) :high-mark (high-border-mark mark))) ((eq stick-to :left) (make-instance 'narrowed-standard-left-sticky-mark :buffer (buffer mark) :offset (offset mark) :low-mark (low-border-mark mark) :high-mark (high-border-mark mark))) (t (error "invalid value for stick-to")))) (defmethod (setf offset) :before (new-offset (mark narrowed-mark-mixin)) (assert (<= (offset (low-border-mark mark)) new-offset) () (make-condition 'motion-before-beginning :offset new-offset)) (assert (<= new-offset (offset (high-border-mark mark))) () (make-condition 'motion-after-end :offset new-offset))) (defmethod beginning-of-buffer-p ((mark narrowed-mark-mixin)) (mark= mark (low-border-mark mark))) (defmethod end-of-buffer-p ((mark narrowed-mark-mixin)) (mark= mark (high-border-mark mark))) (defmethod narrow-mark ((mark standard-left-sticky-mark) (low-mark left-sticky-mark) (high-mark right-sticky-mark)) (assert (and (mark<= low-mark mark) (mark<= mark high-mark))) (change-class mark 'narrowed-standard-left-sticky-mark :low-mark low-mark :high-mark high-mark)) (defmethod narrow-mark ((mark standard-right-sticky-mark) (low-mark left-sticky-mark) (high-mark right-sticky-mark)) (assert (and (mark<= low-mark mark) (mark<= mark high-mark))) (change-class mark 'narrowed-standard-right-sticky-mark :low-mark low-mark :high-mark high-mark)) (defmethod unnarrow-mark ((mark narrowed-standard-left-sticky-mark)) (change-class mark 'standard-left-sticky-mark)) (defmethod unnarrow-mark ((mark narrowed-standard-right-sticky-mark)) (change-class mark 'standard-right-sticky-mark)) (defclass narrowed-delegating-left-sticky-mark (narrowed-mark-mixin delegating-left-sticky-mark) ()) (defclass narrowed-delegating-right-sticky-mark (narrowed-mark-mixin delegating-right-sticky-mark) ()) (defmethod make-narrowed-mark ((mark delegating-left-sticky-mark) &key (low-mark mark) (high-mark mark)) (make-instance 'narrowed-delegating-left-sticky-mark :buffer (buffer mark) :offset (offset mark) :low-mark low-mark :high-mark high-mark)) (defmethod make-narrowed-mark ((mark delegating-right-sticky-mark) &key (low-mark mark) (high-mark mark)) (make-instance 'narrowed-delegating-right-sticky-mark :buffer (buffer mark) :offset (offset mark) :low-mark low-mark :high-mark high-mark)) (defmethod clone-mark ((mark narrowed-delegating-left-sticky-mark) &optional stick-to) (cond ((or (null stick-to) (eq stick-to :left)) (make-instance 'narrowed-delegating-left-sticky-mark :implementation (clone-mark (implementation mark) :left) :buffer (buffer mark) :low-mark (low-border-mark mark) :high-mark (high-border-mark mark))) ((eq stick-to :right) (make-instance 'narrowed-delegating-right-sticky-mark :implementation (clone-mark (implementation mark) :right) :buffer (buffer mark) :low-mark (low-border-mark mark) :high-mark (high-border-mark mark))) (t (error "invalid value for stick-to")))) (defmethod clone-mark ((mark narrowed-delegating-right-sticky-mark) &optional stick-to) (cond ((or (null stick-to) (eq stick-to :right)) (make-instance 'narrowed-delegating-right-sticky-mark :implementation (clone-mark (implementation mark) :right) :buffer (buffer mark) :low-mark (low-border-mark mark) :high-mark (high-border-mark mark))) ((eq stick-to :left) (make-instance 'narrowed-delegating-left-sticky-mark :implementation (clone-mark (implementation mark) :left) :buffer (buffer mark) :low-mark (low-border-mark mark) :high-mark (high-border-mark mark))) (t (error "invalid value for stick-to")))) (defmethod narrow-mark ((mark delegating-left-sticky-mark) (low-mark left-sticky-mark) (high-mark right-sticky-mark)) (assert (and (mark<= low-mark mark) (mark<= mark high-mark))) (change-class mark 'narrowed-delegating-left-sticky-mark :low-mark low-mark :high-mark high-mark)) (defmethod narrow-mark ((mark delegating-right-sticky-mark) (low-mark left-sticky-mark) (high-mark right-sticky-mark)) (assert (and (mark<= low-mark mark) (mark<= mark high-mark))) (change-class mark 'narrowed-delegating-right-sticky-mark :low-mark low-mark :high-mark high-mark)) (defmethod unnarrow-mark ((mark narrowed-delegating-left-sticky-mark)) (change-class mark 'delegating-left-sticky-mark)) (defmethod unnarrow-mark ((mark narrowed-delegating-right-sticky-mark)) (change-class mark 'delegating-right-sticky-mark)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/syntax.lisp0000644000175000017500000010422311345155772020115 0ustar pdmpdm;;; -*- Mode: Lisp; Package: DREI-SYNTAX -*- ;;; (c) copyright 2004-2005 by ;;; Robert Strandh (strandh@labri.fr) ;;; (c) copyright 2005 by ;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :drei-syntax) (defclass syntax (name-mixin observable-mixin) ((%buffer :initarg :buffer :reader buffer) (%command-table :initarg :command-table :initform (error "A command table has not been provided for this syntax") :reader command-table) (%updater-fns :initarg :updater-fns :initform '() :accessor updater-fns :documentation "A list of functions that are called whenever a syntax function needs up-to-date syntax information. `Update-syntax' is never called directly by syntax commands. Each function should take two arguments, integer offsets into the buffer of the syntax delimiting the region that must have an up-to-date parse. These arguments should be passed on to a call to `update-syntax'.")) (:metaclass modual-class) (:documentation "The base class for all syntaxes.")) (defgeneric syntax-command-tables (syntax) (:documentation "Returns additional command tables provided by `syntax'.") (:method-combination append :most-specific-last) (:method append ((syntax syntax)) (list (command-table syntax)))) (defun syntaxp (object) "Return T if `object' is an instance of a syntax, NIL otherwise." (typep object 'syntax)) (defun update-parse (syntax &optional (begin 0) (end (size (buffer syntax)))) "Make sure the parse for `syntax' from offset `begin' to `end' is up to date. `Begin' and `end' default to 0 and the size of the buffer of `syntax', respectively." (if (null (updater-fns syntax)) ;; Just call `update-syntax' manually. We assume the entire ;; buffer has changed. (update-syntax syntax 0 0 begin end) (map nil #'(lambda (updater) (funcall updater begin end)) (updater-fns syntax)))) (define-condition no-such-operation (simple-error) () (:report (lambda (condition stream) (declare (ignore condition)) (format stream "Operation unavailable for this syntax"))) (:documentation "This condition is signaled whenever an attempt is made to execute an operation that is unavailable for the particular syntax" )) (defgeneric update-syntax (syntax unchanged-prefix unchanged-suffix &optional begin end) (:documentation "Inform the syntax module that it must update its view of the buffer. `Unchanged-prefix' `unchanged-suffix' indicate what parts of the buffer has not been changed. `Begin' and `end' are offsets specifying the minimum region of the buffer that must have an up-to-date parse, defaulting to 0 and the size of the buffer respectively. It is perfectly valid for a syntax to ignore these hints and just make sure the entire syntax tree is up to date, but it *must* make sure at at least the region delimited by `begin' and `end' has an up to date parse. Returns two values, offsets into the buffer of the syntax, denoting the buffer region thas has an up to date parse.") (:method-combination values-max-min :most-specific-last)) (defgeneric eval-defun (mark syntax)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Syntax command tables. (defclass syntax-command-table (standard-command-table) () (:documentation "A syntax command table provides facilities for having frame-specific commands that do not show up when the syntax is used in other applications than the one it is supposed to. For example, the Return From Definition command should be available when Lisp syntax is used in Climacs (or another editor), but not anywhere else.")) (defgeneric additional-command-tables (editor command-table) (:method-combination append) (:documentation "Return a list of additional command tables that should be checked for commands in addition to those `command-table' inherits from. The idea is that methods are specialised to `editor' (which is at first a Drei instance), and that those methods may call the function again recursively with a new `editor' argument to provide arbitrary granularity for command-table-selection. For instance, some commands may be applicable in a situation where the editor is a pane or gadget in its own right, but not when it functions as an input-editor. In this case, a method could be defined for `application-frame' as the `editor' argument, that calls `additional-command-tables' again with whatever the \"current\" editor instance is. The default method on this generic function just returns the empty list.") (:method append (editor command-table) '())) (defmethod command-table-inherit-from ((table syntax-command-table)) "Fetch extra command tables to inherit from (using `additional-command-tables') as well as the command tables `table' actually directly inherits from." (append (mapcar #'find-command-table (additional-command-tables *application-frame* table)) (call-next-method))) (defmacro define-syntax-command-table (name &rest args &key &allow-other-keys) "Define a syntax command table class with the provided name, as well as defining a CLIM command table of the same name. `Args' will be passed on to `make-command-table'. An :around method on `command-table-inherit-from' for the defined class will also be defined. This method will make sure that when an instance of the syntax command table is asked for its inherited command tables, it will return those of the defined CLIM command table, as well as those provided by methods on `additional-command-tables'. Command tables provided through `additional-command-tables' will take precence over those specified in the usual way with :inherit-from." `(progn (make-command-table ',name ,@args) (defclass ,name (syntax-command-table) ()) (defmethod command-table-inherit-from ((table ,name)) (append (call-next-method) '(,name) (command-table-inherit-from (find-command-table ',name)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Commenting (defgeneric syntax-line-comment-string (syntax) (:documentation "string to use at the beginning of a line to indicate a line comment")) (defgeneric line-comment-region (syntax mark1 mark2) (:documentation "inset a line comment string at the beginning of every line in the region")) (defmethod line-comment-region (syntax mark1 mark2) (when (mark< mark2 mark1) (rotatef mark1 mark2)) (let ((mark (clone-mark mark1))) (unless (beginning-of-line-p mark) (end-of-line mark) (unless (end-of-buffer-p mark) (forward-object mark))) (loop while (mark< mark mark2) do (insert-sequence mark (syntax-line-comment-string syntax)) (end-of-line mark) (unless (end-of-buffer-p mark) (forward-object mark))))) (defgeneric line-uncomment-region (syntax mark1 mark2) (:documentation "inset a line comment string at the beginning of every line in the region")) (defmethod line-uncomment-region (syntax mark1 mark2) (when (mark< mark2 mark1) (rotatef mark1 mark2)) (let ((mark (clone-mark mark1))) (unless (beginning-of-line-p mark) (end-of-line mark) (unless (end-of-buffer-p mark) (forward-object mark))) (loop while (mark< mark mark2) do (when (looking-at mark (syntax-line-comment-string syntax)) (delete-range mark (length (syntax-line-comment-string syntax)))) (end-of-line mark) (unless (end-of-buffer-p mark) (forward-object mark))))) (defgeneric comment-region (syntax mark1 mark2) (:documentation "turn the region between the two marks into a comment in the specific syntax.") (:method (syntax mark1 mark2) nil)) (defgeneric uncomment-region (syntax mark1 mark2) (:documentation "remove comment around region") (:method (syntax mark1 mark2) nil)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Name for info-pane (defgeneric name-for-info-pane (syntax &key &allow-other-keys) (:documentation "Return the name that should be used for the info-pane for panes displaying a buffer in this syntax.") (:method (syntax &key &allow-other-keys) (name syntax))) (defgeneric display-syntax-name (syntax stream &key &allow-other-keys) (:documentation "Draw the name of the syntax `syntax' to `stream'. This is meant to be called for the info-pane.") (:method (syntax stream &rest args &key) (princ (apply #'name-for-info-pane syntax args) stream))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Syntax completion (defparameter *syntaxes* '()) (defvar *default-syntax* nil "The name of the default syntax. Must be a symbol. This syntax will be used by default, when no other syntax is mandated by file types or attribute lists.") (defstruct (syntax-description (:type list)) (name (error "required argument") :type string) (class-name (error "required argument") :type symbol) (pathname-types nil :type list)) (defmacro define-syntax (class-name superclasses slots &rest options) (let ((defclass-options nil) (default-initargs nil) (name nil) (command-table nil) (pathname-types nil)) (dolist (option options) (case (car option) ((:name) (if name (error "More than one ~S option provided to ~S" ':name 'define-syntax) (setf name (cadr option)))) ((:pathname-types) (if pathname-types (error "More than one ~S option provided to ~S" ':pathname-types 'define-syntax) (setf pathname-types (cdr option)))) ((:command-table) (if command-table (error "More than one ~S option provided to ~S" ':command-table 'define-syntax) (setf command-table `',(cadr option)))) ((:default-initargs) (if default-initargs (error "More than one ~S option provided to ~S" ':default-initargs 'define-syntax) (setf default-initargs (cdr option)))) (t (push (cdr option) defclass-options)))) (unless name (error "~S not supplied to ~S" ':name 'define-syntax)) ;; FIXME: the :NAME initarg looks, well, a bit generic, and could ;; collide with user-defined syntax initargs. Use ;; DREI-SYNTAX::%NAME instead. (setf default-initargs (list* :name name default-initargs)) `(progn (push (make-syntax-description :name ,name :class-name ',class-name :pathname-types ',pathname-types) *syntaxes*) (defclass ,class-name ,superclasses ,slots ,(append '(:default-initargs) (when command-table (list :command-table (once-only (command-table) `(when (find-command-table ,command-table) (if (find-class ,command-table nil) (make-instance ,command-table :name ,command-table) ;; It must be just a command table. (find-command-table ,command-table)))))) default-initargs) (:metaclass modual-class) ,@defclass-options)))) (defgeneric eval-option (syntax name value) (:documentation "Evaluate the option `name' with the specified `value' for `syntax'.") (:method (syntax name value) ;; We do not want to error out if an invalid option is ;; specified. Signal a condition? For now, silently ignore. (declare (ignore syntax name value)))) (defmethod eval-option :around (syntax (name string) value) ;; Convert the name to a keyword symbol... (eval-option syntax (intern (string-upcase name) (find-package :keyword)) value)) (defmacro define-option-for-syntax (syntax option-name (syntax-symbol value-symbol) &body body) "Define an option for the syntax specified by the symbol `syntax'. `Option-name' should be a string that will be the name of the option. The name will automatically be converted to uppercase. When the option is being evaluated, `body' will be run, with `syntax-symbol' bound to the syntax object the option is being evaluated for, and `value-symbol' bound to the value of the option." ;; The name is converted to a keyword symbol which is used for all ;; further identification. (with-gensyms (name) (let ((symbol (intern (string-upcase option-name) (find-package :keyword)))) `(defmethod eval-option ((,syntax-symbol ,syntax) (,name (eql ,symbol)) ,value-symbol) ,@body)))) (defgeneric current-attributes-for-syntax (syntax) (:method-combination append) (:method append (syntax) (list (cons :syntax (name syntax))))) (defun make-attribute-line (syntax) (apply #'concatenate 'string (loop for (name . value) in (current-attributes-for-syntax syntax) collect (string-downcase (symbol-name name) :start 1) collect ": " collect value collect "; "))) #+nil (defmacro define-syntax (class-name (name superclasses) &body body) `(progn (push '(,name . ,class-name) *syntaxes*) (defclass ,class-name ,superclasses ,@body (:default-initargs :name ,name)))) (define-presentation-method accept ((type syntax) stream (view textual-view) &key) (multiple-value-bind (object success string) (complete-input stream (lambda (so-far action) (complete-from-possibilities so-far *syntaxes* '() :action action :name-key #'syntax-description-name :value-key #'syntax-description-class-name)) :partial-completers '(#\Space) :allow-any-input t) (declare (ignore success)) (if (find string *syntaxes* :key #'first :test #'string=) (values object type) (input-not-of-required-type string type)) object)) (defun syntax-from-name (syntax) (let ((description (find syntax *syntaxes* :key #'syntax-description-name :test #'string-equal))) (when description (find-class (syntax-description-class-name description))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Incremental Earley parser ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; parse tree (defclass parse-tree () ((start-mark :initform nil :initarg :start-mark :reader start-mark) (size :initform nil :initarg :size)) (:documentation "The base class for all parse trees.")) (defgeneric start-offset (parse-tree) (:documentation "The offset in the buffer of the first character of a parse tree.")) (defmethod start-offset ((tree parse-tree)) (let ((mark (start-mark tree))) (when mark (offset mark)))) (defmethod (setf start-offset) ((offset number) (tree parse-tree)) (let ((mark (start-mark tree))) (assert (not (null mark))) (setf (offset mark) offset))) (defmethod (setf start-offset) ((offset mark) (tree parse-tree)) (with-slots (start-mark) tree (if (null start-mark) (setf start-mark (clone-mark offset)) (setf (offset start-mark) (offset offset))))) (defgeneric end-offset (parse-tree) (:documentation "The offset in the buffer of the character following the last one of a parse tree.")) (defmethod end-offset ((tree parse-tree)) (with-slots (start-mark size) tree (when start-mark (+ (offset start-mark) size)))) (defmethod (setf end-offset) ((offset number) (tree parse-tree)) (with-slots (start-mark size) tree (assert (not (null start-mark))) (setf size (- offset (offset start-mark))))) (defmethod (setf end-offset) ((offset mark) (tree parse-tree)) (with-slots (start-mark size) tree (assert (not (null start-mark))) (setf size (- (offset offset) (offset start-mark))))) (defmethod buffer ((tree parse-tree)) (let ((start-mark (start-mark tree))) (when start-mark (buffer start-mark)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; lexer (defclass lexer () ((buffer :initarg :buffer :reader buffer :documentation "The buffer associated with the lexer.")) (:documentation "The base class for all lexers.")) (defgeneric nb-lexemes (lexer) (:documentation "Return the number of lexemes in the lexer.")) (defgeneric lexeme (lexer pos) (:documentation "Given a lexer and a position, return the lexeme in that position in the lexer.")) (defgeneric insert-lexeme (lexer pos lexeme) (:documentation "Insert a lexeme at the position in the lexer. All lexemes following POS are moved to one position higher.")) (defgeneric delete-invalid-lexemes (lexer from to) (:documentation "Invalidate all lexemes that could have changed as a result of modifications to the buffer")) (defgeneric inter-lexeme-object-p (lexer object) (:documentation "This generic function is called by the incremental lexer to determine whether a buffer object is an inter-lexeme object, typically whitespace. Client code must supply a method for this generic function.")) (defgeneric skip-inter-lexeme-objects (lexer scan) (:documentation "This generic function is called by the incremental lexer to skip inter-lexeme buffer objects. The default method for this generic function increments the scan mark until the object after the mark is not an inter-lexeme object, or until the end of the buffer has been reached.")) (defgeneric update-lex (lexer start-pos end) (:documentation "This function is called by client code as part of the buffer-update protocol to inform the lexer that it needs to analyze the contents of the buffer at least up to the `end' mark of the buffer. `start-pos' is the position in the lexeme sequence at which new lexemes should be inserted.")) (defgeneric next-lexeme (lexer scan) (:documentation "This generic function is called by the incremental lexer to get a new lexeme from the buffer. Client code must supply a method for this function that specializes on the lexer class. It is guaranteed that scan is not at the end of the buffer, and that the first object after scan is not an inter-lexeme object. Thus, a lexeme should always be returned by this function.")) (defclass incremental-lexer (lexer) ((lexemes :initform (make-instance 'standard-flexichain) :reader lexemes)) (:documentation "A subclass of lexer which maintains the buffer in the form of a sequence of lexemes that is updated incrementally.")) (defmethod nb-lexemes ((lexer incremental-lexer)) (nb-elements (lexemes lexer))) (defmethod lexeme ((lexer incremental-lexer) pos) (element* (lexemes lexer) pos)) (defmethod insert-lexeme ((lexer incremental-lexer) pos lexeme) (insert* (lexemes lexer) pos lexeme)) (defmethod delete-invalid-lexemes ((lexer incremental-lexer) from to) "delete all lexemes between FROM and TO and return the first invalid position in the lexemes of LEXER" (with-slots (lexemes) lexer (let ((start 1) (end (nb-elements lexemes))) ;; use binary search to find the first lexeme to delete (loop while (< start end) do (let ((middle (floor (+ start end) 2))) (if (mark< (end-offset (element* lexemes middle)) from) (setf start (1+ middle)) (setf end middle)))) ;; delete lexemes (loop until (or (= start (nb-elements lexemes)) (mark> (start-mark (element* lexemes start)) to)) do (delete* lexemes start)) start))) (defmethod skip-inter-lexeme-objects ((lexer incremental-lexer) scan) (loop until (end-of-buffer-p scan) while (inter-lexeme-object-p lexer (object-after scan)) do (forward-object scan))) (defmethod update-lex ((lexer incremental-lexer) start-pos end) (let ((scan (clone-mark (low-mark (buffer lexer)) :left))) (setf (offset scan) (end-offset (lexeme lexer (1- start-pos)))) (loop do (skip-inter-lexeme-objects lexer scan) until (if (end-of-buffer-p end) (end-of-buffer-p scan) (mark> scan end)) do (let* ((start-mark (clone-mark scan)) (lexeme (next-lexeme lexer scan)) (size (- (offset scan) (offset start-mark)))) (setf (slot-value lexeme 'start-mark) start-mark (slot-value lexeme 'size) size) (insert-lexeme lexer start-pos lexeme)) (incf start-pos)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; grammar (defclass rule () ((left-hand-side :initarg :left-hand-side :reader left-hand-side) (right-hand-side :initarg :right-hand-side :reader right-hand-side) (symbols :initarg :symbols :reader symbols) (predict-test :initarg :predict-test :reader predict-test) (number))) (defclass grammar () ((rules :initform nil :accessor rules) (hash :initform (make-hash-table) :accessor hash) (number-of-rules :initform 0))) (defmacro grammar-rule ((left-hand-side arrow arglist &body body) &key predict-test) (declare (ignore arrow)) (labels ((var-of (arg) (if (symbolp arg) arg (car arg))) (sym-of (arg) (cond ((symbolp arg) arg) ((= (length arg) 3) (cadr arg)) ((symbolp (cadr arg)) (cadr arg)) (t (car arg)))) (test-of (arg) (cond ((symbolp arg) t) ((= (length arg) 3) (caddr arg)) ((symbolp (cadr arg)) t) (t (cadr arg)))) (build-rule (arglist body) (if (null arglist) body (let ((arg (car arglist))) `(lambda (,(var-of arg)) (when (and (typep ,(var-of arg) ',(sym-of arg)) ,(test-of arg)) ,(build-rule (cdr arglist) body))))))) `(make-instance 'rule :left-hand-side ',left-hand-side :right-hand-side ,(build-rule arglist (if (or (null body) (symbolp (car body))) `(make-instance ',left-hand-side ,@body) `(progn ,@body))) :symbols ,(coerce (mapcar #'sym-of arglist) 'vector) :predict-test ,predict-test))) (defmacro grammar (&body body) "Create a grammar object from a set of rules." (let ((rule (gensym "RULE")) (rules (gensym "RULES")) (result (gensym "RESULT"))) `(let* ((,rules (list ,@(loop for rule in body collect `(grammar-rule ,rule)))) (,result (make-instance 'grammar))) (dolist (,rule ,rules ,result) (add-rule ,rule ,result))))) (defgeneric add-rule (rule grammar)) (defmethod add-rule (rule (grammar grammar)) (push rule (rules grammar)) (setf (slot-value rule 'number) (slot-value grammar 'number-of-rules)) (incf (slot-value grammar 'number-of-rules)) (clrhash (hash grammar)) (let (rhs-symbols) (dolist (rule (rules grammar)) (setf rhs-symbols (union rhs-symbols (coerce (symbols rule) 'list)))) (dolist (rule (rules grammar)) (let ((lhs-symbol (left-hand-side rule))) (dolist (rhs-symbol rhs-symbols) (when (or (subtypep lhs-symbol rhs-symbol) (subtypep rhs-symbol lhs-symbol)) (pushnew rule (gethash rhs-symbol (hash grammar))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; parser (defclass parser () ((grammar :initarg :grammar :reader parser-grammar) (target :initarg :target :reader target) (initial-state :reader initial-state))) (defclass rule-item () ((parse-trees :initform '() :initarg :parse-trees :reader parse-trees))) (defclass incomplete-item (rule-item) ((orig-state :initarg :orig-state :reader orig-state) (predicted-from :initarg :predicted-from :reader predicted-from) (rule :initarg :rule :reader rule) (dot-position :initarg :dot-position :reader dot-position) (suffix :initarg :suffix :reader suffix))) (defmethod print-object ((item incomplete-item) stream) (format stream "[~a ->" (left-hand-side (rule item))) (loop for i from 0 below (dot-position item) do (format stream " ~a" (aref (symbols (rule item)) i))) (format stream " *") (loop for i from (dot-position item) below (length (symbols (rule item))) do (format stream " ~a" (aref (symbols (rule item)) i))) (format stream "]")) (defun derive-and-handle-item (prev-item parse-tree orig-state to-state) (let ((remaining (funcall (suffix prev-item) parse-tree))) (cond ((null remaining) nil) ((functionp remaining) (handle-incomplete-item (make-instance 'incomplete-item :orig-state (orig-state prev-item) :predicted-from (predicted-from prev-item) :rule (rule prev-item) :dot-position (1+ (dot-position prev-item)) :parse-trees (cons parse-tree (parse-trees prev-item)) :suffix remaining) orig-state to-state)) (t (let* ((parse-trees (cons parse-tree (parse-trees prev-item))) (start (find-if-not #'null parse-trees :from-end t :key #'start-offset)) (end (find-if-not #'null parse-trees :key #'end-offset))) (with-slots (start-mark size) remaining (when start (setf start-mark (start-mark start) size (- (end-offset end) (start-offset start)))) (potentially-handle-parse-tree remaining orig-state to-state))))))) (defun item-equal (item1 item2) (declare (optimize speed)) (and (eq (rule item1) (rule item2)) (do ((trees1 (parse-trees item1) (cdr trees1)) (trees2 (parse-trees item2) (cdr trees2))) ((and (null trees1) (null trees2)) t) (when (or (null trees1) (null trees2)) (return nil)) (when (not (parse-tree-equal (car trees1) (car trees2))) (return nil))))) (defun parse-tree-equal (tree1 tree2) (eq (class-of tree1) (class-of tree2))) (defgeneric parse-tree-better (tree1 tree2)) (defmethod parse-tree-better (tree1 tree2) nil) (defclass parser-state () ((parser :initarg :parser :reader parser) (incomplete-items :initform (make-hash-table :test #'eq) :reader incomplete-items) (parse-trees :initform (make-hash-table :test #'eq) :reader parse-trees) (last-nonempty-state :initarg :last-nonempty-state :accessor last-nonempty-state) (predicted-rules))) (defmethod initialize-instance :after ((state parser-state) &rest args) (declare (ignore args)) (with-slots (predicted-rules) state (setf predicted-rules (make-array (slot-value (parser-grammar (parser state)) 'number-of-rules) :element-type 'bit :initial-element 0)))) (defun map-over-incomplete-items (state fun) (maphash (lambda (key incomplete-items) (loop for incomplete-item in incomplete-items do (funcall fun key incomplete-item))) (incomplete-items state))) (defun potentially-handle-parse-tree (parse-tree from-state to-state) (let ((parse-trees (parse-trees to-state))) (flet ((handle-parse-tree () (map-over-incomplete-items from-state (lambda (orig-state incomplete-item) (derive-and-handle-item incomplete-item parse-tree orig-state to-state))))) (cond ((find parse-tree (gethash from-state parse-trees) :test #'parse-tree-better) (setf (gethash from-state parse-trees) (cons parse-tree (remove parse-tree (gethash from-state parse-trees) :test #'parse-tree-better))) (handle-parse-tree)) ((find parse-tree (gethash from-state parse-trees) :test (lambda (x y) (or (parse-tree-better y x) (parse-tree-equal y x)))) nil) (t (push parse-tree (gethash from-state parse-trees)) (handle-parse-tree)))))) (defun predict (item state tokens) (dolist (rule (gethash (aref (symbols (rule item)) (dot-position item)) (hash (parser-grammar (parser state))))) (if (functionp (right-hand-side rule)) (let ((predicted-rules (slot-value state 'predicted-rules)) (rule-number (slot-value rule 'number)) (predict-test (predict-test rule))) (when (zerop (sbit predicted-rules rule-number)) (setf (sbit predicted-rules rule-number) 1) (when (or (null predict-test) (some predict-test tokens)) (handle-and-predict-incomplete-item (make-instance 'incomplete-item :orig-state state :predicted-from item :rule rule :dot-position 0 :suffix (right-hand-side rule)) state tokens)))) (potentially-handle-parse-tree (right-hand-side rule) state state))) (loop for parse-tree in (gethash state (parse-trees state)) do (derive-and-handle-item item parse-tree state state))) (defun handle-incomplete-item (item orig-state to-state) (declare (optimize speed)) (cond ((find item (the list (gethash orig-state (incomplete-items to-state))) :test #'item-equal) nil) (t (push item (gethash orig-state (incomplete-items to-state)))))) (defun handle-and-predict-incomplete-item (item state tokens) (declare (optimize speed)) (cond ((find item (the list (gethash state (incomplete-items state))) :test #'item-equal) nil) (t (push item (gethash state (incomplete-items state))) (predict item state tokens)))) (defmethod initialize-instance :after ((parser parser) &rest args) (declare (ignore args)) (with-slots (grammar initial-state) parser (setf initial-state (make-instance 'parser-state :parser parser)) (setf (last-nonempty-state initial-state) initial-state) (loop for rule in (rules grammar) do (when (let ((sym (left-hand-side rule))) (or (subtypep (target parser) sym) (subtypep sym (target parser)))) (if (functionp (right-hand-side rule)) (let ((predicted-rules (slot-value initial-state 'predicted-rules)) (rule-number (slot-value rule 'number)) (predict-test (predict-test rule))) (when (zerop (sbit predicted-rules rule-number)) (setf (sbit predicted-rules rule-number) 1) (when (null predict-test) (handle-and-predict-incomplete-item (make-instance 'incomplete-item :orig-state initial-state :predicted-from nil :rule rule :dot-position 0 :suffix (right-hand-side rule)) initial-state nil)))) (potentially-handle-parse-tree (right-hand-side rule) initial-state initial-state)))))) (defun state-contains-target-p (state) (loop with target = (target (parser state)) for parse-tree in (gethash (initial-state (parser state)) (parse-trees state)) when (typep parse-tree target) do (return parse-tree))) (defun advance-parse (parser tokens state) (maphash (lambda (from-state items) (declare (ignore from-state)) (dolist (item items) (predict item state tokens))) (incomplete-items state)) (let ((new-state (make-instance 'parser-state :parser parser))) (loop for token in tokens do (potentially-handle-parse-tree token state new-state)) (setf (last-nonempty-state new-state) (if (or (plusp (hash-table-count (incomplete-items new-state))) (state-contains-target-p new-state)) new-state (last-nonempty-state state))) new-state)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Code for analysing parse stack (defun parse-stack-top (state) "for a given state, return the top of the parse stack, or NIL if the parse stack is empty in that state." (when (plusp (hash-table-count (incomplete-items state))) (maphash (lambda (state items) (declare (ignore state)) (return-from parse-stack-top (car items))) (incomplete-items state)))) (defun target-parse-tree (state) "for a given state, return a target parse tree, or NIL if this state does not represent a complete parse of the target." (state-contains-target-p state)) (defun parse-state-empty-p (state) (and (null (parse-stack-top state)) (null (target-parse-tree state)))) (defun parse-stack-next (parse-stack) "given a parse stack frame, return the next frame in the stack." (assert (not (null parse-stack))) (predicted-from parse-stack)) (defun parse-stack-symbol (parse-stack) "given a parse stack frame, return the target symbol of the frame." (assert (not (null parse-stack))) (left-hand-side (rule parse-stack))) (defun parse-stack-parse-trees (parse-stack) "given a parse stack frame, return a list (in the reverse order of analysis) of the parse trees recognized. The return value reveals internal state of the parser. Do not alter it!" (assert (not (null parse-stack))) (parse-trees parse-stack)) (defun map-over-parse-trees (function state) (labels ((map-incomplete-item (item) (unless (null (predicted-from item)) (map-incomplete-item (predicted-from item))) (loop for parse-tree in (reverse (parse-trees item)) do (funcall function parse-tree)))) (let ((state (last-nonempty-state state))) (if (plusp (hash-table-count (incomplete-items state))) (maphash (lambda (state items) (declare (ignore state)) (map-incomplete-item (car items)) (return-from map-over-parse-trees nil)) (incomplete-items state)) (funcall function (state-contains-target-p state)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Syntax querying functions. (defgeneric word-constituentp (syntax obj) (:documentation "Return T if `obj' is a word constituent character in `syntax'.") (:method ((syntax syntax) obj) nil) (:method ((syntax syntax) (obj character)) (alphanumericp obj))) (defgeneric whitespacep (syntax obj) (:documentation "Return T if `obj' is a whitespace character in `syntax'.") (:method ((syntax syntax) obj) nil) (:method ((syntax syntax) (obj character)) (when (member obj '(#\Space #\Tab #\Newline #\Page #\Return)) t))) (defgeneric page-delimiter (syntax) (:documentation "Return the object sequence used as a page deliminter in `syntax'.") (:method ((syntax syntax)) '(#\Newline #\Page))) (defgeneric paragraph-delimiter (syntax) (:documentation "Return the object sequence used as a paragraph deliminter in `syntax'.") (:method ((syntax syntax)) '(#\Newline #\Newline))) (defgeneric syntax-line-indentation (syntax mark tab-width) (:documentation "Return the correct indentation for the line containing the mark, according to the specified syntax.")) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/buffer-streams.lisp0000640000175000017500000001350210741375212021477 0ustar pdmpdm;;; -*- Mode: Lisp; Package: DREI-CORE -*- ;;; (c) copyright 2006-2007 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :drei-core) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; (Gray) streams interface to buffers. (defclass buffer-stream (fundamental-character-input-stream fundamental-character-output-stream) ((%buffer :initarg :buffer :initform (error "A buffer must be provided") :reader buffer :documentation "The buffer from which this stream will read data.") (%start-mark :initarg :start-mark :reader start-mark :documentation "A mark into the buffer of the stream that indicates from which point on the stream will read data from the buffer. By default, the beginning of the buffer. This mark should not be changed.") (%end-mark :initarg :end-mark :reader end-mark :documentation "A mark into the buffer of the stream that indicates the buffer position that the stream will consider end-of-file. By default, the end of the buffer. This mark should not be changed.") (%point :accessor point-of :documentation "A mark indicating the current position in the buffer of the stream.")) (:documentation "A bidirectional stream that performs I/O on an underlying Drei buffer. Marks can be provided to let the stream operate on only a specific section of the buffer.")) (defmethod initialize-instance :after ((stream buffer-stream) &key) (unless (slot-boundp stream '%start-mark) (setf (slot-value stream '%start-mark) (clone-mark (point (buffer stream)) :left)) (beginning-of-buffer (start-mark stream))) (unless (slot-boundp stream '%end-mark) (setf (slot-value stream '%end-mark) (clone-mark (start-mark stream) :right)) (end-of-buffer (end-mark stream))) (setf (point stream) (narrow-mark (clone-mark (start-mark stream) :right) (start-mark stream) (end-mark stream)))) ;;; Input methods. (defmethod stream-read-char ((stream buffer-stream)) (if (end-of-buffer-p (point stream)) :eof (prog1 (object-after (point stream)) (forward-object (point stream))))) (defmethod stream-unread-char ((stream buffer-stream) (char character)) (unless (beginning-of-buffer-p (point stream)) (backward-object (point stream)) nil)) (defmethod stream-read-char-no-hang ((stream buffer-stream)) (stream-read-char stream)) (defmethod stream-peek-char ((stream buffer-stream)) (if (end-of-buffer-p (point stream)) :eof (object-after (point stream)))) (defmethod stream-listen ((stream buffer-stream)) (not (end-of-buffer-p (point stream)))) (defmethod stream-read-line ((stream buffer-stream)) (let ((orig-offset (offset (point stream))) (end-of-line-offset (offset (end-of-line (point stream))))) (unless (end-of-buffer-p (point stream)) (forward-object (point stream))) (values (buffer-substring (buffer stream) orig-offset end-of-line-offset) (end-of-buffer-p (point stream))))) (defmethod stream-clear-input ((stream buffer-stream)) nil) ;;; Output methods. (defmethod stream-write-char ((stream buffer-stream) char) (insert-object (point stream) char)) (defmethod stream-line-column ((stream buffer-stream)) (column-number (point stream))) (defmethod stream-start-line-p ((stream buffer-stream)) (or (mark= (point stream) (start-mark stream)) (beginning-of-line-p (point stream)))) (defmethod stream-write-string ((stream buffer-stream) string &optional (start 0) end) (insert-sequence (point stream) (subseq string start end))) (defmethod stream-terpri ((stream buffer-stream)) (insert-object (point stream) #\Newline)) (defmethod stream-fresh-line ((stream buffer-stream)) (unless (stream-start-line-p stream) (stream-terpri stream))) (defmethod stream-finish-output ((stream buffer-stream)) (declare (ignore stream)) nil) (defmethod stream-force-output ((stream buffer-stream)) (declare (ignore stream)) nil) (defmethod stream-clear-output ((stream buffer-stream)) (declare (ignore stream)) nil) (defmethod stream-advance-to-column ((stream buffer-stream) (column integer)) (call-next-method)) (defmethod interactive-stream-p ((stream buffer-stream)) nil) ;;; Interface functions. (defun make-buffer-stream (&key (buffer (current-buffer)) (start-mark nil start-mark-p) (end-mark nil end-mark-p)) "Create a buffer stream object reading data from `buffer'. By default, the stream will read from the beginning of the buffer and until the end of the buffer, but this can be changed via the optional arguments `start-mark' and `end-mark'." (apply #'make-instance 'buffer-stream :buffer buffer (append (when start-mark-p (list :start-mark (clone-mark start-mark :left))) (when end-mark-p (list :end-mark (clone-mark end-mark :right)))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/drei-clim.lisp0000644000175000017500000006230611345155772020441 0ustar pdmpdm;;; -*- Mode: Lisp; Package: DREI -*- ;;; (c) copyright 2005 by ;;; Robert Strandh (strandh@labri.fr) ;;; (c) copyright 2005 by ;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr) ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Implementation of most of the CLIM-facing parts of Drei, including ;;; the pane and gadget itself as well as the command tables. The ;;; solely input-editor oriented stuff is in input-editor.lisp. (in-package :drei) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; The Drei gadget and pane. ;;; ;;; An application can use Drei in two different ways - by using ;;; `drei-pane' directly, and controlling the command loop itself ;;; (this is what Climacs does), which offers complete control, but ;;; may end up being crummy if the application is not primarily a text ;;; editor, or it can opt to use the Drei gadget by using the keyword ;;; symbol `:drei' as the type argument to `make-pane'. This will ;;; create a Drei gadget that acts independently of the application ;;; command loop (through event handlers), in effect, it should be a ;;; drop-in replacement for the standard CLIM `:text-editor' gadget. (defvar *background-color* +white+) (defvar *foreground-color* +black+) (defvar *show-mark* nil "If true, show a visual representation of the mark.") ;;; Cursors. ;;; NOTE: Despite the name, this does not have anything to do with ;;; CLIM cursors, though perhaps this facility should be built on top ;;; of what CLIM already provides. That seemed a bit (=a lot) hairy, ;;; though. ;;; Cursors are output records. After a cursor is created, The owning ;;; Drei instance should add it to the output stream. The owner of the ;;; cursor (a Drei instance) is responsible for removing the cursor ;;; once it is done with it. Cursors can be active/inactive and ;;; enabled/disabled and have the same activity-status as their ;;; associated view. (defclass drei-cursor (standard-sequence-output-record) ((%view :reader view :initarg :view :initform (error "A Drei cursor must be associated with a Drei view") :type drei-view) (%output-stream :reader output-stream :initarg :output-stream :initform (error "A Drei cursor must be associated with an output stream") :type extended-output-stream) (%mark :reader mark-of :initarg :mark :initform (error "A Drei cursor must be associated with a mark.")) (%enabled :accessor enabled :initarg :enabled :initform t :type boolean :documentation "When a cursor is enabled, it will be drawn when its associated Drei instance is drawn. When it is not enabled, it will simply be ignored during redisplay.") (%active-ink :accessor active-ink :initarg :active-ink :initform +flipping-ink+ :type design :documentation "The ink used to draw the cursor when it is active.") (%inactive-ink :accessor inactive-ink :initarg :inactive-ink :initform +blue+ :type color :documentation "The ink used to draw the cursor when it is inactive.")) (:documentation "A visual representation of a given mark in a Drei buffer. The most important role for instances of subclasses of this class is to visually represent the position of point.")) (defgeneric active (cursor) (:documentation "Whether the cursor is active or not. An active cursor is drawn using the active ink, and an inactive is drawn using the inactive ink. Typically, a cursor will be active when the associated Drei view has focus.") (:method ((cursor drei-cursor)) (active (view cursor)))) (defgeneric ink (cursor) (:documentation "Return the ink object that should be used for displaying the given cursor.")) (defmethod ink ((cursor drei-cursor)) (if (active cursor) (active-ink cursor) (inactive-ink cursor))) (defmethod (setf enabled) :after ((new-val null) (cursor drei-cursor)) (clear-output-record cursor)) (defclass point-cursor (drei-cursor) () (:default-initargs :mark nil :active t) (:documentation "A class that should be used for the visual representation of the point of a Drei instance.")) (defmethod mark-of ((cursor point-cursor)) (point (view cursor))) (defclass mark-cursor (drei-cursor) () (:default-initargs :active-ink +dark-green+ :inactive-ink +dark-green+ :mark nil :active t) (:documentation "A class that should be used for the visual representation of the mark of a Drei instance.")) (defmethod mark-of ((cursor mark-cursor)) (mark (view cursor))) (defmethod enabled ((cursor mark-cursor)) (and (call-next-method) *show-mark*)) (defgeneric visible-1 (cursor view) (:documentation "Is `cursor', associated with `view', visible? If this function returns true, it is assumed that it is safe to display `cursor' to the editor stream. If just one of the applicable methods returns false, the entire function returns false.") (:method-combination and) (:method and (cursor view) (enabled cursor))) (defun visible-p (cursor) "Return true if `cursor' is visible. This is a trampoline function that calls `visible-1' with `cursor' and the view of `cursor'." (visible-1 cursor (view cursor))) ;;; Drei instances. (defclass drei-pane (drei application-pane) () (:default-initargs :incremental-redisplay nil :end-of-line-action :scroll :background *background-color* :foreground *foreground-color* :display-function 'display-drei-pane :width 900 :active nil) (:metaclass modual-class) (:documentation "An actual, instantiable Drei pane that permits (and requires) the host application to control the command loop completely.")) (defmethod stream-default-view ((stream drei-pane)) (view stream)) (defmethod display-drei ((drei drei-pane) &rest args) (declare (ignore args)) (redisplay-frame-pane (pane-frame drei) drei)) (defmethod editor-pane ((drei drei-pane)) ;; The whole point of the `drei-pane' class is that it's its own ;; display surface. drei) (defmethod visible-1 and (cursor (view drei-buffer-view)) ;; We should only redisplay when the cursor is on display, or ;; `offset-to-screen-position' will return a non-number. Also don't ;; display if the view hasn't been displayed yet. (and (<= (offset (top view)) (offset (mark cursor)) (offset (bot view))) (plusp (displayed-lines-count view)))) (defmethod (setf view) :after (new-val (drei drei-pane)) (window-clear drei)) (defmethod (setf cursors) :around (new-cursors (drei drei-pane)) (let ((old-cursors (cursors drei))) (call-next-method) (dolist (old-cursor old-cursors) (erase-output-record old-cursor drei nil)) (dolist (new-cursor new-cursors) (stream-add-output-record drei new-cursor)))) (defmethod note-sheet-grafted :after ((pane drei-pane)) (setf (stream-default-view pane) (view pane))) ;;; The fun is that in the gadget version of Drei, we do not control ;;; the application command loop, and in fact, need to operate ;;; completely independently of it - we can only act when the our port ;;; deigns to bestow an event upon the gadget. So, we basically have ;;; to manually take care of reading gestures (asynchronously), ;;; redisplaying, updating the syntax and all the other fun ;;; details. On top of this, we have to account for the fact that some ;;; other part of the application might catch the users fancy, and ;;; since we do not (and can not) control the command loop, we can not ;;; prevent the user from "leaving" the gadget at inconvenient times ;;; (such as in the middle of entering a complex set of gestures, or ;;; answering questions asked by a command). So, we keep some state ;;; information in the `drei-gadget-pane' object and use it to cobble ;;; together our own poor man's version of an ESA command loop. Syntax ;;; updating is done after a command has been executed, and only then ;;; (or by commands at their own discretion). (defclass drei-gadget-pane (drei-pane value-gadget action-gadget asynchronous-command-processor dead-key-merging-command-processor) ((%currently-processing :initform nil :accessor currently-processing-p) (%previous-focus :accessor previous-focus :initform nil :documentation "The pane that previously had keyboard focus")) (:metaclass modual-class) (:default-initargs :command-executor 'execute-drei-command) (:documentation "An actual, instantiable Drei gadget with event-based command processing.")) (defmethod initialize-instance :after ((drei drei-gadget-pane) &rest args) (declare (ignore args)) ;; Heh, it seems that the :ACTIVE initarg steps over McCLIM's toes ;; and affects whether the gadget is active or not (which is ;; different from whether the Drei is active). It must be active by ;; default! (activate-gadget drei)) (defmethod gadget-value ((gadget drei-gadget-pane)) ;; This is supposed to be a string, but a Drei buffer can contain ;; literal objects. We return a string if we can, an array ;; otherwise. This is a bit slow, as we cons up the array and then ;; probably a new one for the string, most of the time. (let ((contents (buffer-sequence (buffer (view gadget)) 0 (size (buffer (view gadget)))))) (if (every #'characterp contents) (coerce contents 'string) contents))) (defmethod (setf gadget-value) (new-value (gadget drei-gadget-pane) &key (invoke-callback t)) ;; I think we're supposed to permit this, even if the buffer is ;; non-editable. (letf (((read-only-p (buffer (view gadget))) nil)) (performing-drei-operations (gadget :with-undo nil :redisplay nil) (delete-buffer-range (buffer (view gadget)) 0 (size (buffer (view gadget)))) (insert-buffer-sequence (buffer (view gadget)) 0 new-value))) (when invoke-callback (value-changed-callback gadget (gadget-client gadget) (gadget-id gadget) new-value))) (defmethod armed-callback :after ((gadget drei-gadget-pane) client id) (declare (ignore client id)) (setf (active gadget) t) (display-drei gadget)) (defmethod disarmed-callback :after ((gadget drei-gadget-pane) client id) (declare (ignore client id)) (setf (active gadget) nil) (display-drei gadget)) (defgeneric handle-gesture (drei gesture) (:documentation "This generic function is called whenever a Drei gadget variant has determined that a keyboard event corresponds to a useful gesture that should be handled. A useful gesture is, for example, one that is not simply a click on a modifier key.")) (defun propagate-changed-value (drei) (when (modified-p (view drei)) (when (gadget-value-changed-callback drei) (value-changed-callback drei (gadget-client drei) (gadget-id drei) (gadget-value drei))) (setf (modified-p (view drei)) nil))) (defmethod handle-gesture ((drei drei-gadget-pane) gesture) (let ((*command-processor* drei) (*abort-gestures* *esa-abort-gestures*) (*standard-input* drei)) (accepting-from-user (drei) (handler-case (process-gesture drei gesture) (unbound-gesture-sequence (c) (display-message "~A is unbound" (gesture-name (gestures c)))) (abort-gesture () (display-message "Aborted"))) (display-drei drei :redisplay-minibuffer t) (propagate-changed-value drei)))) ;;; This is the method that functions as the entry point for all Drei ;;; gadget logic. (defmethod handle-event ((gadget drei-gadget-pane) (event key-press-event)) (unless (and (currently-processing-p gadget) (directly-processing-p gadget)) (letf (((currently-processing-p gadget) t)) (let ((gesture (convert-to-gesture event))) (when (proper-gesture-p gesture) (with-bound-drei-special-variables (gadget :prompt (format nil "~A " (gesture-name gesture))) (handle-gesture gadget gesture))))))) (defmethod handle-event ((gadget drei-gadget-pane) (event clim-backend:selection-notify-event)) ;; Cargo-culted from above: (unless (and (currently-processing-p gadget) (directly-processing-p gadget)) (letf (((currently-processing-p gadget) t)) (insert-sequence (point (view gadget)) (clim-backend:get-selection-from-event (port gadget) event)) (display-drei gadget :redisplay-minibuffer t) (propagate-changed-value gadget)))) (defmethod handle-event :before ((gadget drei-gadget-pane) (event pointer-button-press-event)) (let ((previous (stream-set-input-focus gadget))) (when (and previous (typep previous 'gadget)) (disarmed-callback previous (gadget-client previous) (gadget-id previous))) (armed-callback gadget (gadget-client gadget) (gadget-id gadget)))) (defmethod invoke-accepting-from-user ((drei drei-gadget-pane) (continuation function)) ;; When an `accept' is called during the execution of a command for ;; the Drei gadget, we must deactivate the gadget in order to not ;; eat keyboard events. (unwind-protect (progn (disarmed-callback drei t t) (funcall continuation)) (armed-callback drei t t))) (defmethod additional-command-tables append ((drei drei-gadget-pane) (table drei-command-table)) `(exclusive-gadget-table ,(frame-command-table *application-frame*))) (defclass drei-area (drei displayed-output-record region command-processor instant-macro-execution-mixin) ((%background-ink :initarg :background-ink :reader background-ink :initform +background-ink+) (%min-width :reader min-width :initarg :min-width :initform 0 :documentation "The minimum width of the Drei editable area. Should be an integer >= 0 or T, meaning that it will extend to the end of the viewport, if the Drei area is in a scrolling arrangement.") (%position :accessor area-position :initarg :area-position :documentation "The position of the Drei editing area in the coordinate system of the encapsulated stream. An (X,Y) list, not necessarily the same as the position of the associated output record.") (%parent-output-record :accessor output-record-parent :initarg :parent :initform nil :documentation "The parent output record of the Drei area instance.")) (:metaclass modual-class) (:default-initargs :command-executor 'execute-drei-command) (:documentation "A Drei editable area implemented as an output record.")) (defmethod initialize-instance :after ((area drei-area) &key x-position y-position) (check-type x-position number) (check-type y-position number) (setf (area-position area) (list x-position y-position) (extend-pane-bottom (view area)) t)) (defmethod (setf view) :after ((new-view drei-view) (drei drei-area)) (setf (extend-pane-bottom new-view) t)) (defmethod (setf cursors) :after (new-cursors (drei drei-area)) (dolist (new-cursor (cursors drei)) (setf (output-record-parent new-cursor) drei))) (defmethod esa-current-window ((drei drei-area)) (editor-pane drei)) (defmethod display-drei ((drei drei-area) &rest args) (declare (ignore args)) (display-drei-area drei)) (defmethod execute-drei-command ((drei drei-area) command) (let ((*standard-input* (or *minibuffer* *standard-input*))) (call-next-method))) ;;; Implementation of the displayed-output-record and region protocol ;;; for Drei areas. The redisplay-related stuff is in ;;; drei-redisplay.lisp. (defmethod output-record-position ((record drei-area)) (values-list (area-position record))) (defmethod* (setf output-record-position) ((new-x number) (new-y number) (record drei-area)) (multiple-value-bind (old-x old-y) (output-record-position record) (setf (area-position record) (list new-x new-y)) (dolist (cursor (cursors record)) (multiple-value-bind (cursor-x cursor-y) (output-record-position cursor) (setf (output-record-position cursor) (values (+ (- cursor-x old-x) new-x) (+ (- cursor-y old-y) new-y))))))) (defmethod output-record-start-cursor-position ((record drei-area)) (output-record-position record)) (defmethod* (setf output-record-start-cursor-position) ((new-x number) (new-y number) (record drei-area)) (setf (output-record-position record) (values new-x new-y))) (defmethod output-record-hit-detection-rectangle* ((record drei-area)) (bounding-rectangle* record)) (defmethod output-record-refined-position-test ((record drei-area) x y) t) (defmethod displayed-output-record-ink ((record drei-area)) +foreground-ink+) (defmethod output-record-children ((record drei-area)) (cursors record)) (defmethod output-record-count ((record drei-area)) (length (cursors record))) (defmethod map-over-output-records-containing-position (function (record drei-area) x y &optional (x-offset 0) (y-offset 0) &rest function-args) (declare (ignore x-offset y-offset)) (dolist (cursor (cursors record)) (when (region-contains-position-p cursor x y) (apply function cursor function-args)))) (defmethod map-over-output-records-overlapping-region (function (record drei-area) region &optional (x-offset 0) (y-offset 0) &rest function-args) (declare (ignore x-offset y-offset)) (dolist (cursor (cursors record)) (when (region-intersects-region-p cursor region) (apply function cursor function-args)))) (defmethod bounding-rectangle* ((drei drei-area)) (with-accessors ((pane editor-pane) (min-width min-width)) drei (let* ((style (medium-text-style pane)) (style-width (text-style-width style pane)) (height (text-style-height style pane))) (multiple-value-bind (x1 y1 x2 y2) (drei-bounding-rectangle* drei) (when (= x1 y1 x2 y2 0) ;; It hasn't been displayed yet, so stuff the position into ;; it... (setf x1 (first (area-position drei)) y1 (second (area-position drei)))) (values x1 y1 (max x2 (+ x1 style-width) (cond ((numberp min-width) (+ x1 min-width)) ;; Must be T, then. ((pane-viewport pane) (+ x1 (bounding-rectangle-width (pane-viewport-region pane)))) (t 0))) (max y2 (+ y1 height))))))) (defmethod replay-output-record :after ((drei drei-area) (stream extended-output-stream) &optional (x-offset 0) (y-offset 0) (region +everywhere+)) (declare (ignore x-offset y-offset region)) (dolist (cursor (cursors drei)) (replay cursor stream))) (defmethod recompute-extent-for-changed-child ((drei drei-area) (child output-record) old-min-x old-min-y old-max-x old-max-y) nil) (defmethod rectangle-edges* ((rectangle drei-area)) (bounding-rectangle* rectangle)) (defmethod region-union ((region1 drei-area) region2) (region-union (bounding-rectangle region1) region2)) (defmethod region-union (region1 (region2 drei-area)) (region-union region1 (bounding-rectangle region2))) (defmethod region-intersection ((region1 drei-area) region2) (region-intersection (bounding-rectangle region1) region2)) (defmethod region-intersection (region1 (region2 drei-area)) (region-intersection region1 (bounding-rectangle region2))) (defmethod region-difference ((region1 drei-area) region2) (region-difference (bounding-rectangle region1) region2)) (defmethod region-difference (region1 (region2 drei-area)) (region-difference region1 (bounding-rectangle region2))) ;; For areas, we need to switch to ESA abort gestures after we have ;; left the CLIM gesture reading machinery, but before we start doing ;; ESA gesture processing. (defmethod process-gesture :around ((command-processor drei-area) gesture) (let ((*abort-gestures* *esa-abort-gestures*)) (call-next-method))) (defmethod (setf active) :after (new-val (drei drei-area)) (replay drei (editor-pane drei))) (defmethod additional-command-tables append ((drei drei-area) (table drei-command-table)) `(exclusive-input-editor-table)) (defclass drei-minibuffer-pane (minibuffer-pane) () (:default-initargs :background +light-gray+ :max-height 20 :height 20 :min-height 20)) (defclass drei-constellation (vrack-pane) ((drei :initform (error "A Drei instance must be provided for the constellation.") :accessor drei :initarg :drei) (minibuffer :initform (error "A minibuffer instance must be provided for the constellation.") :accessor minibuffer :initarg :minibuffer)) (:documentation "A constellation of a Drei gadget instance and a minibuffer.")) (defmethod display-drei :after ((drei drei) &key redisplay-minibuffer) (when (and *minibuffer* redisplay-minibuffer) ;; We need to use :force-p t to remove any existing output from ;; the pane. (redisplay-frame-pane (pane-frame *minibuffer*) *minibuffer* :force-p t))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Programmer interface stuff ;;; ;;; We want it to be dead-easy to integrate Drei in CLIM applications. ;;; XXX This is brittle. If an :around method, that does funky ;;; (side-effecting) stuff, runs before this method, things might ;;; break. Let's hope nothing of that sort happens (this works in ;;; McCLIM. The method, not the hoping.) (defmethod make-pane-1 :around (fm (frame application-frame) (type (eql :drei)) &rest args &key (syntax nil) (initial-contents "") (minibuffer t) (border-width 1) (scroll-bars :horizontal) (drei-class 'drei-gadget-pane) (view 'textual-drei-syntax-view)) (check-type initial-contents array) (check-type border-width integer) (check-type scroll-bars (member t :both :vertical :horizontal nil)) (with-keywords-removed (args (:minibuffer :scroll-bars :border-width :syntax :drei-class :view)) (let* ((borderp (and border-width (plusp border-width))) (minibuffer-pane (cond ((eq minibuffer t) (make-pane 'drei-minibuffer-pane)) ((typep minibuffer 'minibuffer-pane) minibuffer) ((null minibuffer) nil) (t (error "Provided minibuffer is not T, NIL or a `minibuffer-pane'.")))) (drei-pane (apply #'make-pane-1 fm frame drei-class :minibuffer minibuffer-pane :view (make-instance view) args)) (pane drei-pane) (view (view drei-pane))) (letf (((read-only-p (buffer view)) nil)) (insert-buffer-sequence (buffer view) 0 initial-contents)) (if syntax (setf (syntax view) (make-instance (or (when (syntaxp syntax) syntax) (syntax-from-name (string syntax)) (error "Syntax ~A not found" (string syntax))) :buffer (buffer view)))) (when scroll-bars (setf pane (scrolling (:scroll-bar scroll-bars) pane))) (when minibuffer (setf pane (make-pane 'drei-constellation :drei drei-pane :minibuffer minibuffer-pane :contents (list pane minibuffer-pane)))) (when borderp (setf pane (#+(or mcclim building-mcclim) climi::bordering #-(or mcclim building-mcclim) outlining (:border-width border-width) pane))) pane))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/undo.lisp0000640000175000017500000001137310534772661017534 0ustar pdmpdm;;; -*- Mode: Lisp; Package: DREI-UNDO -*- ;;; (c) copyright 2005 by ;;; Robert Strandh (strandh@labri.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; General-purpose undo module (in-package :drei-undo) (defgeneric add-undo (undo-record undo-tree) (:documentation "Add an undo record to the undo tree below the current state, and set the current state to be below the transition represented by the undo record.")) (defgeneric flip-undo-record (undo-record) (:documentation "This function is called by the undo module whenever the current state is changed from its current value to that of the parent state (presumably as a result of a call to undo) or to that of one of its child states. Client code is required to supply methods for this function on client-specific subclasses of `undo-record'.")) (defgeneric undo (undo-tree &optional n) (:documentation "Move the current state `n' steps up the undo tree and call `flip-undo-record' on each step. If the current state is at a level less than `n', a `no-more-undo' condition is signaled and the current state is not moved (and no calls to `flip-undo-record' are made). As long as no new record are added to the tree, the undo module remembers which branch it was in before a sequence of calls to undo.")) (defgeneric redo (undo-tree &optional n) (:documentation "Move the current state `n' steps down the remembered branch of the undo tree and call `flip-undo-record' on each step. If the remembered branch is shorter than `n', a `no-more-undo' condition is signaled and the current state is not moved (and no calls to `flip-undo-record' are made).")) (define-condition no-more-undo (simple-error) () (:report (lambda (condition stream) (declare (ignore condition)) (format stream "No more undo"))) (:documentation "A condition of this type is signaled whenever an attempt is made to call undo when the application is in its initial state.")) (defclass undo-tree () () (:documentation "The base class for all undo trees.")) (defclass standard-undo-tree (undo-tree) ((current-record :accessor current-record) (leaf-record :accessor leaf-record) (redo-path :initform '() :accessor redo-path) (children :initform '() :accessor children) (depth :initform 0 :reader depth)) (:documentation "The base class for all undo records. Client code typically derives subclasses of this class that are specific to the application.")) (defmethod initialize-instance :after ((tree standard-undo-tree) &rest args) (declare (ignore args)) (setf (current-record tree) tree (leaf-record tree) tree)) (defclass undo-record () () (:documentation "The base class for all undo records.")) (defgeneric undo-tree (record) (:documentation "The undo tree to which the undo record `record' belongs.")) (defclass standard-undo-record (undo-record) ((parent :initform nil :accessor parent) (tree :initform nil :accessor undo-tree :documentation "The undo tree to which the undo record belongs.") (children :initform '() :accessor children) (depth :initform nil :accessor depth)) (:documentation "Standard instantiable class for undo records.")) (defmethod add-undo ((record standard-undo-record) (tree standard-undo-tree)) (push record (children (current-record tree))) (setf (undo-tree record) tree (parent record) (current-record tree) (depth record) (1+ (depth (current-record tree))) (current-record tree) record (leaf-record tree) record (redo-path tree) '())) (defmethod undo ((tree standard-undo-tree) &optional (n 1)) (assert (<= n (depth (current-record tree))) () (make-condition 'no-more-undo)) (loop repeat n do (flip-undo-record (current-record tree)) (push (current-record tree) (redo-path tree)) (setf (current-record tree) (parent (current-record tree))))) (defmethod redo ((tree standard-undo-tree) &optional (n 1)) (assert (<= n (- (depth (leaf-record tree)) (depth (current-record tree)))) () (make-condition 'no-more-undo)) (loop repeat n do (setf (current-record tree) (pop (redo-path tree))) (flip-undo-record (current-record tree)))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/core.lisp0000640000175000017500000004271710741375212017514 0ustar pdmpdm;;; -*- Mode: Lisp; Package: DREI-CORE -*- ;;; (c) copyright 2004-2005 by ;;; Robert Strandh (strandh@labri.fr) ;;; (c) copyright 2004-2005 by ;;; Elliott Johnson (ejohnson@fasl.info) ;;; (c) copyright 2005 by ;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr) ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas@sigkill.dk) (in-package :drei-core) (defgeneric proper-line-indentation (view mark) (:documentation "Return the offset to which `mark' should ideally be indented to according to `view'.")) (defmethod proper-line-indentation ((view drei-syntax-view) (mark mark)) (syntax-line-indentation (syntax view) mark (tab-space-count view))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Misc stuff (defun possibly-fill-line () (when (auto-fill-mode (current-view)) (let* ((fill-column (auto-fill-column (current-view))) (offset (offset (point))) (tab-space-count (tab-space-count (current-view)))) (when (>= (buffer-display-column (current-buffer) offset tab-space-count) (1- fill-column)) (fill-line (point) (lambda (mark) (proper-line-indentation (current-view) mark)) fill-column tab-space-count (current-syntax)))))) (defun back-to-indentation (mark syntax) (beginning-of-line mark) (loop until (end-of-line-p mark) while (whitespacep syntax (object-after mark)) do (forward-object mark))) (defun insert-character (char) (unless (constituentp char) (possibly-expand-abbrev (point))) (when (whitespacep (current-syntax) char) (possibly-fill-line)) (if (and (overwrite-mode (current-view)) (not (end-of-line-p (point)))) (progn (delete-range (point)) (insert-object (point) char)) (insert-object (point) char))) (defun delete-horizontal-space (mark syntax &optional (backward-only-p nil)) (let ((mark2 (clone-mark mark))) (loop until (beginning-of-line-p mark) while (whitespacep syntax (object-before mark)) do (backward-object mark)) (unless backward-only-p (loop until (end-of-line-p mark2) while (whitespacep syntax (object-after mark2)) do (forward-object mark2))) (delete-region mark mark2))) (defun indent-current-line (view point) (indent-line point (proper-line-indentation view point) (and (use-tabs view) (tab-space-count view)))) (defun insert-pair (mark syntax &optional (count 0) (open #\() (close #\))) (cond ((> count 0) (loop while (and (not (end-of-buffer-p mark)) (whitespacep syntax (object-after mark))) do (forward-object mark))) ((< count 0) (setf count (- count)) (loop repeat count do (backward-expression mark syntax)))) (unless (or (beginning-of-buffer-p mark) (char= open (object-before mark)) (whitespacep syntax (object-before mark))) (insert-object mark #\Space)) (insert-object mark open) (let ((saved-offset (offset mark))) (loop repeat count do (forward-expression mark syntax)) (insert-object mark close) (unless (or (end-of-buffer-p mark) (char= close (object-after mark)) (whitespacep syntax (object-after mark))) (insert-object mark #\Space)) (setf (offset mark) saved-offset))) (defun move-past-close-and-reindent (view point) (loop until (eql (object-after point) #\)) do (forward-object point)) (forward-object point) (indent-current-line view point)) (defun goto-position (mark pos) (setf (offset mark) pos)) (defun goto-line (mark line-number) (loop with m = (clone-mark mark :right) initially (beginning-of-buffer m) repeat (1- line-number) until (end-of-buffer-p m) do (end-of-line m) do (incf (offset m)) (end-of-line m) finally (beginning-of-line m) (setf (offset mark) (offset m)))) (defun replace-one-string (mark length newstring &optional (use-region-case t)) "Replace LENGTH objects at MARK with NEWSTRING, using the case of those objects if USE-REGION-CASE is true." (let* ((start (offset mark)) (end (+ start length)) (region-case (and use-region-case (buffer-region-case (buffer mark) start end)))) (delete-range mark length) (insert-sequence mark newstring) (when (and use-region-case region-case) (let ((buffer (buffer mark)) (end2 (+ start (length newstring)))) (funcall (case region-case (:upper-case #'upcase-buffer-region) (:lower-case #'downcase-buffer-region) (:capitalized #'capitalize-buffer-region)) buffer start end2))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Character case (defun downcase-word (mark syntax &optional (n 1)) "Convert the next N words to lowercase, leaving mark after the last word." (loop repeat n do (forward-to-word-boundary mark syntax) (let ((offset (offset mark))) (forward-word mark syntax 1 nil) (downcase-region offset mark)))) (defun upcase-word (mark syntax &optional (n 1)) "Convert the next N words to uppercase, leaving mark after the last word." (loop repeat n do (forward-to-word-boundary mark syntax) (let ((offset (offset mark))) (forward-word mark syntax 1 nil) (upcase-region offset mark)))) (defun capitalize-word (mark syntax &optional (n 1)) "Capitalize the next N words, leaving mark after the last word." (loop repeat n do (forward-to-word-boundary mark syntax) (let ((offset (offset mark))) (forward-word mark syntax 1 nil) (capitalize-region offset mark)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Indentation (defun indent-region (view mark1 mark2) "Indent all lines in the region delimited by `mark1' and `mark2' according to the rules of the active syntax in `drei'. `Mark1' and `mark2' will not be modified by this function." (do-buffer-region-lines (line mark1 mark2) (let ((indentation (proper-line-indentation view line))) (indent-line line indentation (and (use-tabs view) (tab-space-count view)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Auto fill (defun fill-line (mark line-indentation-function fill-column tab-width syntax &optional (compress-whitespaces t)) "Breaks the contents of line pointed to by MARK up to MARK into multiple lines such that none of them is longer than FILL-COLUMN. If COMPRESS-WHITESPACES is non-nil, whitespaces are compressed after the decision is made to break the line at a point. For now, the compression means just the deletion of trailing whitespaces." (let ((begin-mark (clone-mark mark))) (beginning-of-line begin-mark) (loop with column = 0 with line-beginning-offset = (offset begin-mark) with walking-mark = (clone-mark begin-mark) while (mark< walking-mark mark) do (let ((object (object-after walking-mark))) (case object (#\Space (setf (offset begin-mark) (offset walking-mark)) (incf column)) (#\Tab (setf (offset begin-mark) (offset walking-mark)) (incf column (- tab-width (mod column tab-width)))) (t (incf column)))) (when (and (>= column fill-column) (/= (offset begin-mark) line-beginning-offset)) (when compress-whitespaces (let ((offset (buffer-search-backward (buffer begin-mark) (offset begin-mark) #(nil) :test #'(lambda (o1 o2) (declare (ignore o2)) (not (whitespacep syntax o1)))))) (when offset (delete-region begin-mark (1+ offset))))) (insert-object begin-mark #\Newline) (incf (offset begin-mark)) (let ((indentation (funcall line-indentation-function begin-mark))) (indent-line begin-mark indentation tab-width)) (beginning-of-line begin-mark) (setf line-beginning-offset (offset begin-mark)) (setf (offset walking-mark) (offset begin-mark)) (setf column 0)) (incf (offset walking-mark))))) (defun fill-region (mark1 mark2 line-indentation-function fill-column tab-width syntax &optional (compress-whitespaces t)) "Fill the region delimited by `mark1' and `mark2'. `Mark1' must be mark<= `mark2.'" (let* ((buffer (buffer mark1))) (do-buffer-region (object offset buffer (offset mark1) (offset mark2)) (when (eql object #\Newline) (setf object #\Space))) (when (>= (buffer-display-column buffer (offset mark2) tab-width) (1- fill-column)) (fill-line mark2 line-indentation-function fill-column tab-width syntax compress-whitespaces)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Indentation (defgeneric indent-line (mark indentation tab-width) (:documentation "Indent the line containing mark with indentation spaces. Use tabs and spaces if tab-width is not nil, otherwise use spaces only.")) (defun indent-line* (mark indentation tab-width left) (let ((mark2 (clone-mark mark))) (beginning-of-line mark2) (loop until (end-of-buffer-p mark2) while (or (eql (object-after mark2) #\Space) (eql (object-after mark2) #\Tab)) do (delete-range mark2 1)) (loop until (zerop indentation) do (cond ((and tab-width (>= indentation tab-width)) (insert-object mark2 #\Tab) (when left ; spaces must follow tabs (forward-object mark2)) (decf indentation tab-width)) (t (insert-object mark2 #\Space) (decf indentation)))))) (defmethod indent-line ((mark left-sticky-mark) indentation tab-width) (indent-line* mark indentation tab-width t)) (defmethod indent-line ((mark right-sticky-mark) indentation tab-width) (indent-line* mark indentation tab-width nil)) (defgeneric delete-indentation (syntax mark) (:documentation "Delete all indentation in the line of `mark' with the whitespace rules of `syntax'. The default method just removes leading whitespace characters.")) (defmethod delete-indentation ((syntax syntax) (mark mark)) (let ((working-mark (clone-mark mark))) (beginning-of-line working-mark) (let ((end-offset (loop for offset from (offset working-mark) below (size (current-buffer)) for buffer-object = (buffer-object (current-buffer) offset) until (char= buffer-object #\Newline) unless (whitespacep syntax buffer-object) return offset))) (when end-offset (delete-region working-mark end-offset))))) (defgeneric join-line (syntax mark) (:documentation "Join the line that `mark' is in to the previous line, and remove whitespace objects at the join point. `Syntax' is used for judging what a whitespace character is.")) (defmethod join-line ((syntax syntax) (mark mark)) (beginning-of-line mark) (unless (beginning-of-buffer-p mark) (delete-range mark -1) (loop until (end-of-buffer-p mark) while (whitespacep syntax (object-after mark)) do (delete-range mark 1)) (loop until (beginning-of-buffer-p mark) while (whitespacep syntax (object-before mark)) do (delete-range mark -1)) (when (and (not (beginning-of-buffer-p mark)) (constituentp (object-before mark))) (insert-object mark #\Space)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Syntax handling (defgeneric set-syntax (view syntax) (:documentation "Set the syntax for the provided view to the specified syntax. `syntax' may be a string containing the name of a known syntax.")) (defmethod set-syntax ((view drei-syntax-view) (syntax syntax)) (setf (syntax view) syntax)) (defmethod set-syntax ((view drei-syntax-view) (syntax symbol)) (set-syntax view (make-syntax-for-view view syntax))) (defmethod set-syntax ((view drei-syntax-view) (syntax class)) (set-syntax view (make-syntax-for-view view syntax))) (defmethod set-syntax ((view drei-syntax-view) (syntax string)) (let ((syntax-class (syntax-from-name syntax))) (cond (syntax-class (set-syntax view (make-syntax-for-view view syntax-class))) (t (beep) (display-message "No such syntax: ~A." syntax))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Narrowing buffers (defgeneric invoke-with-narrowed-buffer (drei low-mark high-mark continuation &optional soft) (:documentation "Invoke `continuation' with the point and mark of `drei' narrowed to the region delimited by `low-mark' and `high-mark'. `low-mark' and `high-mark' may also be T or NIL, meaning \"beginning/end of buffer\" (as appropriate) and \"current position of point\", respectively.")) (defmethod invoke-with-narrowed-buffer ((drei drei) (low-mark left-sticky-mark) (high-mark right-sticky-mark) (continuation function) &optional soft) ;; Excessive protection, because ending up with narrowed marks is no ;; fun. (when soft (dolist (mark (list (point (view drei)) (mark (view drei)))) (cond ((mark> low-mark mark) (setf (offset mark) (offset low-mark))) ((mark> mark high-mark) (setf (offset mark) (offset high-mark)))))) (narrow-mark (point (view drei)) low-mark high-mark) (unwind-protect (progn (narrow-mark (mark (view drei)) low-mark high-mark) (unwind-protect (funcall continuation) (unnarrow-mark (mark (view drei))))) (unnarrow-mark (point (view drei))))) (defmethod invoke-with-narrowed-buffer ((drei drei) (low-mark integer) (high-mark t) (continuation function) &optional soft) (let ((new-low-mark (clone-mark (point (view drei)) :left))) (setf (offset new-low-mark) low-mark) (invoke-with-narrowed-buffer drei new-low-mark high-mark continuation soft))) (defmethod invoke-with-narrowed-buffer ((drei drei) (low-mark left-sticky-mark) (high-mark integer) (continuation function) &optional soft) (let ((new-high-mark (clone-mark (point (view drei)) :right))) (setf (offset new-high-mark) high-mark) (invoke-with-narrowed-buffer drei low-mark new-high-mark continuation soft))) (defmethod invoke-with-narrowed-buffer ((drei drei) (low-mark (eql t)) (high-mark t) (continuation function) &optional soft) (let ((new-low-mark (clone-mark (point (view drei)) :left))) (beginning-of-buffer new-low-mark) (invoke-with-narrowed-buffer drei new-low-mark high-mark continuation soft))) (defmethod invoke-with-narrowed-buffer ((drei drei) (low-mark left-sticky-mark) (high-mark (eql t)) (continuation function) &optional soft) (let ((new-high-mark (clone-mark (point (view drei)) :right))) (end-of-buffer new-high-mark) (invoke-with-narrowed-buffer drei low-mark new-high-mark continuation soft))) (defmethod invoke-with-narrowed-buffer ((drei drei) (low-mark null) (high-mark t) (continuation function) &optional soft) (let ((new-low-mark (clone-mark (point (view drei)) :left))) (invoke-with-narrowed-buffer drei new-low-mark high-mark continuation soft))) (defmethod invoke-with-narrowed-buffer ((drei drei) (low-mark left-sticky-mark) (high-mark null) (continuation function) &optional soft) (let ((new-high-mark (clone-mark (point (view drei)) :right))) (invoke-with-narrowed-buffer drei low-mark new-high-mark continuation soft))) (defmacro with-narrowed-buffer ((drei low-limit high-limit &optional soft) &body body) "Evluate `body' with the point and mark of `drei' narrowed to the region delimited by `low-mark' and `high-mark', which may either be a left-sticky-mark and right-sticky mark (respectively) or two integer offsets. `low-mark' and `high-mark' may also be T or NIL, meaning \"beginning/end of buffer\" (as appropriate) and \"current position of point\", respectively. If `soft' is true, point and mark will be moved to be within the narrowed buffer, otherwise, this situation is an error." `(invoke-with-narrowed-buffer ,drei ,low-limit ,high-limit #'(lambda () ,@body) ,soft)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/drei.lisp0000644000175000017500000006432511345155772017522 0ustar pdmpdm;;; -*- Mode: Lisp; Package: DREI -*- ;;; (c) copyright 2005 by ;;; Robert Strandh (strandh@labri.fr) ;;; (c) copyright 2005 by ;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr) ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) ;;; (c) copyright 2006-2007 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; ;;; Drei is an editing substrate designed for use in CLIM, and used to ;;; implement text-editor gadgets and input-editing-streams in ;;; McCLIM. It is also used as the editor engine in Climacs, from ;;; which Drei was originally extracted. At it's base, Drei has a ;;; `drei' class that contains the buffer and some marks into the ;;; buffer - from this, we derive concrete Drei implementations that ;;; implement usage-dependent semantics for redisplay and input ;;; handling. The essense of Drei is that a set of protocols can be ;;; used to define editing commands and functionality that can be used ;;; in all Drei derivatives, from Climacs to the tiniest of ;;; input-fields, and hence make it as easy for the user (and hacker) ;;; to customize every text-editing task in the CLIM environment, as ;;; it is to customize Emacs. ;;; ;;; In this file, we wrap all the various bits and parts together and ;;; build the basic Drei primitives, such as the buffer and the ;;; abstract `drei' class. ;;; ;;; Officially, Drei stands for "Drei Replaces EINE's Inheritor", but ;;; there are alternatives: ;;; ;;; * Drei Reimplements Emacs Intelligently ;;; ;;; * Drei Reimplements Emacs' Internals ;;; ;;; * Drei Raises Engineer's Interest ;;; ;;; * Drei Revives Eremites' Interest ;;; ;;; * Drei Recursively Expands Itself ;;; ;;; * Drei Erhbar Emacs Ist (in-package :drei) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Convenience stuff. (defgeneric drei-instance-of (object) (:documentation "Return the Drei instance of `object'. For an editor frame, this would be the active editor instance. If `object' itself is a Drei instance, this function should just return `object'.")) (defun drei-instance (&optional (object *esa-instance*)) "Return the Drei instance of `object'. If `object' is not provided, the currently running Drei instance will be returned." (drei-instance-of object)) (defun (setf drei-instance) (new-instance &optional (object *esa-instance*)) (setf (drei-instance-of object) new-instance)) (defun current-view (&optional (object (drei-instance))) "Return the view of the provided object. If no object is provided, the currently running Drei instance will be used." (view object)) (defun (setf current-view) (new-view &optional (object (drei-instance))) (setf (view object) new-view)) (defun point (&optional (object (current-view))) "Return the point of the provided object. If no object is provided, the current view will be used." (point-of object)) (defun (setf point) (new-point object) (setf (point-of object) new-point)) (defgeneric point-of (object) (:documentation "Return the mark object that is the point of `object'. Some objects have their own points, for example Drei buffer-views and buffers.")) (defun mark (&optional (object (current-view))) "Return the mark of the provided object. If no object is provided, the current view will be used." (mark-of object)) (defun (setf mark) (new-mark object) (setf (mark-of object) new-mark)) (defgeneric mark-of (object) (:documentation "Return the mark object that is the mark of `object'. Some objects have their own points, for example Drei instances.")) (defun current-syntax () "Return the syntax of the current buffer." (syntax (current-view))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Isearch (defclass isearch-state () ((search-string :initarg :search-string :accessor search-string) (search-mark :initarg :search-mark :accessor search-mark) (search-forward-p :initarg :search-forward-p :accessor search-forward-p) (search-success-p :initarg :search-success-p :accessor search-success-p) (targets :initarg :targets :accessor targets ))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Query replace (defclass query-replace-state () ((string1 :initarg :string1 :accessor string1) (string2 :initarg :string2 :accessor string2) (targets :initarg :targets :accessor targets) (occurences :initform 0 :accessor occurrences))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Drei command tables. ;;; Commenting. (make-command-table 'comment-table :errorp nil) ;;; Deleting. (make-command-table 'deletion-table :errorp nil) ;;; Editing - making changes to a buffer. (make-command-table 'editing-table :errorp nil) ;;; Filling. (make-command-table 'fill-table :errorp nil) ;;; Dealing with charcase. (make-command-table 'case-table :errorp nil) ;;; Indentation. (make-command-table 'indent-table :errorp nil) ;;; Marking things. (make-command-table 'marking-table :errorp nil) ;;; Moving around. (make-command-table 'movement-table :errorp nil) ;;; Searching. (make-command-table 'search-table :errorp nil) ;;; Information about buffer contents. (make-command-table 'info-table :errorp nil) ;;; Self-insertion. (make-command-table 'self-insert-table :errorp nil) ;;; View stuff (scrolling, etc) (make-command-table 'view-table :errorp nil) ;;; Command table for concrete editor stuff. (define-syntax-command-table editor-table :errorp nil :inherit-from '(comment-table deletion-table editing-table case-table fill-table indent-table marking-table movement-table search-table info-table self-insert-table keyboard-macro-table) :menu '(("Commenting" :menu comment-table))) ;; Command table for commands that are only available when Drei is a ;; gadget. There is no pane-exclusive table because the Drei pane is ;; not meant to be used as-is, but is meant to be subclassed, so we do ;; not want to force users to work around too much default behavior. (make-command-table 'exclusive-gadget-table :errorp nil) ;; Command table for input-editor-only commands. (make-command-table 'exclusive-input-editor-table :errorp nil) (define-command (com-drei-extended-command :command-table exclusive-gadget-table) () "Prompt for a command name and arguments, then run it." (require-minibuffer) (let ((item (handler-case (accept `(command :command-table ,(command-table (drei-instance))) ;; this gets erased immediately anyway :prompt "" :prompt-mode :raw) ((or command-not-accessible command-not-present) () (beep) (display-message "No such command") (return-from com-drei-extended-command nil))))) (execute-drei-command (drei-instance) item))) (set-key 'com-drei-extended-command 'exclusive-gadget-table '((#\x :meta))) (defclass drei-command-table (standard-command-table) () (:documentation "This class is used to provide the kind of indirection we need to support syntax-specific command tables in Drei. Commands should *NOT* be added to it.")) (defmethod additional-command-tables append ((frame application-frame) (command-table syntax-command-table)) "This method allows users of Drei to extend syntaxes with new, app-specific commands, as long as they inherit from a Drei class and specialise a method for it." (additional-command-tables (drei-instance) command-table)) (defmethod command-table-inherit-from ((table drei-command-table)) (append (view-command-tables (current-view)) (additional-command-tables (drei-instance) table) (when (use-editor-commands-p (current-view)) '(editor-table)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; The basic Drei class. (defclass drei () ((%view :initarg :view :accessor view :documentation "The CLIM view that will be used whenever this Drei is being displayed. During redisplay, the `stream-default-view' of the output stream will be temporarily bound to this value.") (%previous-command :initform nil :accessor previous-command :documentation "The previous CLIM command executed by this Drei instance. May be NIL if no command has been executed.") (%editor-pane :reader editor-pane :initarg :editor-pane :type (or null clim-stream-pane) :initform nil :documentation "The stream or pane that the Drei instance will perform output to.") (%minibuffer :initform nil :accessor minibuffer :initarg :minibuffer :type (or minibuffer-pane pointer-documentation-pane null) :documentation "The minibuffer pane (or null) associated with the Drei instance. This may be NIL.") (%command-table :initform (make-instance 'drei-command-table :name 'drei-dispatching-table) :reader command-table :initarg :command-table :type standard-command-table :documentation "The command table used for looking up commands for the Drei instance. Has a sensible default, don't override it unless you know what you are doing.") (%cursors :accessor cursors :initform '() :documentation "A list of which cursors are associated with the Drei instance. During redisplay, `display-drei-view-cursor' is called on each element of this list.") (%point-cursor :accessor point-cursor :documentation "The cursor object that is considered the primary user-oriented cursor, most probably the cursor for the editor point. Note that this cursor is also in the cursors-list.") (%cursors-visible :accessor cursors-visible :initform t :initarg :cursors-visible :documentation "If true, the cursors of this Drei instance will be visible. If false, they will not.") (%isearch-mode :initform nil :accessor isearch-mode) (%isearch-states :initform '() :accessor isearch-states) (%isearch-previous-string :initform nil :accessor isearch-previous-string) (%query-replace-mode :initform nil :accessor query-replace-mode) (%query-replace-state :initform nil :accessor query-replace-state)) (:metaclass modual-class) (:default-initargs :active t :editable-p t) (:documentation "The abstract Drei class that maintains standard Drei editor state. It should not be directly instantiated, a subclass implementing specific behavior (a Drei variant) should be used instead.")) (defmethod active ((drei drei)) "Return true if `drei' is active. A drei instance is active if its view is active." (active (view drei))) (defmethod (setf active) (new-val (drei drei)) (setf (active (view drei)) new-val)) (defmethod (setf cursors-visible) :after (new-val (drei drei)) (dolist (cursor (cursors drei)) (setf (enabled cursor) new-val))) (defmethod available-modes append ((modual drei)) (available-modes (view modual))) (defmethod mode-applicable-p or ((modual drei) mode-name) (mode-applicable-p (view modual) mode-name)) (defmethod mode-enabled-p or ((modual drei) mode-name) (mode-enabled-p (view modual) mode-name)) (defmethod enable-mode ((modual drei) mode-name &rest initargs) (if (mode-applicable-p (view modual) mode-name) (apply #'enable-mode (view modual) mode-name initargs) (call-next-method))) (defmethod disable-mode ((modual drei) mode-name) (if (mode-applicable-p (view modual) mode-name) (disable-mode (view modual) mode-name) (call-next-method))) (defun add-view-cursors (drei) "Add the cursors desired by the Drei view to the editor-pane of the Drei instance." (setf (cursors drei) (nreverse (create-view-cursors (editor-pane drei) (view drei)))) (dolist (cursor (cursors drei)) (setf (enabled cursor) (cursors-visible drei))) ;; We define the point cursor to be the first point-cursor object ;; in the list of cursors. (setf (point-cursor drei) (find-if #'(lambda (cursor) (typep cursor 'point-cursor)) (cursors drei)))) (defmethod initialize-instance :after ((drei drei) &rest args &key view active single-line (editable-p t) no-cursors initial-contents) (declare (ignore args)) (unless view ; Unless a view object has been provided... ;; Create it with the provided initargs. (setf (view drei) (make-instance 'textual-drei-syntax-view :active active :single-line single-line :read-only (not editable-p) :no-cursors no-cursors :initial-contents initial-contents))) (add-view-cursors drei)) (defmethod (setf view) :after (new-val (drei drei)) ;; Delete the old cursors, then add the new ones, provided the ;; setting of the view is successful. (dolist (cursor (cursors drei)) (when (output-record-parent cursor) (delete-output-record cursor (output-record-parent cursor) nil))) (add-view-cursors drei) ;; Finally make sure it doesn't remember anything from a potential ;; traumatic past. (clear-redisplay-information new-val)) (defmethod esa-current-buffer ((drei drei)) (buffer (view drei))) (defmethod esa-current-window ((drei drei)) drei) (defmethod drei-instance-of ((object drei)) object) (defmethod print-object ((object drei) stream) (print-unreadable-object (object stream :type t :identity t) (format stream "~A" (type-of (view object))))) (defmethod command-for-unbound-gestures ((drei drei) gestures) (command-for-unbound-gestures (view drei) gestures)) ;; Main redisplay entry point. (defgeneric display-drei (drei &key redisplay-minibuffer) (:documentation "`Drei' must be an object of type `drei' and `frame' must be a CLIM frame containing the editor pane of `drei'. If you define a new subclass of `drei', you must define a method for this generic function. In most cases, methods defined on this function will merely be a trampoline to a function specific to the given Drei variant. If `redisplay-minibuffer' is true, also redisplay `*minibuffer*' if it is non-NIL.")) (define-condition no-available-minibuffer (user-condition-mixin error) ((%drei :reader drei :initarg :drei :initform (error "A drei instance must be provided") :documentation "The Drei instance that does not have an available minibuffer.")) (:documentation "This error is signalled when a command wants to use the minibuffer, but none is available.")) (defun no-available-minibuffer (drei-instance) "Signal an `no-available-minibuffer' error for `drei-instance'." (error 'no-available-minibuffer :drei drei-instance)) (defun require-minibuffer (&optional (drei-instance (drei-instance))) "Check that the provided Drei instance (defaulting to the one currently running) has an available minibuffer. If not, signal an error of type `no-available-minibuffer'." (unless *minibuffer* (no-available-minibuffer drei-instance))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Some standard building block machinery. (defgeneric handle-drei-condition (drei condition) (:documentation "When an unhandled condition that is a subtype of `user-condition-mixin' (and some other hardcoded condition types) is signalled during execution of a Drei command, this generic function will be called with the Drei instance as the first argument, and the condition as the second argument.")) (defmethod handle-drei-condition (drei (condition offset-before-beginning)) (beep) (display-message "Beginning of buffer")) (defmethod handle-drei-condition (drei (condition offset-after-end)) (beep) (display-message "End of buffer")) (defmethod handle-drei-condition (drei (condition motion-before-beginning)) (beep) (display-message "Beginning of buffer")) (defmethod handle-drei-condition (drei (condition motion-after-end)) (beep) (display-message "End of buffer")) (defmethod handle-drei-condition (drei (condition no-such-operation)) (beep) (display-message "Operation unavailable for syntax")) (defmethod handle-drei-condition (drei (condition buffer-read-only)) (beep) (display-message "Buffer is read only")) (defmethod handle-drei-condition (drei (condition user-condition-mixin)) (beep) (with-minibuffer-stream (minibuffer) (let ((*print-escape* nil)) (princ condition minibuffer)))) (defmacro handling-drei-conditions (&body body) "Evaluate `body' while handling Drei user notification signals. The handling consists of displaying their meaning to the user in the minibuffer. This is the macro that ensures conditions such as `motion-before-end' does not land the user in the debugger." ;; Perhaps a DREI-CONDITION class should be added so we could more ;; easily catch all these. `User-condition-mixin' isn't available ;; at, for example, the buffer level, after all. `(handler-case (progn ,@body) (user-condition-mixin (c) (handle-drei-condition (drei-instance) c)) (offset-before-beginning (c) (handle-drei-condition (drei-instance) c)) (offset-after-end (c) (handle-drei-condition (drei-instance) c)) (motion-before-beginning (c) (handle-drei-condition (drei-instance) c)) (motion-after-end (c) (handle-drei-condition (drei-instance) c)) (no-such-operation (c) (handle-drei-condition (drei-instance) c)))) (defun find-available-minibuffer (drei-instance) "Find a pane usable as the minibuffer for `drei-instance'. The default will be to use the minibuffer specified for `drei-instance' (if there is one), secondarily the value of `*minibuffer*' will be used. Thirdly, the value of `*pointer-documentation-output*' will be used. If the found panes are not available (for example, if they are the editor-panes of `drei-instance'), it is possible for this function to return NIL." (flet ((available-minibuffer-p (pane) (and (or (typep pane 'minibuffer-pane) (typep pane 'pointer-documentation-pane)) (not (eq pane (editor-pane drei-instance)))))) (find-if #'available-minibuffer-p (list (minibuffer drei-instance) *minibuffer* *pointer-documentation-output*)))) (defmacro with-bound-drei-special-variables ((drei-instance &key (kill-ring nil kill-ring-p) (minibuffer nil minibuffer-p) (command-parser nil command-parser-p) (partial-command-parser nil partial-command-parser-p) (previous-command nil previous-command-p) (prompt nil prompt-p)) &body body) "Evaluate `body' with a set of Drei special variables (`(drei-instance)', `*kill-ring*', `*minibuffer*', `*command-parser*', `*partial-command-parser*', `*previous-command*', `*extended-command-prompt*') bound to their proper values, taken from `drei-instance'. The keyword arguments can be used to provide forms that will be used to obtain values for the respective special variables, instead of finding their value in `drei-instance' or their existing binding. This macro binds all of the usual Drei special variables, but also some CLIM special variables needed for ESA-style command parsing." `(let* ((*esa-instance* ,drei-instance) (*kill-ring* ,(if kill-ring-p kill-ring '*kill-ring*)) (*minibuffer* ,(if minibuffer-p minibuffer `(find-available-minibuffer (drei-instance)))) (*command-parser* ,(if command-parser-p command-parser ''esa-command-parser)) (*partial-command-parser* ,(if partial-command-parser-p partial-command-parser ''esa-partial-command-parser)) (*previous-command* ,(if previous-command-p previous-command `(previous-command (drei-instance)))) (*extended-command-prompt* ,(if prompt-p prompt "Extended command: ")) (*standard-input* (or *minibuffer* *standard-input*))) ,@body)) (defgeneric invoke-performing-drei-operations (drei continuation &key with-undo redisplay) (:documentation "Invoke `continuation', setting up and performing the operations specified by the keyword arguments for the given Drei instance.")) (defmethod invoke-performing-drei-operations ((drei drei) (continuation function) &key with-undo (redisplay t)) (with-accessors ((buffer buffer)) (view drei) (with-undo ((when with-undo (list buffer))) (funcall continuation)) (unless with-undo (clear-undo-history buffer)) (when redisplay (etypecase drei (pane (redisplay-frame-pane *application-frame* drei)) (t (display-drei drei :redisplay-minibuffer t)))))) (defmacro performing-drei-operations ((drei &rest args &key with-undo (redisplay t)) &body body) "Provide various Drei maintenance services around the evaluation of `body'. This macro provides a convenient way to perform some operations on a Drei, and make sure that they are properly reflected in the undo tree, that the Drei is redisplayed, the syntax updated, etc. Exactly what is done can be controlled via the keyword arguments. Note that if `with-undo' is false, the *entire* undo history will be cleared after `body' has been evaluated. This macro expands into a call to `invoke-performing-drei-operations'." (declare (ignore with-undo redisplay)) `(invoke-performing-drei-operations ,drei (lambda () ,@body) ,@args)) (defmacro with-drei-options ((drei &key (syntax nil syntax-provided-p) keep-syntax) &body body) "Evaluate `body' with the Drei instance `drei' changed to reflect the given options. The Drei instance will revert to the original options after `body' has been evaluated." ;; Build a list consisting of lists of three elements, the first ;; element being how to save the old value, the second element being ;; how to set the new value, the third element being how to restore ;; the old value. (once-only (drei syntax) (let (triple-list) (when syntax-provided-p (push (list (unless keep-syntax `(old-syntax (syntax (view ,drei)))) `(progn (setf (syntax (view ,drei)) (etypecase ,syntax (string (make-syntax-for-view (view ,drei) (or (syntax-from-name ,syntax) (error "No such syntax: ~A" ,syntax)))) (symbol (make-syntax-for-view (view ,drei) ,syntax)) (syntax ,syntax)))) (unless keep-syntax `(progn (setf (syntax (view ,drei)) old-syntax)))) triple-list)) `(progn (check-type ,drei drei) (let ,(remove-if #'null (mapcar #'first triple-list)) ,@(remove-if #'null (mapcar #'second triple-list)) (unwind-protect (progn ,@body) ,@(remove-if #'null (mapcar #'third triple-list)))))))) (defgeneric invoke-accepting-from-user (drei continuation) (:documentation "Set up `drei' and the environment so that calls to `accept' will behave properly. Then call `continuation'.")) (defmethod invoke-accepting-from-user ((drei drei) (continuation function)) ;; By default, everything should work. (funcall continuation)) (defmacro accepting-from-user ((drei) &body body) "Modidfy `drei' and the environment so that calls to `accept' can be done to arbitrary streams from within `body'. Or, at least, make sure the Drei instance will not be a problem. When Drei calls a command, it will be wrapped in this macro, so it should be safe to use `accept' within Drei commands. This macro expands into a call to `invoke-accepting-from-user'." `(invoke-accepting-from-user ,drei #'(lambda () ,@body))) ;;; Plain `execute-frame-command' is not good enough for us. Our ;;; event-handler method uses this function to invoke commands. (defgeneric execute-drei-command (drei-instance command) (:documentation "Execute `command' for `drei'. This is the standard function for executing Drei commands - it will take care of reporting to the user if a condition is signalled, updating the syntax, setting the `previous-command' of `drei' and recording the operations performed by `command' for undo.")) (defmethod execute-drei-command ((drei drei) command) (performing-drei-operations (drei :redisplay nil :with-undo t) (handling-drei-conditions (apply (command-name command) (command-arguments command))) (setf (previous-command drei) command))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/basic-commands.lisp0000644000175000017500000005156211345155772021456 0ustar pdmpdm;;; -*- Mode: Lisp; Package: DREI-COMMANDS -*- ;;; (c) copyright 2004-2005 by ;;; Robert Strandh (strandh@labri.fr) ;;; (c) copyright 2004-2005 by ;;; Elliott Johnson (ejohnson@fasl.info) ;;; (c) copyright 2005 by ;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr) ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) ;;; (c) copyright 2006 by ;;; Taylor R. Campbell (campbell@mumble.net) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Definitions of basic commands that are necessary for DREI to be ;;; functional at all. (in-package :drei-commands) (defmacro handling-motion-limit-errors ((unit-plural &key (beep t) (display-message t)) &body body) "Evaluate body, if a `motion-limit-error' is signalled, beep if `beep' is true (the default), and display a message stating that there are no more `unit-plural's if `display-message' is true (the default)." `(handler-case (progn ,@body) (motion-limit-error () ,(when beep `(beep)) ,(when display-message `(display-message ,(concatenate 'string "No more " unit-plural)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Motion commands. ;;; See information in motion.lisp ;;; ;;; Given the general motion functions FORWARD- and ;;; BACKWARD-, ;;; ;;; (DEFINE-MOTION-COMMANDS ) ;;; ;;; defines the motion commands Forward and Backward in ;;; . The following keyword parameters are recognized: ;;; ;;; :NOUN ;;; Noun to use in the docstring: `Move point forward by one ;;; .' Default is the unit name, downcased. ;;; ;;; :PLURAL ;;; Plural form for the prompt, `Number of ', and the rest ;;; of the docstring; e.g.: `With a numeric argument N, move point ;;; forward by N .' (defmacro define-motion-commands (unit command-table &key noun plural) (labels ((concat (&rest strings) (apply #'concatenate 'STRING (mapcar #'string strings))) (symbol (&rest strings) (intern (apply #'concat strings)))) (let ((forward (symbol "FORWARD-" unit)) (backward (symbol "BACKWARD-" unit)) (com-forward (symbol "COM-FORWARD-" unit)) (com-backward (symbol "COM-BACKWARD-" unit)) (noun (or noun (string-downcase unit))) (plural (or plural (concat (string-downcase unit) "s")))) `(PROGN (DEFINE-COMMAND (,com-forward :NAME T :COMMAND-TABLE ,command-table) ((COUNT 'INTEGER :PROMPT ,(concat "Number of " plural) :default 1)) ,(concat "Move point forward by one " noun ". With a numeric argument N, move point forward by N " plural ". With a negative argument -N, move point backward by N " plural ".") (handling-motion-limit-errors (,plural) (,forward (point) (current-syntax) COUNT))) (DEFINE-COMMAND (,com-backward :NAME T :COMMAND-TABLE ,command-table) ((COUNT 'INTEGER :PROMPT ,(concat "Number of " plural) :default 1)) ,(concat "Move point backward by one " noun ". With a numeric argument N, move point backward by N " plural ". With a negative argument -N, move point forward by N " plural ".") (handling-motion-limit-errors (,plural) (,backward (point) (current-syntax) COUNT))))))) ;;; Manually define some commands (define-command (com-beginning-of-line :name t :command-table movement-table) () "Move point to the beginning of the current line." (beginning-of-line (point))) (define-command (com-end-of-line :name t :command-table movement-table) () "Move point to the end of the current line." (end-of-line (point))) ;; Object movement comands - defined specially because FORWARD-OBJECT ;; and BACKWARD-OBJECT is part of the buffer protocol, not the ;; high-level motion abstraction. (define-command (com-forward-object :name t :command-table movement-table) ((count 'integer :prompt "Number of objects" :default 1)) "Move point forward by one object. With a numeric argument N, move point forward by N objects. With a negative argument -N, move point backward by M objects." (handling-motion-limit-errors ("objects") (forward-object (point) count))) (define-command (com-backward-object :name t :command-table movement-table) ((count 'integer :prompt "number of objects" :default 1)) "Move point backward by one object. With a numeric argument N, move point backward by N objects. With a negative argument -N, move point forward by N objects." (handling-motion-limit-errors ("objects") (backward-object (point) count))) ;;; Autogenerate commands (define-motion-commands word movement-table) (define-motion-commands page movement-table) (define-motion-commands paragraph movement-table) (define-motion-commands sentence movement-table) ;;; Lines have goal-columns, so we have to define the commands ;;; manually. (define-command (com-forward-line :name t :command-table movement-table) ((count 'integer :prompt "number of lines" :default 1)) "move point forward by one line. with a numeric argument n, move point forward by n lines. with a negative argument -n, move point backward by n lines." (handling-motion-limit-errors ("lines") (unless (member (unlisted (previous-command (drei-instance))) '(com-forward-line com-backward-line)) (setf (goal-column (current-view)) (column-number (point)))) (forward-line (point) (current-syntax) count) (setf (column-number (point)) (goal-column (current-view))))) (define-command (com-backward-line :name t :command-table movement-table) ((count 'integer :prompt "number of lines" :default 1)) "move point backward by one line. with a numeric argument n, move point backward by n lines. with a negative argument -n, move point forward by n lines." (handling-motion-limit-errors ("lines") (unless (member (unlisted (previous-command (drei-instance))) '(com-forward-line com-backward-line)) (setf (goal-column (current-view)) (column-number (point)))) (backward-line (point) (current-syntax) count) (setf (column-number (point)) (goal-column (current-view))))) ;;; Bind gestures to commands (set-key `(com-forward-object ,*numeric-argument-marker*) 'movement-table '((#\f :control))) (set-key `(com-forward-object ,*numeric-argument-marker*) 'movement-table '((#+(or mcclim building-mcclim) :right #-(or mcclim building-mcclim) :right-arrow))) (set-key `(com-backward-object ,*numeric-argument-marker*) 'movement-table '((#\b :control))) (set-key `(com-backward-object ,*numeric-argument-marker*) 'movement-table '((#+(or mcclim building-mcclim) :left #-(or mcclim building-mcclim) :left-arrow))) (set-key `(com-forward-word ,*numeric-argument-marker*) 'movement-table '((#\f :meta))) (set-key `(com-forward-word ,*numeric-argument-marker*) 'movement-table '((#+(or mcclim building-mcclim) :right #-(or mcclim building-mcclim) :right-arrow :control))) (set-key `(com-backward-word ,*numeric-argument-marker*) 'movement-table '((#\b :meta))) (set-key `(com-backward-word ,*numeric-argument-marker*) 'movement-table '((#+(or mcclim building-mcclim) :left #-(or mcclim building-mcclim) :left-arrow :control))) (set-key `(com-forward-line ,*numeric-argument-marker*) 'movement-table '((#\n :control))) (set-key `(com-forward-line ,*numeric-argument-marker*) 'movement-table '((#+(or mcclim building-mcclim) :down #-(or mcclim building-mcclim) :down-arrow))) (set-key `(com-backward-line ,*numeric-argument-marker*) 'movement-table '((#\p :control))) (set-key `(com-backward-line ,*numeric-argument-marker*) 'movement-table '((#+(or mcclim building-mcclim) :up #-(or mcclim building-mcclim) :up-arrow))) (set-key 'com-beginning-of-line 'movement-table '((:home))) (set-key 'com-beginning-of-line 'movement-table '((#\a :control))) (set-key 'com-end-of-line 'movement-table '((#\e :control))) (set-key 'com-end-of-line 'movement-table '((:end))) (set-key `(com-forward-page ,*numeric-argument-marker*) 'movement-table '((#\x :control) (#\]))) (set-key `(com-backward-page ,*numeric-argument-marker*) 'movement-table '((#\x :control) (#\[))) (set-key `(com-backward-paragraph ,*numeric-argument-marker*) 'movement-table '((#\{ :meta))) (set-key `(com-backward-paragraph ,*numeric-argument-marker*) 'movement-table '((#+(or mcclim building-mcclim) :up #-(or mcclim building-mcclim) :up-arrow :control))) (set-key `(com-forward-paragraph ,*numeric-argument-marker*) 'movement-table '((#\} :meta))) (set-key `(com-forward-paragraph ,*numeric-argument-marker*) 'movement-table '((#+(or mcclim building-mcclim) :down #-(or mcclim building-mcclim) :down-arrow :control))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Editing commands. ;;; ;;; Commands for deleting, killing and moving stuff See information in ;;; motion.lisp ;;; ;;; A deletion command is a command named Kill , Backward Kill ;;; , Delete or Backward Delete . corresponding to ;;; the editing functions FORWARD-KILL-, BACKWARD-KILL-, ;;; FORWARD-DELETE- and BACKWARD-DELETE- respectively ;;; (note that the "forward" prefix is gone in the command name). ;;; ;;; An editing command is a command named Transpose s. ;;; ;;; This file also holds command definitions for other functions ;;; defined in the DREI-EDITING package. (defmacro define-deletion-commands (unit command-table &key noun plural) (labels ((concat (&rest strings) (apply #'concatenate 'STRING (mapcar #'string strings))) (symbol (&rest strings) (intern (apply #'concat strings))) (try-to-find (&rest strings) (find-symbol (apply #'concat (mapcar #'string-upcase (mapcar #'string strings)))))) (let ((forward-kill (try-to-find "FORWARD-KILL-" unit)) (backward-kill (try-to-find "BACKWARD-KILL-" unit)) (forward-delete (try-to-find "FORWARD-DELETE-" unit)) (backward-delete (try-to-find "BACKWARD-DELETE-" unit)) (com-kill (symbol "COM-KILL-" unit)) (com-backward-kill (symbol "COM-BACKWARD-KILL-" unit)) (com-delete (symbol "COM-DELETE-" unit)) (com-backward-delete (symbol "COM-BACKWARD-DELETE-" unit)) (noun (or noun (string-downcase unit)))) (unless (and forward-kill backward-kill forward-delete backward-delete) (error "The unit ~A is not known." unit)) (let ((plural (or plural (concat (string-downcase unit) "s")))) `(progn ;; Kill Unit (define-command (,com-kill :name t :command-table ,command-table) ((count 'integer :prompt ,(concat "Number of " plural) :default 1)) ,(concat "Kill " plural " up to the next " noun " end. With a numeric argument, kill forward (backward if negative) that many " plural ". Successive kills append to the kill ring.") (handling-motion-limit-errors (,plural) (,forward-kill (point) (current-syntax) count (eq (command-name *previous-command*) ',com-kill)))) ;; Backward Kill Unit (define-command (,com-backward-kill :name t :command-table ,command-table) ((count 'integer :prompt ,(concat "Number of " plural) :default 1)) ,(concat "Kill from point until the previous " noun " beginning. With a numeric argument, kill backward (forward, if negative) that many " plural ". Successive kills append to the kill ring.") (handling-motion-limit-errors (,plural) (,backward-kill (point) (current-syntax) count (eq (command-name *previous-command*) ',com-backward-kill)))) ;; Delete Unit (define-command (,com-delete :name t :command-table ,command-table) ((count 'integer :prompt ,(concat "Number of " plural) :default 1)) ,(concat "Delete from point until the next " noun " end. With a positive numeric argument, delete that many " plural " forward.") (handling-motion-limit-errors (,plural) (,backward-delete (point) (current-syntax) count))) ;; Backward Delete Unit (define-command (,com-backward-delete :name t :command-table ,command-table) ((count 'integer :prompt ,(concat "Number of " plural) :default 1)) ,(concat "Delete from point until the previous " noun " beginning. With a positive numeric argument, delete that many " plural " backward.") (handling-motion-limit-errors (,plural) (,backward-delete (point) (current-syntax) count)))))))) (defmacro define-editing-commands (unit command-table &key noun plural) (labels ((concat (&rest strings) (apply #'concatenate 'STRING (mapcar #'string strings))) (symbol (&rest strings) (intern (apply #'concat strings))) (try-to-find (&rest strings) (find-symbol (apply #'concat (mapcar #'string-upcase (mapcar #'string strings)))))) (let* ((plural (or plural (concat (string-downcase unit) "s"))) (upcase-plural (string-upcase plural)) (noun (or noun (string-downcase unit))) (transpose (try-to-find "TRANSPOSE-" upcase-plural)) (com-transpose (symbol "COM-TRANSPOSE-" upcase-plural))) (unless (and transpose) (error "The unit ~A is not known." unit)) `(progn ;; Transpose Units (define-command (,com-transpose :name t :command-table ,command-table) () ,(concat "Transpose the " plural " around point, leaving point at the end of them. With point in the whitespace between words, transpose the " plural " before and after point. With point inside a " noun ", transpose that " noun " with the next one. With point before the first " noun " of the buffer, transpose the first two " plural " of the buffer.") (handling-motion-limit-errors (,plural) (,transpose (point) (current-syntax)))))))) ;;; Some manually defined commands (define-command (com-transpose-objects :name t :command-table editing-table) () "Transpose the objects before and after point, advancing point. At the end of a line transpose the previous two objects without advancing point. At the beginning of the buffer do nothing. At the beginning of any line other than the first effectively move the first object of that line to the end of the previous line." (transpose-objects (point))) (define-command (com-delete-object :name t :command-table deletion-table) ((count 'integer :prompt "Number of Objects" :default 1) (killp 'boolean :prompt "Kill?" :default nil)) "Delete the object after point. With a numeric argument, kill that many objects after (or before, if negative) point." (handling-motion-limit-errors ("objects") (if killp (forward-kill-object (point) count) (forward-delete-object (point) count)))) (define-command (com-backward-delete-object :name t :command-table deletion-table) ((count 'integer :prompt "Number of Objects" :default 1) (killp 'boolean :prompt "Kill?" :default nil)) "Delete the object before point. With a numeric argument, kills that many objects before (or after, if negative) point." (handling-motion-limit-errors ("objects") (if killp (backward-kill-object (point) count #'error-limit-action) (backward-delete-object (point) count #'error-limit-action)))) ;; We require somewhat special behavior from Kill Line, so define a ;; new function and use that to implement the Kill Line command. (defun user-kill-line (mark &optional (count 1) (whole-lines-p nil) (concatenate-p nil)) (let ((start (offset mark))) (cond ((= 0 count) (beginning-of-line mark)) ((< count 0) (loop repeat (- count) until (beginning-of-buffer-p mark) do (beginning-of-line mark) until (beginning-of-buffer-p mark) do (backward-object mark))) ((or whole-lines-p (> count 1)) (loop repeat count until (end-of-buffer-p mark) do (end-of-line mark) until (end-of-buffer-p mark) do (forward-object mark))) (t (cond ((end-of-buffer-p mark) nil) ((end-of-line-p mark) (forward-object mark)) (t (end-of-line mark))))) (unless (mark= mark start) (if concatenate-p (kill-ring-concatenating-push *kill-ring* (region-to-sequence start mark)) (kill-ring-standard-push *kill-ring* (region-to-sequence start mark))) (delete-region start mark)))) (define-command (com-kill-line :name t :command-table deletion-table) ((numarg 'integer :prompt "Kill how many lines?" :default 1) (numargp 'boolean :prompt "Kill entire lines?" :default nil)) "Kill the objects on the current line after point. When at the end of a line, kill the #\\Newline. With a numeric argument of 0, kill the objects on the current line before point. With a non-zero numeric argument, kill that many lines forward (backward, if negative) from point. Successive kills append to the kill ring." (let* ((concatenate-p (eq (command-name *previous-command*) 'com-kill-line))) (user-kill-line (point) numarg numargp concatenate-p))) ;;; Autogenerate commands (define-deletion-commands word deletion-table) (define-editing-commands word editing-table) (define-editing-commands line editing-table) (define-deletion-commands definition deletion-table) (define-editing-commands definition editing-table) (define-deletion-commands paragraph deletion-table) (define-editing-commands paragraph editing-table) ;;; Bind gestures to commands (set-key `(com-kill-word ,*numeric-argument-marker*) 'deletion-table '((#\d :meta))) (set-key `(com-backward-kill-word ,*numeric-argument-marker*) 'deletion-table '((#\Backspace :meta))) (set-key 'com-transpose-words 'editing-table '((#\t :meta))) (set-key 'com-transpose-lines 'editing-table '((#\x :control) (#\t :control))) (set-key `(com-delete-object ,*numeric-argument-marker* ,*numeric-argument-marker*) 'deletion-table '(#\Rubout)) (set-key `(com-delete-object ,*numeric-argument-marker* ,*numeric-argument-marker*) 'deletion-table '((#\d :control))) (set-key `(com-backward-delete-object ,*numeric-argument-marker* ,*numeric-argument-marker*) 'deletion-table '(#\Backspace)) (set-key 'com-transpose-objects 'editing-table '((#\t :control))) (set-key `(com-kill-line ,*numeric-argument-marker* ,*numeric-argument-marker*) 'deletion-table '((#\k :control))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Self-insertion-commands. ;;; ;;; These are what do the basic keypress->character inserted in buffer ;;; mapping. (define-command com-self-insert ((count 'integer :default 1)) "Insert the gesture used to invoke this command into the current buffer `count' times. `Count' should get its value from the numeric arguments." (loop repeat count do (insert-character *current-gesture*))) (defmethod command-for-unbound-gestures ((view textual-drei-syntax-view) gestures) (when (and (= (length gestures) 1) (characterp (first gestures)) (graphic-char-p (first gestures))) `(com-self-insert ,*numeric-argument-marker*))) (set-key `(com-self-insert ,*numeric-argument-marker*) 'self-insert-table '((#\Newline))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/fundamental-syntax.lisp0000644000175000017500000000520211345155772022406 0ustar pdmpdm;;; -*- Mode: Lisp; Package: DREI-FUNDAMENTAL-SYNTAX -*- ;;; (c) copyright 2005 by ;;; Robert Strandh (strandh@labri.fr) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Syntax for unknown buffer contents. Parse contents into lines. (in-package :drei-fundamental-syntax) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Every syntax must have a command table. (define-syntax-command-table fundamental-table :errorp nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; The syntax object and misc stuff. (define-syntax fundamental-syntax (syntax) () (:command-table fundamental-table) (:name "Fundamental")) (setf *default-syntax* 'fundamental-syntax) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; update syntax (defmethod update-syntax values-max-min ((syntax fundamental-syntax) prefix-size suffix-size &optional begin end) (declare (ignore begin end)) ;; We do nothing. Technically, Fundamental syntax always parses the ;; entire buffer, though. (values 0 (size (buffer syntax)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Redisplay ;;; ;;; Just uses the default buffer-view redisplay behavior. (defmethod pump-state-for-offset-with-syntax ((view textual-drei-syntax-view) (syntax fundamental-syntax) (offset integer)) (buffer-view-pump-state-for-offset view offset)) (defmethod stroke-pump-with-syntax ((view textual-drei-syntax-view) (syntax fundamental-syntax) stroke pump-state) (buffer-view-stroke-pump view stroke pump-state)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; exploit the parse ;; do this better (defmethod syntax-line-indentation ((syntax fundamental-syntax) mark tab-width) 0) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/editing.lisp0000640000175000017500000003671410741375212020207 0ustar pdmpdm;;; -*- Mode: Lisp; Package: DREI-EDITING; -*- ;;; (c) copyright 2004-2005 by ;;; Robert Strandh (strandh@labri.fr) ;;; (c) copyright 2004-2005 by ;;; Elliott Johnson (ejohnson@fasl.info) ;;; (c) copyright 2005 by ;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr) ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Drei editing ;;; See information in motion.lisp ;;; ;;; An editing function is a function named FORWARD-- or ;;; BACKWARD--, or just - in the case where ;;; discering between forward and backward commands does not make ;;; sense (an example is TRANSPOSE-). ;;; ;;; A proper unit is a unit for which all the functions required by ;;; the motion protocol has been implemented, this can be trivially ;;; done by using the macro DREI-MOTION:DEFINE-MOTION-COMMANDS. ;;; ;;; Given a proper unit, ;;; ;;; (DEFINE-EDIT-FNS ) ;;; ;;; defines the editing functions FORWARD-DELETE-, ;;; BACKWARD-DELETE-, FORWARD-KILL-, BACKWARD-KILL- ;;; and TRANSPOSE-. ;;; ;;; This file also holds definitions for other miscellaneus ;;; editing-related functions. The definitions in this file should ;;; have to do with immediate editing, understood as insertion, ;;; deletion or movement of buffer contents. Transformation of buffer ;;; contents (such as converting the case of a region) should not be ;;; here. (in-package :drei-editing) (defmacro define-edit-fns (unit &key plural) (labels ((concat (&rest strings) (apply #'concatenate 'STRING (mapcar #'string strings))) (symbol (&rest strings) (intern (apply #'concat strings)))) (let* ((unit-name (string-downcase unit)) (plural (or plural (concat unit-name "s"))) (upper-plural (string-upcase plural)) (forward-delete (symbol "FORWARD-DELETE-" unit)) (backward-delete (symbol "BACKWARD-DELETE-" unit)) (forward-kill (symbol "FORWARD-KILL-" unit)) (backward-kill (symbol "BACKWARD-KILL-" unit)) (transpose (symbol "TRANSPOSE-" upper-plural)) (forward (find-symbol (concat "FORWARD-" (string-upcase unit)))) (backward (find-symbol (concat "BACKWARD-" (string-upcase unit))))) (unless (and forward backward) (error "The unit ~A is not known." unit)) `(progn (defgeneric ,forward-delete (mark syntax &optional count limit-action) (:documentation ,(concat "Delete COUNT " plural " beginning from MARK."))) (defmethod ,forward-delete (mark syntax &optional (count 1) (limit-action #'error-limit-action)) (let ((mark2 (clone-mark mark))) (when (,forward mark2 syntax count limit-action) (delete-region mark mark2) t))) (defmethod ,forward-delete :around (mark syntax &optional (count 1) (limit-action #'error-limit-action)) (cond ((minusp count) (,backward-delete mark syntax (- count) limit-action)) ((plusp count) (call-next-method)) (t t))) (defgeneric ,backward-delete (mark syntax &optional count limit-action) (:documentation ,(concat "Delete COUNT " plural " backwards beginning from MARK."))) (defmethod ,backward-delete (mark syntax &optional (count 1) (limit-action #'error-limit-action)) (let ((mark2 (clone-mark mark))) (when (,backward mark2 syntax count limit-action) (delete-region mark mark2) t))) (defmethod ,backward-delete :around (mark syntax &optional (count 1) (limit-action #'error-limit-action)) (cond ((minusp count) (,forward-delete mark syntax (- count) limit-action)) ((plusp count) (call-next-method)) (t t))) (defgeneric ,forward-kill (mark syntax &optional count concatenate-p limit-action) (:documentation ,(concat "Kill COUNT " plural " beginning from MARK."))) (defmethod ,forward-kill (mark syntax &optional (count 1) concatenate-p (limit-action #'error-limit-action)) (let ((start (offset mark))) (,forward mark syntax count limit-action) (unless (mark= mark start) (if concatenate-p (if (plusp count) (kill-ring-concatenating-push *kill-ring* (region-to-sequence start mark)) (kill-ring-reverse-concatenating-push *kill-ring* (region-to-sequence start mark))) (kill-ring-standard-push *kill-ring* (region-to-sequence start mark))) (delete-region start mark) t))) (defmethod ,forward-kill :around (mark syntax &optional (count 1) concatenate-p (limit-action #'error-limit-action)) (declare (ignore concatenate-p)) (cond ((minusp count) (,backward-kill mark syntax (- count) limit-action)) ((plusp count) (call-next-method)) (t t))) (defgeneric ,backward-kill (mark syntax &optional count concatenate-p limit-action) (:documentation ,(concat "Kill COUNT " plural " backwards beginning from MARK."))) (defmethod ,backward-kill (mark syntax &optional (count 1) concatenate-p (limit-action #'error-limit-action)) (let ((start (offset mark))) (,backward mark syntax count limit-action) (unless (mark= mark start) (if concatenate-p (if (plusp count) (kill-ring-concatenating-push *kill-ring* (region-to-sequence start mark)) (kill-ring-reverse-concatenating-push *kill-ring* (region-to-sequence start mark))) (kill-ring-standard-push *kill-ring* (region-to-sequence start mark))) (delete-region start mark) t))) (defmethod ,backward-kill :around (mark syntax &optional (count 1) concatenate-p (limit-action #'error-limit-action)) (declare (ignore concatenate-p)) (cond ((minusp count) (,forward-kill mark syntax (- count) limit-action)) ((plusp count) (call-next-method)) (t t))) (defgeneric ,transpose (mark syntax) (:documentation ,(concat "Transpose two " plural " at MARK."))) (defmethod ,transpose ((mark right-sticky-mark) syntax) (let ((start1 (clone-mark mark))) (,backward start1 syntax 1 nil) (let ((end1 (clone-mark start1))) (,forward end1 syntax 1 #'error-limit-action) (let ((start2 (clone-mark end1))) (,forward start2 syntax 1 #'error-limit-action) (let ((end2 (clone-mark start2))) (,backward start2 syntax 1 nil) (as-region (start1 end1) (as-region (start2 end2) (when (mark> start1 start2) (psetf start1 start2 end1 end2 start2 start1 end2 end1)) (if (mark> end1 start2) (error-limit-action mark (offset mark) 0 ,unit-name syntax) (let ((obj2 (extract-region start2 end2))) (insert-sequence start2 (extract-region start1 end1)) (insert-sequence start1 obj2) (setf (offset mark) (offset end2))))))))))) (defmethod ,transpose ((mark left-sticky-mark) syntax) (let ((start1 (clone-mark mark))) (,backward start1 syntax 1 nil) (let ((end1 (clone-mark start1))) (,forward end1 syntax 1 #'error-limit-action) (let ((start2 (clone-mark end1))) (,forward start2 syntax 1 #'error-limit-action) (let ((end2 (clone-mark start2))) (,backward start2 syntax 1 nil) (as-region (start1 end1) (as-region (start2 end2) (when (mark> start1 start2) (psetf start1 start2 end1 end2 start2 start1 end2 end1)) (if (mark> end1 start2) (error-limit-action mark (offset mark) 0 ,unit-name syntax) (let ((obj2 (extract-region start2 end2))) (insert-sequence start2 (extract-region start1 end1)) (insert-sequence start1 obj2) (setf (offset mark) (offset end2))))))))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Object editing (defun forward-delete-object (mark &optional (count 1) limit-action) "Kill `count' objects beginning from `mark'." (let ((offset (offset mark))) (handler-case (progn (forward-object mark count) (delete-region offset mark)) (invalid-motion () (when limit-action (funcall limit-action mark (offset mark) count "object" nil)))))) (defun backward-delete-object (mark &optional (count 1) limit-action) "Kill `count' objects backwards beginning from `mark'." (let ((offset (offset mark))) (handler-case (progn (backward-object mark count) (delete-region offset mark)) (invalid-motion () (when limit-action (funcall limit-action mark (offset mark) (- count) "object" nil)))))) (defun forward-kill-object (mark &optional (count 1) concatenate-p limit-action) "Kill `count' objects beginning from `mark'." (let ((start (offset mark))) (handler-case (progn (forward-object mark count) (if concatenate-p (if (plusp count) (kill-ring-concatenating-push *kill-ring* (region-to-sequence start mark)) (kill-ring-reverse-concatenating-push *kill-ring* (region-to-sequence start mark))) (kill-ring-standard-push *kill-ring* (region-to-sequence start mark))) (delete-region start mark)) (invalid-motion () (when limit-action (funcall limit-action mark (offset mark) (- count) "object" nil)))))) (defun backward-kill-object (mark &optional (count 1) concatenate-p limit-action) "Kill `count' objects backwards beginning from `mark'." (let ((start (offset mark))) (handler-case (progn (backward-object mark count) (if concatenate-p (if (plusp count) (kill-ring-concatenating-push *kill-ring* (region-to-sequence start mark)) (kill-ring-reverse-concatenating-push *kill-ring* (region-to-sequence start mark))) (kill-ring-standard-push *kill-ring* (region-to-sequence start mark))) (delete-region start mark)) (invalid-motion () (when limit-action (funcall limit-action mark (offset mark) (- count) "object" nil)))))) (defun transpose-objects (mark) "Transpose two objects at `mark'." (unless (beginning-of-buffer-p mark) (when (end-of-line-p mark) (backward-object mark)) (unless (beginning-of-buffer-p mark) (let ((object (object-after mark))) (delete-range mark) (backward-object mark) (insert-object mark object) (forward-object mark))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Line editing (define-edit-fns line) (define-edit-fns line-start) ;; Autogenerated TRANSPOSE-LINES is not good enough. (defmethod transpose-lines ((mark left-sticky-mark) syntax) (beginning-of-line mark) (unless (beginning-of-buffer-p mark) (backward-line mark syntax)) (let* ((bol (offset mark)) (eol (progn (end-of-line mark) (offset mark))) (line (buffer-sequence (buffer mark) bol eol))) (delete-region bol mark) ;; Remove newline at end of line as well. (unless (end-of-buffer-p mark) (delete-range mark)) (end-of-line mark) (forward-line mark syntax 0) (insert-sequence mark line) (insert-object mark #\Newline))) (defmethod transpose-lines ((mark right-sticky-mark) syntax) (beginning-of-line mark) (unless (beginning-of-buffer-p mark) (backward-line mark syntax)) (let* ((bol (offset mark)) (eol (progn (end-of-line mark) (offset mark))) (line (buffer-sequence (buffer mark) bol eol))) (delete-region bol mark) ;; Remove newline at end of line as well. (unless (end-of-buffer-p mark) (delete-range mark)) (end-of-line mark) (insert-object mark #\Newline) (forward-line mark syntax 0) (insert-sequence mark line))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Word editing (define-edit-fns word) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Page editing (define-edit-fns page) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Paragraph editing (define-edit-fns paragraph) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Sentence editing (define-edit-fns sentence) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Expression editing (define-edit-fns expression) (define-edit-fns definition) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; List editing (define-edit-fns list) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/misc-commands.lisp0000644000175000017500000000624411345155772021325 0ustar pdmpdm;;; -*- Mode: Lisp; Package: DREI-COMMANDS -*- ;;; (c) copyright 2004-2005 by ;;; Robert Strandh (strandh@labri.fr) ;;; (c) copyright 2004-2005 by ;;; Elliott Johnson (ejohnson@fasl.info) ;;; (c) copyright 2005 by ;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr) ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic@yahoo.com) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Miscellaneous commands for Drei (in-package :drei-commands) (define-command (com-eval-expression :name t :command-table editor-table) ((exp 'expression :prompt "Eval") (insertp 'boolean :prompt "Insert?" :default nil)) "Prompt for and evaluate a lisp expression. With a numeric argument inserts the result at point as a string; otherwise prints the result." (let* ((*package* (find-package :climacs-gui)) (values (multiple-value-list (handler-case (eval exp) (error (condition) (progn (beep) (display-message "~a" condition) (return-from com-eval-expression nil)))))) (result (format nil "~:[; No values~;~:*~{~S~^,~}~]" values))) (if insertp (insert-sequence (point) result) (display-message result)))) (define-command (com-count-lines-page :name t :command-table info-table) () "Print the number of lines in the current page. Also prints the number of lines before and after point (as '(b + a)')." (let* ((start (clone-mark (point))) (end (clone-mark (point)))) (backward-page start (current-syntax) 1 nil) (forward-page end (current-syntax) 1 nil) (let ((total (number-of-lines-in-region start end)) (before (number-of-lines-in-region start (point))) (after (number-of-lines-in-region (point) end))) (display-message "Page has ~A lines (~A + ~A)" (1+ total) before after)))) (define-command (com-count-lines-region :name t :command-table info-table) () "Print the number of lines in the region. Also prints the number of objects (as 'o character[s]')." (let* ((lines (number-of-lines-in-region (point) (mark))) (chars (abs (- (offset (point)) (offset (mark)))))) (display-message "Region has ~D line~:P, ~D character~:P." (1+ lines) chars))) (set-key `(com-eval-expression ,*unsupplied-argument-marker* ,*numeric-argument-marker*) 'editor-table '((#\: :meta))) (set-key 'com-count-lines-page 'info-table '((#\x :control) (#\l))) (set-key 'com-count-lines-region 'info-table '((#\= :meta))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Drei/rectangle.lisp0000640000175000017500000001445610741375213020530 0ustar pdmpdm;;; -*- Mode: Lisp; Package: DREI-CORE -*- ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Implementation of rectangle editing. (in-package :drei-core) (defvar *killed-rectangle* nil "The killed rectangle as a list of lines.") (defun map-rectangle-lines (view function start end) "Map over lines in rectangle, calling `function' for each line. The rectangle is defined by the marks `start' and `end'. For each line, `function' will be called with arguments of a mark situated at the beginning of the line, the starting column of the rectangle and the ending column of the rectangle. This function returns a list of the return values of `function'." (when (mark> start end) (rotatef start end)) (let ((startcol (column-number start)) (endcol (column-number end)) (mark (make-buffer-mark (buffer view) (offset start)))) (loop do (beginning-of-line mark) until (mark> mark end) collect (funcall function (clone-mark mark) startcol endcol) until (not (forward-line mark (syntax view) 1 nil))))) (defmacro with-bounding-marks (((start-mark end-mark) mark startcol endcol &key force-start force-end) &body body) "Evaluate `body' with `start-mark' and `end-mark' bound to marks delimiting the rectangle area. The rectangle area is defined as the part of the line that `mark' is situated in, that lies between the columns `startcol' and `endcol'. If `force-start' or `force-end' is non-NIL, the line will be padded with space characters in order to put `start-mark' or `end-mark' at their specified columns respectively." (once-only (mark startcol endcol) `(progn (let ((,mark ,mark) (,startcol ,startcol) (,endcol ,endcol)) (move-to-column ,mark ,startcol ,force-start) (let ((,start-mark (clone-mark ,mark))) (let ((,end-mark (clone-mark ,mark))) (move-to-column ,end-mark ,endcol ,force-end) ,@body)))))) (defun extract-and-delete-rectangle-line (mark startcol endcol) "For the line that `mark' is in, delete and return the string between column `startcol' and `endcol'. If the string to be returned is not as wide as the rectangle, it will be right-padded with space characters." (with-bounding-marks ((start-mark end-mark) mark startcol endcol) (let ((str (concatenate 'string (buffer-substring (buffer mark) (offset start-mark) (offset end-mark)) (make-string (- (- endcol startcol) (- (column-number end-mark) (column-number start-mark))) :initial-element #\Space)))) (delete-range start-mark (- (offset end-mark) (offset start-mark))) str))) (defun delete-rectangle-line (mark startcol endcol) "For the line that `mark' is in, delete the string between column `startcol' and `endcol'." (with-bounding-marks ((start-mark end-mark) mark startcol endcol) (delete-range start-mark (- (offset end-mark) (offset start-mark))))) (defun open-rectangle-line (mark startcol endcol) "For the line that `mark' is in, move the string between column `startcol' and `endcol' to the right, replacing the area previously inhabited by it with space characters." (with-bounding-marks ((start-mark end-mark) mark startcol endcol) (unless (mark= start-mark end-mark) (insert-sequence start-mark (make-string (- endcol startcol) :initial-element #\Space))))) (defun clear-rectangle-line (mark startcol endcol) "For the line that `mark' is in, replace the string between column `startcol' and `endcol' with space characters." (with-bounding-marks ((start-mark end-mark) mark startcol endcol) (let ((size (- (offset end-mark) (offset start-mark)))) (delete-range start-mark size) (insert-sequence start-mark (make-string size :initial-element #\Space))))) (defun delete-rectangle-line-whitespace (mark startcol endcol) "For the line that `mark' is in, delete all whitespace characters from `startcol' up to the first non-whitespace character." (with-bounding-marks ((start-mark end-mark) mark startcol endcol) (let ((target-mark (clone-mark start-mark))) (re-search-forward target-mark "[^ ]") (when (= (line-number start-mark) (line-number target-mark)) (delete-range start-mark (- (offset target-mark) (offset start-mark) 1)))))) (defun replace-rectangle-line (mark startcol endcol string) "For the line that `mark' is in, replace the string between column `startcol' and `endcol' with `string'." (with-bounding-marks ((start-mark end-mark) mark startcol endcol :force-start t) (delete-range start-mark (- (offset end-mark) (offset start-mark))) (insert-sequence start-mark string))) (defun insert-in-rectangle-line (mark startcol endcol string) "For the line that `mark' is in, move the string between column `startcol' and `endcol' to the right, replacing the area previously inhabited by it with the contents of `string'." (with-bounding-marks ((start-mark end-mark) mark startcol endcol :force-start t) (insert-sequence start-mark string))) (defun insert-rectangle-at-mark (view mark rectangle) "Yank the killed rectangle, positioning the upper left corner at current point." (let ((insert-column (column-number mark))) (dolist (line rectangle) (move-to-column mark insert-column t) (insert-sequence mark line) (unless (forward-line mark (syntax view) 1 nil) (open-line mark) (forward-object mark))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/0000755000175000017500000000000011347763412015712 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/0000755000175000017500000000000011347763424017502 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/listener.lisp0000644000175000017500000001771511345155772022232 0ustar pdmpdm ;;; This is a lisp listener. ;;; (C) Copyright 2003 by Andy Hefner (hefner1@umbc.edu) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-listener) ;;; Listener view ;;; ;;; FIXME: this TEXTUAL-VIEW thing is a lie: we can draw graphics. ;;; However, all the various presentation methods around the world are ;;; specialized on textual view, and it sucks to have to reimplement ;;; them all. (defclass listener-view (textual-view) ()) (defclass listener-pointer-documentation-view (listener-view pointer-documentation-view) ()) (defparameter +listener-view+ (make-instance 'listener-view)) (defparameter +listener-pointer-documentation-view+ (make-instance 'listener-pointer-documentation-view)) (define-presentation-method present :around ((object sequence) (type sequence) stream (view listener-view) &key acceptably for-context-type) (present object 'expression :stream stream :view view :acceptably acceptably :for-context-type for-context-type)) (define-presentation-method accept :around ((type sequence) stream (view listener-view) &key default default-type) (declare (ignorable default default-type)) ;; oh, my word. although TYPE here might look like it's bound to ;; the presentation type itself, in fact it is bound to the ;; parameter of the SEQUENCE presentation type. We need the ;; presentation type itself, so we reconstruct it. (let ((ptype (list 'sequence type))) (let* ((token (read-token stream)) (result (handler-case (read-from-string token) (error (c) (declare (ignore c)) (simple-parse-error "Error parsing ~S for presentation type ~S" token ptype))))) (if (presentation-typep result ptype) (values result ptype) (input-not-of-required-type result ptype))))) ;;; Listener interactor stream. If only STREAM-PRESENT were ;;; specializable on the VIEW argument, this wouldn't be necessary. ;;; However, it isn't, so we have to play this game. We currently ;;; only use this to get single-box presentation highlighting. (defclass listener-interactor-pane (interactor-pane) ()) (defmethod stream-present :around ((stream listener-interactor-pane) object type &rest args &key (single-box nil sbp) &allow-other-keys) (declare (ignore single-box sbp)) (apply #'call-next-method stream object type :single-box t args) ;; we would do this, but CLIM:PRESENT calls STREAM-PRESENT with all ;; the keyword arguments explicitly. *sigh*. #+nil (if sbp (call-next-method) (apply #'call-next-method stream object type :single-box t args))) ;;; Listener application frame (define-application-frame listener (standard-application-frame) ((system-command-reader :accessor system-command-reader :initarg :system-command-reader :initform t)) (:panes (interactor-container (make-clim-stream-pane :type 'listener-interactor-pane :name 'interactor :scroll-bars t :default-view +listener-view+)) (doc :pointer-documentation :default-view +listener-pointer-documentation-view+) (wholine (make-pane 'wholine-pane :display-function 'display-wholine :scroll-bars nil :display-time :command-loop :end-of-line-action :allow))) (:top-level (default-frame-top-level :prompt 'print-listener-prompt)) (:command-table (listener :inherit-from (application-commands lisp-commands asdf-commands filesystem-commands show-commands) :menu (("Listener" :menu application-commands) ("Lisp" :menu lisp-commands) ("Filesystem" :menu filesystem-commands) ("Show" :menu show-commands)))) (:disabled-commands com-pop-directory com-drop-directory com-swap-directory) (:menu-bar t) (:layouts (default (vertically () interactor-container doc wholine)))) ;;; Package selection popup (define-listener-command (com-choose-package) () (let ((new-package (menu-choose (sort (mapcar (lambda (package) (cons (package-name package) package)) (list-all-packages)) #'string< :key #'car) :label "Choose Package"))) (when new-package (setf *package* new-package)))) (define-presentation-to-command-translator choose-package-translator (listener-current-package com-choose-package listener :echo nil :priority 100 ; These presentations appear in exactly one context, so give this a high priority. :documentation ((object stream) (declare (ignore object)) (format stream "Choose package"))) (current-package) nil) ;;; Lisp listener command loop (define-presentation-type empty-input ()) (define-presentation-method present (object (type empty-input) stream view &key &allow-other-keys) (princ "" stream)) ;;; Sneaky - we want to use :fix text for the command prompt, but ;;; use the default :sans-serif in accepting-values dialogs. Those ;;; are invokved by the :around method on r-f-c, so if we bind ;;; the text style here in the primary method, we're okay. (defmethod read-frame-command ((frame listener) &key (stream *standard-input*)) "Specialized for the listener, read a lisp form to eval, or a command." (multiple-value-bind (object type) (let ((*command-dispatchers* '(#\,))) (with-text-style (stream (make-text-style :fix :roman :normal)) (accept 'command-or-form :stream stream :prompt nil :default "hello" :default-type 'empty-input))) (cond ((presentation-subtypep type 'empty-input) ;; Do nothing. `(com-eval (values))) ((presentation-subtypep type 'command) object) (t `(com-eval ,object))))) (defun print-listener-prompt (stream frame) (declare (ignore frame)) (with-output-as-presentation (stream *package* 'package :single-box t) (print-package-name stream)) (princ "> " stream)) (defmethod frame-standard-output ((frame listener)) (get-frame-pane frame 'interactor)) (defun run-listener (&key (new-process nil) (width 790) (height 550) port frame-manager (process-name "Listener") (package :clim-user)) (let* ((fm (or frame-manager (find-frame-manager :port (or port (find-port))))) (frame (make-application-frame 'listener :frame-manager fm :width width :height height))) (flet ((run () (let ((*package* (find-package package))) (unwind-protect (run-frame-top-level frame) (disown-frame fm frame))))) (if new-process (values (clim-sys:make-process #'run :name process-name) frame) (run))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/file-types.lisp0000644000175000017500000005561011345155772022462 0ustar pdmpdm;;; File types (in-package :clim-listener) ; This implementation of MIME types is rather silly. ; I'm not sure that it's that important to do a better job ; at the moment. ;; TODO: ;; * Link mime-types with presentation-types ;; * ..then, tie them into presentation-type-of to make it automagic. ;; * Smarter detection of file types (defclass mime-media-type () ((media-type-name :reader media-type-name)) (:documentation "MIME top-level media type")) (defclass text (mime-media-type) ((media-type-name :initform 'text)) (:documentation "Textual information")) (defclass image (mime-media-type) ((media-type-name :initform 'image)) (:documentation "Image data")) (defclass audio (mime-media-type) ((media-type-name :initform 'audio)) (:documentation "Audio data")) (defclass video (mime-media-type) ((media-type-name :initform 'video)) (:documentation "Video data")) (defclass application (mime-media-type) ((media-type-name :initform 'application)) (:documentation "Application data")) (defclass inode (mime-media-type) ((media-type-name :initform 'inode)) (:documentation "Unix inode")) ;; Note that specific mime types should inherit mime-type as well as ;; a media-type class, preferably in that order. (defclass mime-type (mime-media-type) ((media-subtype :reader media-subtype-name) #+nil (extensions :initform nil :reader extensions)) (:documentation "A full specified MIME content-type")) ;; Default mime icons (defmethod icon-of ((obj mime-media-type)) *document-icon*) (defmethod icon-of ((obj text)) *document-icon*) (defmethod icon-of ((obj audio)) (standard-icon "audio.xpm")) (defmethod icon-of ((obj image)) (standard-icon "image.xpm")) (defmethod icon-of ((obj video)) (standard-icon "video.xpm")) (defmethod icon-of ((obj application)) (standard-icon "simple-object.xpm")) ;; Useful methods related to mime types #+IGNORE (defmethod mime-command-translator ((type T) pathname) nil) (defvar *extension-mapping* (make-hash-table :test #'equalp) "Mapping from file extension string to symbols naming mime type classes.") (defvar *icon-mapping* (make-hash-table :test #'eq) "Mapping from symbols naming mime type classes to icon patterns.") (defvar *view-command-mapping* (make-hash-table :test #'eq) "Mapping from symbols naming mime types to hash tables containing view-command information parsed from /etc/mime.types") (defun pathname-extension (pathname) "Returns the 'extension' of a file, whatever the hell that means." ;; FIXME: This is all wrong. As a call to pathname-type, this function ;; seems rather silly, but we can do better than this. (pathname-type pathname)) ;; A lot of magic needs to be done here to handle various things which ;; are not conveyed through file extensions. Most importantly, looking ;; at the executable bit to distinguish binaries from everything else. (defvar *magic-name-mappings* (make-hash-table :test #'equalp)) (defmacro defmagic (type &rest args) `(dolist (filename ',args) (setf (gethash filename *magic-name-mappings*) ',type))) (defun lookup-magic-name (pathname) (let* ((type (pathname-type pathname)) (name (pathname-name pathname)) (key (if type (concatenate 'string name "." type) ; Why did I do it this way? name)) (item (gethash key *magic-name-mappings*))) item)) (defun pathname-mime-type (pathname) (or (lookup-magic-name pathname) (gethash (pathname-extension pathname) *extension-mapping*))) (defmacro define-mime-type ((media-type subtype) &rest options) ; XXX Bad, probably I should put all the symbols in one MIME package or something. ; the CLIM-LISTENER package will do for now. (let ((full-type (intern (concatenate 'string (symbol-name media-type) "/" (symbol-name subtype)) (find-package :clim-listener) ))) ;FIXME `(progn (assert (find-class ',media-type nil)) (defclass ,full-type (mime-type ,media-type) ((media-subtype :initform ',subtype))) ,@(mapcar (lambda (opt) (case (first opt) (:extensions `(dolist (ext ',(rest opt)) (setf (gethash ext *extension-mapping*) ',full-type))) (:names `(defmagic ,full-type ,@(rest opt))) (:icon `(setf (gethash ',full-type *icon-mapping*) ,(second opt))))) options) (clim-mop:finalize-inheritance (find-class ',full-type)) ))) ;; ICON-OF is measurably slow here in CMUCL. Interesting.. (defmethod icon-of ((pathname pathname)) (cond ((wild-pathname-p pathname) (standard-icon "wild.xpm")) ((not (probe-file pathname)) (standard-icon "invalid.xpm")) ((directoryp pathname) *folder-icon*) ;; FIXME: use inode mime types (t (let ((mime-class (find-class (pathname-mime-type pathname) nil))) (if mime-class (or (gethash (class-name mime-class) *icon-mapping*) (icon-of (clim-mop:class-prototype (find-class (pathname-mime-type pathname) nil)))) *document-icon*))))) (defmethod icon-of ((obj mime-type)) ; (or (gethash (class-name (class-of obj)) *icon-mapping*) ; (call-next-method))) (let ((cpl (clim-mop:class-precedence-list (class-of obj)))) (dolist (class cpl) (let ((icon (gethash (class-name class) *icon-mapping*))) (when icon (return-from icon-of icon))))) (call-next-method)) ;; Some predefined MIME types ;; Don't need to do too much here, most of them will be grabbed from ;; the /etc/mime.types file. (define-mime-type (text plain) (:extensions "txt" "text") (:icon (standard-icon "text.xpm"))) (define-mime-type (text x-makefile) (:names "Makefile")) (define-mime-type (text x-lisp-source) (:extensions "lisp") (:icon (standard-icon "lambda.xpm"))) (define-mime-type (text x-csrc) (:extensions "c") (:icon (standard-icon "c.xpm"))) (define-mime-type (text x-chdr) (:extensions "h") (:icon (standard-icon "h.xpm"))) (define-mime-type (text x-lisp-system) (:extensions "system" "asd") (:names "system.lisp" "defsystem.lisp") (:icon (standard-icon "design.xpm"))) (define-mime-type (application x-lisp-fasl) (:extensions "x86f" "amd64f" "sparcf" "sparc64f" "hpf" "hp64f" "lbytef" "fasl" "ibin" "dfsl" "ufsl") ; MORE! (:icon (standard-icon "object.xpm"))) (define-mime-type (text x-shellscript) (:extensions "sh") (:icon (standard-icon "script.xpm"))) ;; Magic name mappings (very silly things) ;; It occurs to me for these types of mappings, a "prefix" mapping would be ;; vastly more useful than what I have here. That is, it would be more useful ;; to match patterns like Makefile*, INSTALL*, README*, etc. (defmagic text/plain "readme" "read.me" "copying" "copyright" "install") ;;; /etc/mime.types parser (defun read-slashified-line (stream &optional (accumulation nil)) (let ((line (read-line stream nil))) (cond ((null line) (values nil nil)) ((zerop (length line)) (values accumulation t)) ((and (null accumulation) ;; # Comment (char= (elt line 0) #\#)) (values nil t)) (t (if (char= #\\ (elt line (1- (length line)))) (read-slashified-line stream (concatenate 'string accumulation (subseq line 0 (1- (length line))))) (values (concatenate 'string accumulation line) t)))))) (defun read-the-lines (pathname) (let ((elements nil)) (with-open-file (in pathname) (loop (multiple-value-bind (val more-input) (read-slashified-line in) (unless more-input (return-from read-the-lines elements)) (when val (push val elements))))))) (defun skip-whitespace (string &optional (start 0) end) (when start (or (position-if (lambda (c) (and (graphic-char-p c) (not (char= c #\space)))) string :start start :end end) end))) (defun file-char-p (char) (and (graphic-char-p char) (not (char= char #\space)))) (defun read-extensions (string &optional (start 0)) (setf start (skip-whitespace string start)) (when start (let ((pos (or (position-if-not #'file-char-p string :start start) (length string)))) (cons (subseq string start pos) (read-extensions string pos))))) (defun read-mime-type (string &optional (start 0)) (declare (optimize (debug 3))) (setf start (skip-whitespace string start)) (let* ((pos-slash (position #\/ string :test #'char= :start start)) (pos-end (position-if (lambda (c) (member c '(#\space #\tab))) string :start (if pos-slash (1+ pos-slash) start))) (media-type (string-upcase (subseq string start pos-slash))) (media-type-sym (intern media-type (find-package :clim-listener))) (subtype (when pos-slash (string-upcase (subseq string (1+ pos-slash) pos-end)))) (full-symbol (intern (if subtype (concatenate 'string media-type "/" subtype) media-type) (find-package :clim-listener)))) (values media-type-sym full-symbol (when subtype (intern subtype)) pos-end))) ;;; PARSE-NETSCAPE-MIME-TYPE and PARSE-STANDARD-MIME-TYPE return the various ;;; properties of each type in a hash table. The primary ones of concern are ;;; :TYPE, :MEDIA-TYPE, :EXTS, and :DESC. ;; Is this even a standard format to put things in? The only thing I've seen ;; make records of this type is Netscape, and things like Pine claim they ;; don't parse it at all. Stupid netscape. ; * hefner cringes. (defun parse-netscrapings (table string &optional (start 0)) "Recursively parse FOO=BAR pairs, returning the result in a hash table." (setf start (skip-whitespace string start)) (when start (let ((split-pos (position #\= string :start start))) (when split-pos (let* ((foo (subseq string start split-pos)) (pos (skip-whitespace string (1+ split-pos)))) ; (format t "~%***** foo=~A~%" foo) (when pos (let* ((end (or (if (eql (elt string pos) #\") (1+ (position-if (lambda (c) (char= c #\")) string :start (1+ pos))) (position-if (lambda (c) (member c '(#\space #\tab))) string :start pos)) (length string))) (real-start (if (eql #\" (elt string pos)) (1+ pos) pos)) (real-end (if (eql #\" (elt string (1- end))) (1- end) end)) (bar (subseq string real-start real-end)) (keysym (intern (string-upcase foo) (find-package :keyword))) (value (case keysym (:type (nth-value 1 (read-mime-type bar))) (:exts (read-extensions bar)) (otherwise bar)))) (when (eq keysym :type) (setf (gethash :subtype table) (nth-value 2 (read-mime-type bar))) (setf (gethash :media-type table) (read-mime-type bar))) ; (format t "~&~W => ~W~%" foo bar) (setf (gethash keysym table) value) (parse-netscrapings table string end) )))))) table) (defun parse-netscape-mime-type (elt) "Parse a mimetype of the form 'type=foo/bar desc=baz...'" (let ((table (make-hash-table :size 4))) (parse-netscrapings table elt) table)) (defun parse-standard-mime-type (elt) "Parse a 'normal' mime.types entry" (let ((table (make-hash-table :size 4))) (multiple-value-bind (media-type type subtype pos) (read-mime-type elt) (setf (gethash :media-type table) media-type) (setf (gethash :type table) type) (setf (gethash :subtype table) subtype) (setf (gethash :exts table) (read-extensions elt pos)) table))) (defun parse-mt-elt (elt) (if (search "type=" elt) (parse-netscape-mime-type elt) (parse-standard-mime-type elt))) (defun process-mime-type (elt) (when elt (if (find-class (gethash :media-type elt) nil) (let ((media-type (gethash :media-type elt)) (subtype (gethash :subtype elt)) (exts (gethash :exts elt))) (eval `(define-mime-type (,media-type ,subtype) (:extensions ,@exts)))) #+nil(format t "Ignoring ~W, unknown media type.~%" (gethash :type elt))))) (defun parse-mime-types-file (pathname) (mapcar (lambda (x) (process-mime-type (parse-mt-elt x))) (read-the-lines pathname))) ;;; Mailcap parser (RFC 1524) ;Location of the Mailcap File(s) ; For UNIX, a path search of mailcap files is specified. The default ; path search is specified as including at least the following: ; $HOME/.mailcap:/etc/mailcap:/usr/etc/mailcap:/usr/local/etc/mailcap ;Semantics of executable commands ; Several portions of a mailcap entry specify commands to be executed. ; In particular, the mandatory second fie ld, the view-command, takes a ; command to be executed, as do the optional print, edit, test, and ; compose fields. ; On a UNIX system, such commands will each be a full shell command ; line, including the path name for a program and its arguments. ; (Because of differences in shells and the implementation and behavior ; of the same shell from one system to another, it is specified that ; the command line be intended as input to the Bourne shell, i.e., that ; it is implicitly preceded by "/bin/sh -c " on the command line.) ; The two characters "%s", if used, will be replaced by the name of a ; file for the actual mail body data. [snip] ; Furthermore, any occurrence of "%t" will be replaced by the content- ; type and subtype specification. (That is, if the content-type is ; "text/plain", then %t will be replaced by "text/plain".) ; Semantics of the "test" field... ignoring this for now. ; > Don't see any of them on my system that aren't just tests against ; > the DISPLAY variable, anyway, and we know that's set. ; > Will fix later.. ;;; This is not a mail client, so I assume I don't need most of this stuff. (defparameter *whitespace* '(#\Space #\Tab #\Newline #\Return)) #+nil ;; Oops, forgot to parse quote characters. (defun read-mailcap-field (string &optional (start 0)) "Seperates a field of a mailcap entry, delimited by either semicolons or the end of the string. Returns two values, the string contents of the field, and the new position index (or nil if out of input)." (if (and start (< start (length string))) (let ((end-pos (or (position #\; string :start start) (length string)))) (values (string-trim *whitespace* (subseq string start end-pos)) (1+ end-pos))) (values nil nil))) (defun read-mailcap-field (string &optional (start 0)) (let ((index start) (chars nil)) (loop named poop while (< index (length string)) do (let ((c (elt string index))) (cond ((eql c #\\) ; quoted character? (when (< index (1- (length string))) (push (elt string (incf index)) chars))) ((eql c #\;) (return-from poop chars)) (t (push c chars))) (incf index))) (values (string-trim *whitespace* (concatenate 'string (nreverse chars))) (if (>= (1+ index) (length string)) nil (1+ index))))) (defun parse-mt-field (string) (let* ((sep-pos (position #\= string)) (field-name (subseq string 0 (or sep-pos (length string))))) (values (intern (string-upcase field-name) (find-package :keyword)) (ignore-errors (or (when sep-pos (subseq string (1+ sep-pos))) t))))) (defun parse-mailcap-entry (line) "Parses a line of the mailcap file, returning either nil or the properties of the type in a hash table." (let ((table (make-hash-table :size 8)) (foo nil)) ; <- position after reading required fields (when ;; First read the required fields. (with-simple-restart (skip "Skip mailcap entry \"~A\"" (string-trim #(#\Space #\Tab) line)) (multiple-value-bind (text pos) (read-mailcap-field line) (and pos (multiple-value-bind (media-type type subtype) (read-mime-type text) (multiple-value-bind (view-command pos) (read-mailcap-field line pos) (setf foo pos) (setf (gethash :type table) type) (setf (gethash :subtype table) subtype) (setf (gethash :media-type table) media-type) ;; Note the return value: (setf (gethash :view-command table) view-command)))))) ;; If the required fields were read successfully, read ;; the options into the hash table. (loop (when (null foo) (return-from parse-mailcap-entry table)) (multiple-value-bind (text pos) (ignore-errors (read-mailcap-field line foo)) (setf foo pos) (when text (multiple-value-bind (field value) (parse-mt-field text) (when field (setf (gethash field table) value))))) )))) (defun process-mailcap-entry (entry) (when entry (setf (gethash (gethash :type entry) *view-command-mapping*) entry))) (defun parse-mailcap-file (pathname) (mapcar (lambda (x) (process-mailcap-entry (parse-mailcap-entry x))) (read-the-lines pathname))) ;;; These functions invoke the parsing of the mime.types and mailcap files ;; Search paths - in addition to these, the user's home directory will ;; be checked. (defparameter *mime.types-search-path* '(#p"/etc/mime.types" #p"/usr/etc/mime.types" #p"/usr/local/etc/mime.types")) (defparameter *mailcap-search-path* '(#p"/etc/mailcap" #p"/usr/etc/mailcap" #p"/usr/local/etc/mailcap")) (defun load-mime-types () (let ((search-path (cons (merge-pathnames #P".mime.types" (user-homedir-pathname)) *mime.types-search-path*))) (dolist (path (reverse search-path)) (when (probe-file path) (format t "Loading mime types from ~A~%" path) (parse-mime-types-file path))))) (defun load-mailcaps () (let ((search-path (cons (merge-pathnames #P".mailcap" (user-homedir-pathname)) *mailcap-search-path*))) (dolist (path (reverse search-path)) (when (probe-file path) (format t "Loading mailcap from ~A~%" path) (parse-mailcap-file path))))) ;; Running external viewers.. ;; FIXME: I don't have the quoting for things quite right, I can't ;; seem to open any file with quotes in the name. (how embarassing!) (defun quote-shell-characters (string) (let ((shell-chars '(#\` #\$ #\\ #\" #\'))) (with-output-to-string (out) (with-input-from-string (in string) (loop for c = (read-char in nil) while c do (when (member c shell-chars) (write-char #\\ out)) (write-char c out)))))) (defun translate-uri-pathspec-character (char) (if (or (alphanumericp char) (find char ";@&=+$,-_.!~*'()")) char (format nil "%~2,'0X" (char-code char)))) (defun encode-uri-path-element (string) (with-output-to-string (out) (map nil (lambda (char) (write-string (string (translate-uri-pathspec-character char)) out)) string))) (defgeneric concatenate-uri-directory-elements (type elements)) (defmethod concatenate-uri-directory-elements ((type (eql :absolute)) elements) (apply #'concatenate 'string (list #\/) (mapcan (lambda (x) (list (encode-uri-path-element x) "/")) elements))) ;; Relative pathnames? Probably for most purposes this should not ever get ;; called with one, as it makes litte sense. (defun translate-uri-pathname-directory (pathname) (let ((dirs (pathname-directory pathname))) (if (not (listp dirs)) (progn (warn "Don't know how to convert ~A to a URI." pathname) "") (ignore-errors (concatenate-uri-directory-elements (first dirs) (rest dirs)))))) (defun translate-uri-pathname-name (pathname) (encode-uri-path-element (namestring (make-pathname :name (pathname-name pathname) :type (pathname-type pathname) :version (pathname-version pathname))))) (defun pathname-to-uri-string (pathname) (format nil "file://~A~A" (translate-uri-pathname-directory pathname) (translate-uri-pathname-name pathname))) (defun gen-view-command-line (spec pathname) (with-output-to-string (out) (with-input-from-string (in (gethash :view-command spec)) (loop for c = (read-char in nil) while c do (if (char= c #\%) (let ((d (read-char in nil))) (cond ((eql d #\s) (princ (quote-shell-characters (namestring (truename pathname))) out)) ((eql d #\t) (princ (gethash :type spec) out)) ((eql d #\u) (princ (pathname-to-uri-string pathname) out)) (t (format *trace-output* "Ignoring unknown syntax ~W" d)))) (write-char c out)))))) (defun find-viewspec (pathname) (let* ((type (pathname-mime-type pathname)) (def (gethash type *view-command-mapping*))) (when (and def (probe-file pathname) (gethash :view-command def) (not (gethash :needsterminal def))) (values `(com-background-run "/bin/sh" ("-c" ,(gen-view-command-line def pathname))) (format nil "Open using ~A" (subseq (gethash :view-command def) 0 (position #\Space (gethash :view-command def)))) (gen-view-command-line def pathname))))) (defun run-view-command (pathname) (let* ((type (pathname-mime-type pathname)) (def (gethash type *view-command-mapping*))) (when def (let* ((view-command (gethash :view-command def)) (test (gethash :test def)) (needsterminal (gethash :needsterminal def))) (if needsterminal (format t "Sorry, the viewer app needs a terminal (fixme!)~%") (progn (when test (format *trace-output* "Sorry, ignoring TEST option ~W for ~A viewer " test type)) (if view-command (run-program "/bin/sh" `("-c" ,(gen-view-command-line def pathname) "&")) (format t "~&No view-command!~%")))))))) (eval-when (:load-toplevel :execute) (load-mime-types) (load-mailcaps))cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/icons.lisp0000644000175000017500000000605511345155772021513 0ustar pdmpdm(in-package :clim-listener) ;;; (C) Copyright 2003 by Andy Hefner (hefner1@umbc.edu) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;; Icons for various things ;; Needs to have gilberth's XPM loader loaded first! ;; Some day, revamp icons so that ICON-OF gives you some wrapper that can ;; represent a set of icons, from which you can request one of a particular ;; size. For now, everything I use is 16x16. ;; This is a particularly silly idea, but ICON-OUTPUT-RECORD could be useful ;; for aligning images relative to the text baseline. ;; Ooops, icons.lisp gets left in the pathname, but that gets overridden anyway.. ;(defparameter *icon-path* (merge-pathnames #P"icons/" #.*compile-file-truename*)) (defmacro deficon (var pathname) `(eval-when (:load-toplevel :execute) (defparameter ,var (make-pattern-from-bitmap-file ,(merge-pathnames pathname *icon-path*) :format :xpm :port nil)))) (defvar *icon-cache* (make-hash-table :test #'equal)) (defun standard-icon (filename) "Loads an icon from the *icon-path*, caching it by name in *icon-cache*" (or (gethash filename *icon-cache*) (setf (gethash filename *icon-cache*) (make-pattern-from-bitmap-file (merge-pathnames (parse-namestring filename) *icon-path*) :format :xpm :port nil)))) ;; Don't particularly need these any more.. (deficon *folder-icon* #P"folder.xpm") (deficon *document-icon* #P"document.xpm") (deficon *object-icon* #P"simple-object.xpm") ;; Icon functions (defmethod icon-of ((object t)) *object-icon*) (defun draw-icon (stream pattern &key (extra-spacing 0) ) (let ((stream (if (eq stream t) *standard-output* stream))) (multiple-value-bind (x y) (stream-cursor-position stream) (draw-pattern* stream pattern x y) (stream-increment-cursor-position stream (+ (pattern-width pattern) extra-spacing) 0)))) (defun precache-icons () (let ((pathnames (remove-if #'directoryp (list-directory (gen-wild-pathname (strip-filespec *icon-path*)))))) (dolist (pn pathnames) (standard-icon (namestring (make-pathname :name (pathname-name pn) :type (pathname-type pn))))))) (eval-when (:load-toplevel :execute) (precache-icons)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/package.lisp0000644000175000017500000000063111345155772021765 0ustar pdmpdm;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- (in-package :cl-user) (defpackage "CLIM-LISTENER" (:use "CLIM" "CLIM-LISP" "CLIM-EXTENSIONS") (:export #:run-listener #:dev-commands)) (in-package :clim-listener) (eval-when (:load-toplevel) (defparameter *icon-path* (merge-pathnames #P"icons/" (load-time-value (or #.*compile-file-pathname* *load-pathname*))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/cmu-hacks.lisp0000600000175000017500000000725210423413301022220 0ustar pdmpdm;; Gilbert Baumann's hacks for using the CMUCL debugger within a CLIM stream. (in-package :climi) #+cmu19a (progn (setf (ext:package-definition-lock (find-package "DEBUG")) nil) (setf (ext:package-definition-lock (find-package "COMMON-LISP")) nil) (setf (ext:package-definition-lock (find-package "EXT")) nil)) ;; a patch (defmethod stream-listen ((stream standard-extended-input-stream)) (with-encapsulating-stream (estream stream) (loop for char = (read-gesture-or-reason estream :timeout 0 :peek-p t) do (if (read-result-p char) (loop-finish) (stream-read-gesture estream)) ; consume pointer gesture finally (return (characterp char))))) ;; a patch, not sure about this one as constructing an event seems wrong. (defmethod stream-unread-gesture ((stream standard-extended-input-stream) gesture) (with-encapsulating-stream (estream stream) (repush-gesture (if (characterp gesture) (make-instance 'key-press-event :modifier-state 0 :key-name gesture :key-character gesture :sheet estream :x 0 :y 0 :graft-x 0 :graft-y 0) gesture) (stream-input-buffer estream)))) (in-package :goatee) (defmethod lookup-gesture-command ((gesture key-press-event) table) (let ((modifier-state (logandc1 climi::+alt-key+ (event-modifier-state gesture)))) (cdr (assoc modifier-state (gethash (keyboard-event-character gesture) table nil))))) (in-package "DEBUG") (#+CMU19C ext:without-package-locks #-CMU19C progn (defun internal-debug () (let ((*in-the-debugger* t) (*read-suppress* nil)) (unless (typep *debug-condition* 'step-condition) (clear-input *debug-io*) (format *debug-io* "~2&Debug (type H for help)~2%")) (debug-loop) )) ;; (mp:without-scheduling (debug-loop)))) (defun invoke-debugger (condition) "The CMU Common Lisp debugger. Type h for help." (when *debugger-hook* (let ((hook *debugger-hook*) (*debugger-hook* nil)) (funcall hook condition hook))) (unix:unix-sigsetmask 0) (let* ((*debug-condition* condition) (*debug-restarts* (compute-restarts condition)) (*standard-input* *debug-io*) ;in case of setq (*standard-output* *debug-io*) ;'' '' '' '' (*error-output* *debug-io*) ;; Rebind some printer control variables. (kernel:*current-level* 0) (*print-readably* nil) (*read-eval* t)) (let ((*debugger-hook* (lambda (cond hook) (let ((*debugger-hook* nil) (*debug-io* sys:*tty*)) (invoke-debugger cond))))) (real-invoke-debugger condition)))) (defun debug-prompt () (let ((*standard-output* *debug-io*)) (progn (terpri) (prin1 (di:frame-number *current-frame*)) (dotimes (i *debug-command-level*) (princ "]")) (princ " ") (force-output)))) (defparameter *debug-prompt* #'debug-prompt "This is a function of no arguments that prints the debugger prompt on *debug-io*.") ) (in-package "LISP") (#+CMU19C ext:without-package-locks #-CMU19C progn (defun get-stream-command (stream) "This takes a stream and waits for text or a command to appear on it. If text appears before a command, this returns nil, and otherwise it returns a command." (let ((cmdp nil #+NIL (funcall (lisp-stream-misc stream) stream :get-command))) (cond (cmdp) ((listen stream) nil) (t ;; This waits for input and returns nil when it arrives. (unread-char (read-char stream) stream))))) ) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/README0000644000175000017500000001102411345155772020357 0ustar pdmpdmMcCLIM Lisp Listener Overview -------- The McCLIM Listener provides an interactive toplevel with full access to the graphical capabilities of CLIM and a set of built-in commands intended to be useful for lisp development and experimentation. Present features include: - Reading/evaluation of lisp expressions - Ability to run external programs, through the "Run" command or #! macro - Commands for inspecting CLOS classes (superclasses/subclasses, slots, etc.) - Navigation of the filesystem, including a directory stack - Launching of external programs sensitive to file type (determined by mailcap and mime.types files) Installation ------------ The clim-listener system is defined both by McCLIM's central system.lisp and the ASDF-ized version in mcclim.asd. It can be loaded in the same manner as the rest of McCLIM. For ASDF users, the following should work: * (asdf:operate 'asdf:load-op :clim-listener) Once loaded, you can run the listener using: * (clim-listener:run-listener) If you have a multithreaded lisp, you can start the listener in a separate thread, thereby leaving your main REPL available: * (clim-listener:run-listener :new-process t) Compatibility ------------- The Listener is developed using CMUCL 18e and recent versions of SBCL. It is known to work well on these platforms. It has also been reported to work on OpenMCL, Lispworks, and clisp. It has not been tested on ACL and will require a small amount of work due to the number of implementation-specific features used (MOP, pathnames, run-program, environment variables, etc). Usage ----- After starting the listener, a typical lisp prompt will be displayed, with the package name preceding the prompt. You may type lisp forms or commands to this prompt. The , (comma) character starts a command, every other input will be treated by the listener as a form to be evaluated. At the bottom of the window is a wholine which shows various things such as the username/hostname, package, current directory (*default-pathname-defaults*), the depth of the directory stack (if not empty), and the current memory usage. Some of these items will be sensitive to pointer gestures. Commands -------- The command "Help (with) Commands" will produce a list of available commands. General Commands - Help - Clear Output History - clears the screen - Exit Basic Lisp Commands - Apropos - Describe - Room - Trace - Untrace - Eval - Load File - Compile File - Compile and Load CLOS Commands - Show Class Superclasses - Show Class Subclasses - Show Class Slots - Show Class Generic Functions - Show Applicable Methods Filesystem Commands - Show Directory - Up Directory - Edit File (probably broken) - Show File (almost certainly broken) Directory Stack Commands - Display Directory Stack - Push Directory - Pop Directory - Swap Directory - Drop Directory Other Commands - Run (run an external program) - Background Run (as above, but don't wait for program to complete) The #! Macro Character ---------------------- Although there are commands for running external programs, the #! macro character tries to provide a nicer interface. It allows you to run external programs as a lisp function call, and attempts to transform the arguments in some meaningful way. Several transformations are performed: - Keywords are converted to options. Single character keywords are turned into an option with a single dash (e.g., :v becomes "-v"). Longer keywords become an option preceded by two dashes (e.g., :verbose becomes "--verbose") - Sequences are flattened into separate arguments - Wild pathnames are expanded (currently subject to brokenness in the DIRECTORY function of various CL environments) My apologies to anyone doing something more useful with this macro character if I have clobbered your readtable. Calling Commands from Lisp -------------------------- Calling CLIM commands from lisp is straightforward. By convention, the pretty names used at the interactor map to a function name which implements the command body by upcasing the name, replacing spaces with hyphens, and prepending "COM-" (e.g., Show Directory becomes COM-SHOW-DIRECTORY). Notes ----- There is currently no debugger integration with the listener, which is not particularly convenient. Gilbert Baumann has modified the CMUCL debugger so that it is capable of displaying on a CLIM stream. These modifications are contained in the file cmucl-hacks.lisp. If you want to try this, load the file and (setf *debug-io* *standard-output*) within the CLIM listener. cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/wholine.lisp0000755000175000017500000001363511345155772022052 0ustar pdmpdm;;; Listener "wholine" ;;; (C) Copyright 2003 by Andy Hefner (hefner1@umbc.edu) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-listener) (define-presentation-type listener-current-package () :inherit-from 'package) ;; Wholine Pane (defclass wholine-pane (application-pane) () (:default-initargs :background +gray90+)) (defmethod compose-space ((pane wholine-pane) &key width height) (declare (ignore width height)) (let ((h (* 1.5 (text-style-height (medium-text-style pane) pane)))) ; magic padding (make-space-requirement :height h :min-height h :max-height h))) ;; When the pane is grown, we must repaint more than just the newly exposed ;; regions, because the decoration within the previous region must move. ;; Likewise, shrinking the pane requires repainting some of the interior. (defmethod allocate-space :after ((pane wholine-pane) width height) (repaint-sheet pane (sheet-region pane))) (defun print-package-name (stream) (let ((foo (package-name *package*))) (with-drawing-options (stream :ink +royalblue+) (format stream "~A" (reduce (lambda (&optional (a foo) (b foo)) (if (< (length a) (length b)) a b)) (package-nicknames *package*)))))) (defun frob-pathname (pathname) (namestring (truename pathname))) ;; How to add repaint-time decoration underneath the contents of a ;; stream pane: Write your own handle-repaint that draws the ;; decoration then replays the recorded output, and define a ;; window-clear method which calls the next window-clear method, ;; then calls handle-repaint to redraw the decoration. (defmethod handle-repaint ((pane wholine-pane) region) (declare (ignore region)) (with-output-recording-options (pane :draw t :record nil) (with-bounding-rectangle* (x0 y0 x1 y1) (sheet-region pane) (draw-rectangle* pane x0 y0 x1 y1 :filled t :ink (pane-background pane)) (climi::draw-bordered-rectangle* (sheet-medium pane) x0 y0 x1 y1 :style :mickey-mouse-inset)) (replay-output-record (stream-output-history pane) pane))) (defmethod window-clear ((pane wholine-pane)) (call-next-method) (handle-repaint pane (sheet-region pane))) (defun generate-wholine-contents (frame pane) (declare (ignore frame)) (let* ((*standard-output* pane) (username (or #+cmu (cdr (assoc :user ext:*environment-list*)) #+scl (cdr (assoc "USER" ext:*environment-list* :test 'string=)) #+allegro (sys:getenv "USER") #-(or allegro cmu scl) (getenv "USER") "luser")) ; sorry.. (sitename (machine-instance)) ;; :sans-serif :roman :small is the best looking jaggy font. ;; But :small looks awful using freetype, perhaps because the ;; fonts are, for whatever reason, slightly smaller. ;; Very distressing. (text-size (if (find-package :mcclim-truetype) :normal :small)) (memusage #+(or cmu scl) (lisp::dynamic-usage) #+sbcl (sb-kernel:dynamic-usage) #+lispworks (getf (system:room-values) :total-allocated) #+openmcl (+ (ccl::%usedbytes) (ccl::%freebytes)) #+clisp (values (sys::%room)) #-(or cmu scl sbcl lispworks openmcl clisp) 0)) (with-text-style (t (make-text-style :sans-serif :roman text-size)) (formatting-table (t :x-spacing '(3 :character)) (formatting-row (t) (macrolet ((cell ((align-x) &body body) `(formatting-cell (t :align-x ,align-x) ,@body))) (cell (:left) (format t "~A@~A" username sitename)) (cell (:center) (format t "Package ") (with-output-as-presentation (t *package* 'listener-current-package) (print-package-name t))) (cell (:center) ;; CLISP gives us an error when calling ;; `cl:probe-file' with a directory argument. (when #+clisp (or (ignore-errors (ext:probe-directory *default-pathname-defaults*)) (ignore-errors (probe-file *default-pathname-defaults*))) #-clisp (probe-file *default-pathname-defaults*) (with-output-as-presentation (t (truename *default-pathname-defaults*) 'pathname) (format t "~A" (frob-pathname *default-pathname-defaults*)))) (when *directory-stack* (with-output-as-presentation (t *directory-stack* 'directory-stack) (format t " (~D deep)" (length *directory-stack*))))) ;; Although the CLIM spec says the item formatter should try to fill ;; the available width, I can't get either the item or table formatters ;; to really do so such that the memory usage appears right justified. (cell (:center) (when (numberp memusage) (present memusage 'lisp-memory-usage))))))))) (defun display-wholine (frame pane) (invoke-and-center-output pane (lambda () (generate-wholine-contents frame pane)) :horizontally nil :hpad 5))cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/hotfixes.lisp0000644000175000017500000000645607741012702022224 0ustar pdmpdm(in-package :clim-internals) ;;; (C) Copyright 2003 by Andy Hefner (hefner1@umbc.edu) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; This file contains various hotfixes against McCLIM to make ;;; it do what I need it to do. ;; These two might be obsolete.. ;; If you find various translators not working, uncomment these, otherwise ;; I think Tim Moore fixed things. #+nil (define-presentation-method presentation-subtypep ((type command-name) maybe-supertype) (with-presentation-type-parameters (command-name maybe-supertype) (let ((super-table command-table)) (with-presentation-type-parameters (command-name type) (command-table-inherits-from-p super-table command-table))))) #+nil (define-presentation-method presentation-subtypep ((type command) maybe-supertype) (with-presentation-type-parameters (command maybe-supertype) (let ((super-table command-table)) (with-presentation-type-parameters (command type) (command-table-inherits-from-p super-table command-table))))) ;; Only slightly improved reader support for McCLIM ;; Not really good enough to commit, but needed here. (defun finish-rescan (stream) (setf (stream-scan-pointer stream) (stream-insertion-pointer stream)) (setf (slot-value stream 'rescanning-p) nil)) #+nil (defun accept-using-read (stream ptype default default-type defaultp &key ((:read-eval *read-eval*) nil)) ;;(format *trace-output* "~&Activation gestures were: ~A~%" *activation-gestures*) (letf () ;(((medium-foreground stream) +green+)) (let ((*activation-gestures* nil)) (labels ((kludge-read () (read-preserving-whitespace stream nil)) (read-it () (loop (handler-case (return-from read-it (values (kludge-read) ptype)) (parse-error (c) (beep stream) (when *pointer-documentation-output* #+nil(setf (medium-foreground stream) +red+) ; This is silly. (window-clear *pointer-documentation-output*) (format *pointer-documentation-output* "~&A reader error ~A occured at ~A !~%" nil (stream-scan-pointer stream))) (finish-rescan stream) #+nil(read-gesture :stream stream :input-wait-handler *input-wait-handler*) (stream-read-char stream) (immediate-rescan stream)))))) (let ((result (read-it))) (if (presentation-typep result ptype) (values result ptype) (input-not-of-required-type result ptype))))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/TODO0000644000175000017500000000130511345155772020170 0ustar pdmpdm There are plenty of things left to do before the listener will really be useful for its intended purpose: McCLIM TODO: - Implement more of the emacs editing keys - Completion of pathnames and symbols - Subform accepting in places other than OpenMCL - Error checking during form reading Listener TODO: - Cleanup of mime type representation (no point in defining classes for each mime type, just define classes for the media types, and use EQL specializers to distinguish between subtypes in methods. - Flesh out icons - support multiple sizes in separate subdirectories of icons/ - Implement sorting and other options to Show Directory - Copy File, Delete File, etc. - Debugger integration cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/dev-commands.lisp0000644000175000017500000020304011345155772022746 0ustar pdmpdm(in-package :clim-listener) ;;; (C) Copyright 2003,2008 by Andy Hefner (ahefner@gmail.com) ;;; (C) Copyright 2004 by Paolo Amoroso (amoroso@mclink.it) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Command table and menu definitions (define-command-table application-commands) (define-command-table lisp-dev-commands :inherit-from nil) ;; Translators live here (define-command-table lisp-commands :inherit-from (lisp-dev-commands) :menu (("ASDF" :menu asdf-commands))) (define-command-table show-commands :inherit-from (lisp-dev-commands)) (define-command-table filesystem-commands :inherit-from (directory-stack-commands) :menu (("Directory Stack" :menu directory-stack-commands))) (define-command-table directory-stack-commands) ;;; Presentation types (define-presentation-type specializer () :inherit-from 'expression) (define-presentation-type class () :inherit-from 'specializer) (define-presentation-type eql-specializer () :inherit-from 'specializer) (define-presentation-type class-name () :inherit-from 'symbol) (define-presentation-type slot-definition () :inherit-from 'expression) (define-presentation-type-abbreviation function-name () `(and expression (satisfies legal-and-fboundp))) (defun legal-and-fboundp (object) (and #+sbcl (sb-int:valid-function-name-p object) #-sbcl (typep object '(or symbol (cons (eql setf)))) (fboundp object))) (define-presentation-type process () :inherit-from 'expression) (define-presentation-type generic-function () :inherit-from 't) (define-presentation-method presentation-typep (object (type generic-function)) (typep object 'generic-function)) (define-presentation-type standard-generic-function () :inherit-from 'generic-function) (define-presentation-type method () :inherit-from 'expression) (define-presentation-type standard-method () :inherit-from 'method) (define-presentation-type directory-stack () :inherit-from 'expression) (define-presentation-type bytes () :inherit-from 'integer) (define-presentation-type lisp-memory-usage () :inherit-from 'bytes) (define-presentation-type package () :inherit-from 'expression) (define-presentation-method presentation-typep (object (type package)) (typep object 'package)) (define-presentation-type package-name () :inherit-from 'string) (define-presentation-method presentation-typep (object (type package-name)) (find-package object)) ;;; Views (defclass fancy-view (textual-view) ((icon-size :initarg :icon-size :initform 16) (base-path :initform nil :initarg :base-path))) ;;; Presentation methods (define-presentation-method present (object (type standard-method) stream (view textual-view) &key &allow-other-keys) (let ((name (clim-mop:generic-function-name (clim-mop:method-generic-function object))) (qualifiers (clim-mop:method-qualifiers object)) (specializers (clim-mop:method-specializers object)) (lambda-list (clim-mop:method-lambda-list object)) (class-of-t (find-class t))) (format stream "~S ~{~S ~}(" name qualifiers) (multiple-value-bind (required optional rest key key-present) (climi::parse-lambda-list lambda-list) (loop for spec in specializers for arg in required for first-time = t then nil do (unless first-time (write-char #\space stream)) (if (eq spec class-of-t) (present arg 'symbol :stream stream) (progn (write-char #\( stream) (present arg 'symbol :stream stream) (write-char #\space stream) (with-output-as-presentation (stream spec 'specializer :single-box t) (if (typep spec 'class) (format stream "~S" (clim-mop:class-name spec)) (format stream "~S" `(eql ,(clim-mop:eql-specializer-object spec))))) (write-char #\) stream)))) (when optional (format stream " &optional ~{~A ~^ ~}" optional)) (when rest (format stream " &rest ~A" (car rest))) (when key-present (format stream " &key")) (loop for arg in key for key-arg = (cond ((symbolp arg) (intern (symbol-name arg) :keyword)) ((symbolp (car arg)) (intern (symbol-name (car arg)) :keyword) ) (t (caar arg))) do (format stream " ~S" key-arg)) (write-char #\) stream)))) (define-presentation-method present (object (type generic-function) stream (view textual-view) &key &allow-other-keys) (princ (clim-mop:generic-function-name object) stream)) (define-presentation-method accept ((type generic-function) stream (view textual-view) &key) ;; generic-functions are a subclass of standard-object, so they can be ;; accepted as expressions! (let ((fn (accept 'expression :stream stream :view view :history 'generic-function :prompt nil))) ;; (when (typep fn 'generic-function) (return-from accept fn)) (handler-case (fdefinition fn) (error () (simple-parse-error "~S is not the name of a generic function." fn))))) (define-presentation-method present (object (type bytes) stream (view textual-view) &key &allow-other-keys) (if (zerop object) (princ "0" stream) (let* ((suffixes '(" bytes" " KB" " MB" " GB" " TB" " PB")) (x (floor (realpart (log object 1000)))) (idx (min x (1- (length suffixes))))) (if (zerop idx) (format stream "~A bytes" object) (format stream "~,1F~A" (/ object (expt 1000 idx)) (nth idx suffixes)))))) ;;; Presentation translators (define-presentation-translator class-name-to-class (class-name class lisp-dev-commands :documentation ((object stream) (format stream "Class object ~A" object)) :gesture t) (object) (find-class object)) (define-presentation-translator symbol-to-class (symbol class lisp-dev-commands :documentation ((object stream) (format stream "Class object ~A" object)) :gesture t :tester ((object) (not (not (find-class object nil)))) :tester-definitive t) (object) (find-class object)) (define-presentation-translator symbol-to-class-name (symbol class-name lisp-dev-commands :documentation ((object stream) (format stream "Class ~A" object)) :gesture t :tester ((object) (not (not (find-class object nil)))) :tester-definitive t) (object) object) (define-presentation-translator class-to-class-name (class class-name lisp-dev-commands :documentation ((object stream) (format stream "Class of ~A" object)) :gesture t) (object) (clim-mop:class-name object)) (define-presentation-translator expression-to-function-name (expression function-name lisp-dev-commands :documentation ((object stream) (format stream "~A" object)) :gesture t :tester ((object) (legal-and-fboundp object)) :tester-definitive t) (object) object) (define-presentation-translator symbol-to-function-name (symbol function-name lisp-dev-commands :documentation ((object stream) (format stream "~A" object)) :gesture t :tester ((object) (legal-and-fboundp object)) :tester-definitive t) (object) object) #+nil ; doesn't work for some reason (define-presentation-translator sequence-to-function-name ((sequence t) function-name lisp-dev-commands :documentation ((object stream) (format stream "~A" object)) :gesture t :tester ((object) (legal-and-fboundp object)) :tester-definitive t) (object) object) ;;; Application commands (define-command (com-clear-output :name "Clear Output History" :command-table application-commands :menu t :provide-output-destination-keyword nil) () (window-clear *standard-output*)) ;; McCLIM fixme: Shouldn't we be able to activate before the (args) prompt ;; since defaults are defined? ;; FIXME: Disabled input, as it usually seems to hang. (define-command (com-run :name "Run" :command-table application-commands :menu t :provide-output-destination-keyword t) ((program 'string :prompt "Command") (args '(sequence string) :default nil :prompt "Arguments")) (run-program program args :wait t :input nil)) ;; I could replace this command with a keyword to COM-RUN.. (define-command (com-background-run :name "Background Run" :menu t :command-table application-commands :provide-output-destination-keyword t) ((program 'string :prompt "Command") (args '(sequence string) :default nil :prompt "Args")) (run-program program args :wait nil :output nil :input nil)) (define-command (com-reload-mime-database :name "Reload Mime Database" :menu t :command-table application-commands) () (progn (load-mime-types) (load-mailcaps))) (add-menu-item-to-command-table (find-command-table 'application-commands) nil :divider nil) (define-command (com-exit :name "Quit" :command-table application-commands :menu t :provide-output-destination-keyword nil) () (frame-exit *application-frame*)) ;;;; Commands relating to the Lisp environment (defvar *apropos-list* nil "The apropos command stores its output here.") ;; FIXME: Make this a present method specialzed on a view? (defun apropos-present-symbol (symbol &optional (stream *standard-output*) show-package) (multiple-value-bind (style ink) (values (if (or (fboundp symbol) (boundp symbol) (find-class symbol nil)) (make-text-style *apropos-symbol-bound-family* *apropos-symbol-unbound-face* :normal) (make-text-style *apropos-symbol-unbound-family* *apropos-symbol-bound-face* :normal)) (cond ((eql (symbol-package symbol) (find-package "KEYWORD")) (make-rgb-color 0.46 0.0 0.0)) ((fboundp symbol) (make-rgb-color 0.0 0.0 0.3)) ((find-class symbol nil) (make-rgb-color 0.03 0.35 0.48)) ((boundp symbol) (make-rgb-color 0.0 0.0 0.0)) (t (make-rgb-color 0.6 0.6 0.6)))) (with-drawing-options (stream :ink ink :text-style style) (with-output-as-presentation (stream symbol 'clim:symbol) (if show-package (let ((*package* (find-package :common-lisp-user))) (format stream "~W" symbol)) (princ (symbol-name symbol) stream))) (when (boundp symbol) (format stream " = ") (with-drawing-options (stream :ink +olivedrab+ ;; XXX :text-style (make-text-style :fix :roman :small)) (let ((object (symbol-value symbol))) (present object (presentation-type-of object) :stream stream))))))) ;; These are used by com-apropos to filter the list of symbols according to the domain keyword (defgeneric apropos-applicable-p (spec symbol)) (defmethod apropos-applicable-p ((spec (eql 'symbols)) symbol) t) (defmethod apropos-applicable-p ((spec (eql 'classes)) symbol) (find-class symbol nil)) (defmethod apropos-applicable-p ((spec (eql 'functions)) symbol) (fboundp symbol)) (defmethod apropos-applicable-p ((spec (eql 'variables)) symbol) (boundp symbol)) (defmethod apropos-applicable-p ((spec (eql 'command-tables)) symbol) (find-command-table symbol :errorp nil)) ;(defmethod apropos-applicable-p ((spec (eql 'presentation-type)) symbol) ; (find-presentation-type-class symbol nil)) (define-command (com-apropos :name "Apropos" :command-table lisp-commands :menu t :provide-output-destination-keyword t) ((string 'clim:string :prompt "String") &key (package '(or package-name package) :prompt "Package" :default nil) (domain '(member symbols classes functions variables command-tables) :prompt "Domain" :default 'symbols)) (let ((real-package (when package (if (typep package 'package) package (find-package package))))) (when (and package (not real-package)) (cerror "Search all packages instead" "No package specified by ~A could be found." package)) (let ((symbols (remove-if-not (lambda (sym) (apropos-applicable-p domain sym)) (apropos-list string real-package)))) (dolist (sym symbols) (apropos-present-symbol sym *standard-output* t) (terpri)) (setf *apropos-list* symbols) (note "Results have been saved to ~W~%" '*apropos-list*)))) (define-command (com-trace :name "Trace" :command-table lisp-commands :menu t :provide-output-destination-keyword nil) ((fsym 'function-name :prompt "function name")) (if (fboundp fsym) (progn (eval `(trace ,fsym)) (format t "~&Tracing ~W.~%" fsym)) (format t "~&Function ~W is not defined.~%" fsym))) (define-command (com-untrace :name "Untrace" :command-table lisp-commands :menu t :provide-output-destination-keyword nil) ((fsym 'function-name :prompt "function name")) (if (fboundp fsym) (progn (eval `(untrace ,fsym)) (format t "~&~W will no longer be traced.~%" fsym)) (format t "~&Function ~W is not defined.~%" fsym))) (define-command (com-load-file :name "Load File" :command-table lisp-commands :menu t :provide-output-destination-keyword t) ((pathname 'pathname :prompt "pathname")) (load pathname)) (define-command (com-compile-file :name "Compile File" :command-table lisp-commands :menu t :provide-output-destination-keyword t) ((pathname 'pathname :prompt "pathname")) (compile-file pathname)) (define-command (com-compile-and-load :name "Compile and load" :command-table lisp-commands :menu t :provide-output-destination-keyword t) ((pathname 'pathname :prompt "pathname")) (load (compile-file pathname))) (define-command (com-room :name "Room" :command-table lisp-commands :menu t :provide-output-destination-keyword t) () (room)) (define-presentation-to-command-translator mem-room-translator (lisp-memory-usage com-room lisp-commands :gesture :select :documentation "Room" :pointer-documentation "Room") ()) (define-presentation-to-command-translator com-show-class-subclasses-translator (class-name com-show-class-subclasses lisp-commands :menu t :documentation "Show Class Subclasses" :pointer-documentation "Show Class Subclasses") (object) (list object)) (define-presentation-to-command-translator com-show-class-superclasses-translator (class-name com-show-class-superclasses lisp-commands :menu t :tester ((object) (not (eq t object))) :documentation "Show Class Superclasses" :pointer-documentation "Show Class Superclasses") (object) (list object)) (define-presentation-to-command-translator com-show-class-generic-functions-translator (class-name com-show-class-generic-functions lisp-commands :menu t :documentation "Show Class Generic Functions" :pointer-documentation "Show Class Generic Functions") (object) (list object)) (define-presentation-to-command-translator com-show-class-slots-translator (class-name com-show-class-slots lisp-commands :menu t :documentation "Show Class Slots" :pointer-documentation "Show Class Slots") (object) (list object)) ;;; CLOS introspection commands (defun class-grapher (stream class inferior-fun &key (orientation :horizontal)) "Does the graphing for Show Class Superclasses and Subclasses commands" (let ((normal-ink +foreground-ink+) (arrow-ink *graph-edge-ink*) (text-style *graph-text-style*)) (with-drawing-options (stream :text-style text-style) (prog1 ;; not sure whether anyone wants the return value... (format-graph-from-roots (list class) #'(lambda (class stream) (with-drawing-options (stream :ink normal-ink :text-style text-style) ;; Present class name rather than class here because the printing of the ;; class object itself is rather long and freaks out the pointer doc pane. (with-output-as-presentation (stream (clim-mop:class-name class) 'class-name :single-box t) ; (surrounding-output-with-border (stream :shape :drop-shadow) (princ (clim-mop:class-name class) stream)))) ;) inferior-fun :stream stream :merge-duplicates t :graph-type :tree :orientation orientation :arc-drawer #'(lambda (stream foo bar x1 y1 x2 y2) (declare (ignore foo bar)) (draw-arrow* stream x1 y1 x2 y2 :ink arrow-ink))) ;; format-graph-from-roots doesn't do this by default... (when (typep stream 'pane) (change-space-requirements stream)))))) (defun frob-to-class (spec) (if (typep spec 'class) spec (find-class spec nil))) (define-command (com-show-class-superclasses :name "Show Class Superclasses" :command-table show-commands :menu "Class Superclasses" :provide-output-destination-keyword t) ((class-spec 'class-name :prompt "class") &key (orientation 'keyword :prompt "orientation" :default :horizontal)) (let ((class (frob-to-class class-spec))) (if (null class) (note "~A is not a defined class." class-spec) (class-grapher *standard-output* class #'clim-mop:class-direct-superclasses :orientation orientation)))) (define-command (com-show-class-subclasses :name "Show Class Subclasses" :command-table show-commands :menu "Class Subclasses" :provide-output-destination-keyword t) ((class-spec 'class-name :prompt "class") &key (orientation 'keyword :prompt "orientation" :default :horizontal)) (let ((class (frob-to-class class-spec))) (if (not (null class)) (class-grapher *standard-output* class #'clim-mop:class-direct-subclasses :orientation orientation) (note "~A is not a defined class." class-spec)))) (defun direct-slot-definitions (class slot-name) "Given a class and a slot name, returns a list of the direct slot definitions for this slot in the order they occur along the CPL." (mapcan (lambda (cpl-class) (copy-list (remove slot-name (clim-mop:class-direct-slots cpl-class) :key #'clim-mop:slot-definition-name :test-not #'eql))) (clim-mop:class-precedence-list class))) (defun present-slot (slot class &key (stream *standard-output*)) "Formats a slot definition into a table row." (let* ((name (clim-mop:slot-definition-name slot)) (type (clim-mop:slot-definition-type slot)) (initargs (clim-mop:slot-definition-initargs slot)) (initfunc (clim-mop:slot-definition-initfunction slot)) (initform (clim-mop:slot-definition-initform slot)) (direct-slots (direct-slot-definitions class name)) (readers (mapcan (lambda (x) (copy-list (clim-mop:slot-definition-readers x))) direct-slots)) (writers (mapcan (lambda (x) (copy-list (clim-mop:slot-definition-writers x))) direct-slots)) (documentation (first (remove nil (mapcar (lambda (x) (documentation x t)) direct-slots)))) (*standard-output* stream)) (macrolet ((with-ink ((var) &body body) `(with-drawing-options (t :ink ,(intern (concatenate 'string "*SLOT-" (symbol-name var) "-INK*"))) ,@body)) (fcell ((var align-x &rest cell-opts) &body body) `(formatting-cell (t :align-x ,align-x ,@cell-opts) (with-ink (,var) ,@body) ))) (fcell (name :left) (with-output-as-presentation (t slot 'slot-definition :single-box t) (princ name)) (unless (eq type t) (fresh-line) (with-ink (type) (princ type)))) (fcell (initargs :right) (dolist (x initargs) (format t "~W~%" x))) (fcell (initform :left) (if initfunc (format t "~W" initform) (note "No initform"))) (formatting-cell (t :align-x :left) (if (not (or readers writers)) (note "No accessors") (progn (with-ink (readers) (if readers (dolist (reader readers) (present reader (presentation-type-of reader)) (terpri)) (note "No readers~%"))) (with-ink (writers) (if writers (dolist (writer writers) (present writer (presentation-type-of writer)) (terpri)) (note "No writers")))))) (fcell (documentation :left) (when documentation (with-text-family (t :serif) (princ documentation)))) ))) (defun earliest-slot-definer (slot class) "Returns the earliest class in the CPL of CLASS which defines SLOT." (let ((name (clim-mop:slot-definition-name slot))) (dolist (class (reverse (clim-mop:class-precedence-list class))) (dolist (slot-b (clim-mop:class-direct-slots class)) (when (eq name (clim-mop:slot-definition-name slot-b)) (return-from earliest-slot-definer class))))) (error "Slot ~W does not appear to be defined in ~W" slot class)) (defun class-sorted-slots (class) "Sort the slots in order of definition within the CPL, superclasses first." (let ((cpl (clim-mop:class-precedence-list class))) (sort (copy-list (clim-mop:class-slots class)) (lambda (a b) (< (position (earliest-slot-definer a class) cpl) (position (earliest-slot-definer b class) cpl)))))) (defun print-slot-table-heading () (formatting-row (t) (dolist (name '("Slot name" "Initargs" "Initform" "Accessors")) (formatting-cell (t :align-x :center) (underlining (t) (with-text-family (t :sans-serif) (princ name))))))) (defun present-slot-list (slots class) (formatting-table (t) (print-slot-table-heading) (dolist (slot slots) (formatting-row (t) (present-slot slot class))))) (defun friendly-slot-allocation-type (allocation) (if (typep allocation 'standard-class) (class-name allocation) allocation)) (defun present-the-slots (class) (let* ((slots (class-sorted-slots class)) (instance-slots (remove-if (lambda (x) (not (eq :instance (clim-mop:slot-definition-allocation x)))) slots)) (other-slots (set-difference slots instance-slots)) (allocation-types (remove-duplicates (mapcar #'clim-mop:slot-definition-allocation other-slots)))) (when other-slots (underlining (t) (format t "~&Instance Slots~%"))) (present-slot-list instance-slots class) (dolist (alloc allocation-types) (underlining (t) (format t "~&Allocation: ~A~%" (friendly-slot-allocation-type alloc))) (present-slot-list (remove-if (lambda (x) (not (eq alloc (clim-mop:slot-definition-allocation x)))) other-slots) class)))) (define-command (com-show-class-slots :name "Show Class Slots" :command-table show-commands :menu "Class Slots" :provide-output-destination-keyword t) ((class-name 'clim:symbol :prompt "class name")) (let* ((class (find-class class-name nil)) (finalized-p (and class (typep class 'standard-class) (progn (clim-mop:finalize-inheritance class) (clim-mop:class-finalized-p class)))) (slots (and finalized-p (clim-mop:class-slots class)))) (cond ((null class) (note "~A is not a defined class.~%" class-name)) ((not (typep class 'standard-class)) (note "Class ~A is not a STANDARD-CLASS.~%" class-name)) ((not finalized-p) (note "Class ~A is not finalized." class-name)) ((null slots) (note "~%This class has no slots.~%~%")) (t (invoke-as-heading (lambda () (format t "~&Slots for ") (with-output-as-presentation (t (clim-mop:class-name class) 'class-name :single-box t) (princ (clim-mop:class-name class))))) (present-the-slots class))))) (defparameter *ignorable-internal-class-names* '(standard-object)) (defun remove-ignorable-classes (classes) (remove-if (lambda (c) (or (member (class-name c) *ignorable-internal-class-names*) (not (typep c 'standard-class)))) classes)) (defun x-specializer-direct-generic-functions (specializer) ;; This still belongs in CLIM-MOP. #+PCL (pcl::specializer-direct-generic-functions specializer) #+SBCL (sb-pcl::specializer-direct-generic-functions specializer) #+clisp (clos:specializer-direct-generic-functions specializer) #+openmcl-partial-mop (openmcl-mop:specializer-direct-generic-functions specializer) #+scl (clos:specializer-direct-generic-functions specializer) #+allegro (mop:specializer-direct-generic-functions specializer) #-(or PCL SBCL scl clisp openmcl-partial-mop) (error "Sorry, not supported in your CL implementation. See the function X-SPECIALIZER-DIRECT-GENERIC-FUNCTION if you are interested in fixing this.")) (defun class-funcs (class) (remove-duplicates (mapcan (lambda (class) (copy-list (x-specializer-direct-generic-functions class))) (remove-ignorable-classes (clim-mop:class-precedence-list class))))) (defun slot-name-sortp (a b) (flet ((slot-name-symbol (x) (or (and (consp x) (second x) (symbolp (second x)) (second x)) x))) (let ((a (slot-name-symbol a)) (b (slot-name-symbol b))) (if (and (symbolp a) (symbolp b)) (cond ((not (eq (symbol-package a) (symbol-package b))) (string< (package-name (symbol-package a)) (package-name (symbol-package b)))) (t (string< (symbol-name a) (symbol-name b)))) (string< (princ-to-string a) (princ-to-string b)))))) (define-command (com-show-class-generic-functions :name "Show Class Generic Functions" :command-table show-commands :menu "Class Generic Functions" :provide-output-destination-keyword t) ((class-spec 'class-name :prompt "class")) (let ((class (frob-to-class class-spec))) (if (null class) (note "~A is not a defined class." class-spec) (let ((funcs (sort (class-funcs class) #'slot-name-sortp :key #'clim-mop:generic-function-name))) (with-text-size (t :small) (format-items funcs :printer (lambda (item stream) (present item 'generic-function :stream stream)) :move-cursor t)))))) (defun method-applicable-to-args-p (method args arg-types) (loop for specializer in (clim-mop:method-specializers method) for arg in args for arg-type in arg-types unless (cond ((eq arg-type :wild) t) ((typep specializer 'clim-mop:eql-specializer) (and (not (eq arg arg-type)) (eql arg (clim-mop:eql-specializer-object specializer)))) ((eq arg arg-type) (subtypep arg-type specializer)) (t (typep arg specializer))) return nil finally (return t))) (defun get-applicable-methods (gf args arg-types) (mapcan #'(lambda (method) (when (method-applicable-to-args-p method args arg-types) (list method))) (clim-mop:generic-function-methods gf))) (defun sort-methods-by-args (methods arg-types) (let ((cpls (mapcar #'(lambda (type) (if (eq type :wild) nil (clim-mop:class-precedence-list type))) arg-types))) (flet ((sorter (meth1 meth2) (loop for spec1 in (clim-mop:method-specializers meth1) for spec2 in (clim-mop:method-specializers meth2) for arg-type in arg-types for cpl in cpls for spec1-cpl = (unless (typep spec1 'clim-mop:eql-specializer) (clim-mop:class-precedence-list spec1)) for spec2-cpl = (unless (typep spec1 'clim-mop:eql-specializer) (clim-mop:class-precedence-list spec2)) do (cond ((eq spec1 spec2)) ;Keep going ((eq arg-type :wild) (cond ((typep spec1 'clim-mop:eql-specializer) (unless (typep spec2 'clim-mop:eql-specializer) (return-from sorter t))) ((typep spec1 'clim-mop:eql-specializer) (return-from sorter nil)) ((subtypep spec1 spec2) (return-from sorter t)) ((subtypep spec2 spec1) (return-from sorter nil)) ;; Types are not related (t (let ((cpl-len1 (length spec1-cpl)) (cpl-len2 (length spec2-cpl))) (cond ((> cpl-len1 cpl-len2) (return-from sorter t)) ((< cpl-len1 cpl-len2) (return-from sorter nil))))))) ;; An actual instance ((typep spec1 'clim-mop:eql-specializer) (return-from sorter t)) ((typep spec2 'clim-mop:eql-specializer) (return-from sorter nil)) (t (let ((pos1 (position spec1 cpl)) (pos2 (position spec2 cpl))) (cond ((< pos1 pos2) (return-from sorter t)) ((> pos1 pos2) (return-from sorter nil)))))) finally (return nil)))) (declare (dynamic-extent #'sorter)) (sort methods #'sorter)))) (defun show-specialized-methods (gf stream methods arg-types) (let ((before nil) (after nil) (around nil) (primary nil)) (loop for meth in methods for (qualifier) = (clim-mop:method-qualifiers meth) do (case qualifier (:before (push meth before)) (:after (push meth after)) (:around (push meth around)) (t (push meth primary)))) (setq before (sort-methods-by-args before arg-types)) (setq after (nreverse (sort-methods-by-args after arg-types))) (setq around (sort-methods-by-args around arg-types)) (setq primary (sort-methods-by-args primary arg-types)) (flet ((do-meths (kind methods) (with-text-face (stream :italic) (format stream "~A methods:~%" kind)) (loop for meth in methods do (present meth 'standard-method :stream stream) (terpri stream)))) (do-meths "Before" before) (do-meths "Around" around) (do-meths "Primary" primary) (do-meths "After" after)))) (defun make-gf-specialized-ptype (gf-name) (let ((gf gf-name)) (unless (typep gf 'generic-function) (handler-case (setq gf (fdefinition gf-name)) (error () (return-from make-gf-specialized-ptype nil)))) (unless (typep gf 'generic-function) (return-from make-gf-specialized-ptype nil)) (let ((required (climi::parse-lambda-list (clim-mop::generic-function-lambda-list gf)))) (loop for arg in required collect (make-presentation-type-specifier '(expression) :description (format nil "~A" arg)) into args finally (return `(sequence-enumerated ,@args)))))) (define-command (com-show-generic-function :name t :command-table show-commands :menu "Generic Function" :provide-output-destination-keyword t) ((gf 'generic-function :prompt "a generic function") &key (classes 'boolean :default nil :mentioned-default t) (methods 'boolean :default nil :mentioned-default t) (specialized (make-gf-specialized-ptype gf) :prompt "function arguments" :default nil :display-default nil)) (when specialized (setq methods t)) (let ((doc-string (documentation gf t))) (with-text-face (*standard-output* :italic) (format *standard-output* "Lambda list:~%")) (format *standard-output* "~S~%" (clim-mop:generic-function-lambda-list gf)) (when doc-string (with-text-face (*standard-output* :italic) (format *standard-output* "Documentation:~%~A~&" doc-string))) (when classes (with-text-face (*standard-output* :italic) (format *standard-output* "Classes:~%")) (let ((class-list nil) (meths (clim-mop:generic-function-methods gf))) (loop for m in meths do (loop for arg in (clim-mop:method-specializers m) unless (typep arg 'clim-mop:eql-specializer) do (pushnew arg class-list))) (loop for class in class-list do (progn (with-output-as-presentation (*standard-output* (clim-mop:class-name class) 'class-name :single-box t) (format *standard-output* "~S~%" (clim-mop:class-name class))))))) (when methods (let ((args nil) (arg-types nil)) (if (null specialized) (setq args (mapcar (constantly :wild) (clim-mop:generic-function-argument-precedence-order gf)) arg-types args) (loop with arg = nil and arg-type = nil for arg-for-spec in specialized do (setf (values arg arg-type) (cond ((eq arg-for-spec '*) (values :wild :wild)) ((and (listp arg-for-spec) (eq (car arg-for-spec) 'quote)) (values (cadr arg-for-spec) (class-of (cadr arg-for-spec)))) ((symbolp arg-for-spec) (let ((class (find-class arg-for-spec))) (values class class))) ((typep arg-for-spec 'standard-class) (values arg-for-spec arg-for-spec)) (t (values arg-for-spec (class-of arg-for-spec))))) collect arg into collect-args collect arg-type into collect-arg-types finally (setf (values args arg-types) (values collect-args collect-arg-types)))) (let ((meths (get-applicable-methods gf args arg-types))) (with-text-face (*standard-output* :italic) (format *standard-output* "Methods:~%")) (show-specialized-methods gf *standard-output* meths arg-types)))))) ;;; Add to McCLIM's listener the commands "Show Used Packages" and "Show Package ;;; Users" for displaying package hierarchy graphs. ;;; ;;; Paolo Amoroso -- 27 Aug 2004 (defun symbol-status (sym) (nth-value 1 (find-symbol (symbol-name sym) (symbol-package sym)))) (defun portable-internal-symbol-count (package) (let ((n 0)) (do-symbols (symbol package) (when (and #+NIL (eq (symbol-package symbol) package) (eq :internal (symbol-status symbol))) (incf n))) n)) (defun count-internal-symbols (package) "Return the number of internal symbols in PACKAGE." ;; We take only the first value, the symbol count, and discard the second, the ;; hash table capacity #+(or cmu scl) (values (lisp::internal-symbol-count package)) #+sbcl (values (sb-int:package-internal-symbol-count package)) #+clisp (svref (sys::%record-ref *package* 1) 2) #-(or cmu scl sbcl clisp) (portable-internal-symbol-count package)) (defun portable-external-symbol-count (package) (let ((n 0)) (do-external-symbols (symbol package) (declare (ignorable symbol)) (incf n)) n)) (defun count-external-symbols (package) "Return the number of external symbols in PACKAGE." #+(or cmu scl) (values (lisp::external-symbol-count package)) #+sbcl (values (sb-int:package-external-symbol-count package)) #+clisp (svref (sys::%record-ref *package* 0) 2) #-(or cmu scl sbcl clisp) (portable-external-symbol-count package)) (defun package-grapher (stream package inferior-fun) "Draw package hierarchy graphs for `Show Package Users' and `Show Used Packages'." (let ((normal-ink +foreground-ink+) (arrow-ink (make-rgb-color 0.72 0.72 0.72)) (text-style (make-text-style :fix :roman :normal))) (with-drawing-options (stream :text-style text-style) (format-graph-from-roots (list package) #'(lambda (package stream) (let ((internal (count-internal-symbols package)) (external (count-external-symbols package))) (with-drawing-options (stream :ink (if (plusp external) normal-ink (make-rgb-color 0.4 0.4 0.4)) :text-style text-style) (with-output-as-presentation (stream package 'package :single-box t) (format stream "~A (~D/~D)" (package-name package) internal external))))) inferior-fun :stream stream :merge-duplicates t :graph-type :tree :orientation :horizontal :arc-drawer #'(lambda (stream foo bar x1 y1 x2 y2) (declare (ignore foo bar)) (draw-arrow* stream x1 y1 x2 y2 :ink arrow-ink)))))) (define-command (com-show-used-packages :name "Show Used Packages" :command-table show-commands :menu "Used Packages" :provide-output-destination-keyword t) ((package-spec '(or package-name package) :prompt "package" :default *package*)) (let ((real-package (when package-spec (if (typep package-spec 'package) package-spec (find-package package-spec))))) (if (packagep real-package) (package-grapher *standard-output* real-package #'package-use-list) (note "~A is not a package." package-spec)))) (define-command (com-show-package-users :name "Show Package Users" :command-table show-commands :menu "Package Users" :provide-output-destination-keyword t) ((package-spec '(or package-name package) :prompt "package" :default *package*)) (let ((real-package (when package-spec (if (typep package-spec 'package) package-spec (find-package package-spec))))) (if (packagep real-package) (package-grapher *standard-output* real-package #'package-used-by-list) (note "~A is not a package." package-spec)))) ;;; Filesystem Commands ;;; ------------------- (defun pathname-printing-name (pathname &optional relative-to) (if relative-to (native-enough-namestring pathname relative-to) (native-namestring pathname))) (defun pretty-pretty-pathname (pathname stream &optional (relative-to nil)) (with-output-as-presentation (stream pathname 'clim:pathname :single-box t) (let ((icon (icon-of pathname))) (when icon (draw-icon stream icon :extra-spacing 3))) (princ (pathname-printing-name pathname relative-to) stream)) (terpri stream)) (defun actual-name (pathname) (if (directoryp pathname) (if (stringp (car (last (pathname-directory pathname)))) (car (last (pathname-directory pathname))) (directory-namestring pathname)) (native-namestring (file-namestring pathname)))) (defun sort-pathnames (list sort-by) (case sort-by ; <--- FIXME ('name (sort list #'string-lessp :key #'actual-name)) (t list))) (defun split-sort-pathnames (list group-dirs sort-by) (mapcar (lambda (x) (sort-pathnames x sort-by)) (multiple-value-list (if (not group-dirs) (values list) (values (remove-if-not #'directoryp list) (remove-if #'directoryp list)))))) (defun garbage-name-p (name) (when (> (length name) 2) (let ((first (elt name 0)) (last (elt name (1- (length name))))) (or (char= last #\~) (and (char= first #\#) (char= last #\#)))))) (defun hidden-name-p (name) (and (> (length name) 1) (char= (elt name 0) #\.))) (defun filter-garbage-pathnames (seq show-hidden hide-garbage) (remove-if (lambda (name) (or (and (not show-hidden) (hidden-name-p name)) (and hide-garbage (garbage-name-p name)))) seq :key #'actual-name)) (defun show-directory-pathnames (pathname) "Convert the pathname entered by the user into a query pathname (the pathname which will be passed to cl:directory, potentially a wild pathname), and a base pathname (which directory entries may be printed relative to in the fashion of enough-namestring)." (values (if (wild-pathname-p pathname) pathname (gen-wild-pathname pathname)) (strip-filespec pathname))) ;; Change to using an :ICONIC view for pathnames? (define-command (com-show-directory :name "Show Directory" :command-table filesystem-commands :menu t :provide-output-destination-keyword t) ((pathname 'pathname #+nil(or 'string 'pathname) :prompt "pathname") &key (sort-by '(member name size modify none) :default 'name) (show-hidden 'boolean :default nil :prompt "show hidden") (hide-garbage 'boolean :default t :prompt "hide garbage") (show-all 'boolean :default nil :prompt "show all") (style '(member :items :list) :default :items :prompt "listing style") (group-directories 'boolean :default t :prompt "group directories?") (full-names 'boolean :default nil :prompt "show full name?") (list-all-direct-subdirectories 'boolean :default nil :prompt "list all direct subdirectories?")) (multiple-value-bind (query-pathname base-pathname) (show-directory-pathnames pathname) (let ((dir (if list-all-direct-subdirectories (list-directory-with-all-direct-subdirectories query-pathname) (list-directory query-pathname)))) (with-text-family (t :sans-serif) (invoke-as-heading (lambda () (cond ((wild-pathname-p pathname) (format t "Files matching ") (present query-pathname 'pathname)) (t (format t "Contents of ") (present (directory-namestring query-pathname) 'pathname))))) (when (parent-directory pathname) (with-output-as-presentation (t (parent-directory pathname) 'clim:pathname :single-box t) ;; Workaround new mcclim-images draw-icon silliness using ;; table formatter (formatting-table (t :move-cursor nil) (formatting-row () (formatting-cell () (draw-icon t (standard-icon "up-folder.xpm") :extra-spacing 3) (format t "Parent Directory"))))) ;; Note that the above leaves the cursor positioned at the end ;; of the "Parent Directory" line. (terpri)) (dolist (group (split-sort-pathnames dir group-directories sort-by)) (unless show-all (setf group (filter-garbage-pathnames group show-hidden hide-garbage))) (ecase style (:items (abbreviating-format-items group :row-wise nil :x-spacing " " :y-spacing 1 :printer (lambda (x stream) (pretty-pretty-pathname x stream (if full-names nil base-pathname)))) (multiple-value-bind (x y) (stream-cursor-position *standard-output*) (setf (stream-cursor-position *standard-output*) (values 0 y)))) (:list (dolist (ent group) (let ((ent (merge-pathnames ent pathname))) (pretty-pretty-pathname ent *standard-output* full-names)))))))))) #+nil ; OBSOLETE (define-presentation-to-command-translator show-directory-translator (clim:pathname com-show-directory filesystem-commands :gesture :select :pointer-documentation ((object stream) (format stream "Show directory ~A" object)) :tester-definitive t :tester ((object) (directoryp object))) (object) (list object)) (define-command (com-change-directory :name "Change Directory" :menu t :command-table filesystem-commands) ((pathname 'pathname :prompt "pathname")) (let ((pathname (merge-pathnames ;; helpfully fix things if trailing slash wasn't entered (coerce-to-directory pathname)))) (if (not (probe-file pathname)) (note "~A does not exist.~%" pathname) (change-directory pathname)))) (define-command (com-up-directory :name "Up Directory" :menu t :command-table filesystem-commands) () (let ((parent (parent-directory *default-pathname-defaults*))) (when parent (change-directory parent) (italic (t) (format t "~&The current directory is now ") (present (truename parent)) (terpri))))) (define-gesture-name :change-directory :pointer-button-press (:middle)) (define-presentation-to-command-translator change-directory-translator (clim:pathname com-change-directory filesystem-commands :gesture :change-directory :pointer-documentation ((object stream) (declare (ignore object)) (format stream "Change to this directory")) :documentation ((object stream) (declare (ignore object)) (format stream "Change to this directory")) :tester ((object) (directoryp object))) (object) (list object)) ;;; External file viewers (defgeneric mime-type-to-command (mime-type pathname) (:documentation "Translates a pathname to an invocation of a CLIM command, typically according to the mime type deduced for that pathname. Returns three values: command, documentation, and pointer documentation.")) ;; This pathname translator stuff is really turning into a mess. ;; What I need to do is merge mime types with presentations, and ;; rip all the rest of this shit out. (defmethod mime-type-to-command (mime-type pathname) (declare (ignore mime-type pathname)) (values nil nil)) (defmethod mime-type-to-command ((mime-type null) pathname) (declare (ignore #|mime-type|# pathname)) (values nil nil)) (defmethod mime-type-to-command ((mime-type symbol) pathname) (mime-type-to-command (clim-mop:class-prototype (find-class mime-type nil)) pathname)) ;; Move these elsewhere. (defmethod mime-type-to-command ((mime-type text/x-lisp-source) pathname) (values `(com-compile-and-load ,pathname) "Compile and Load" (format nil "Compile and load ~A" pathname))) (defmethod mime-type-to-command ((mime-type application/x-lisp-fasl) pathname) (values `(com-load-file ,pathname) "Load" (format nil "Load ~A" pathname))) ;; I've taken to doing translator documentation exactly opposite of how the CLIM ;; spec seems to intend. The spec says that the pointer-documentation should be ;; short and quickly computed, and the documentation should be longer and more ;; descriptive. Personally, I like seeing the full the command with the arguments ;; in the pointer-doc window, and something short in right-button menus. ;; So.. yeah. (defun automagic-translator (pathname) "Returns 2 values: the command translation, and a documentation string for the translation." (cond ((wild-pathname-p pathname) (values `(com-show-directory ,pathname) "Show Matching Files" (format nil "Show Files Matching ~A" pathname))) ((not (probe-file pathname)) (values nil nil nil)) ((directoryp pathname) (values `(com-show-directory ,pathname) "Show Directory" (format nil "Show Directory ~A" pathname))) (t (multiple-value-bind (command doc pointer-doc) (find-viewspec pathname) (let ((mime-type (pathname-mime-type pathname))) (mv-or (when mime-type (mime-type-to-command mime-type pathname)) (when command (values command doc pointer-doc)))))))) (define-presentation-translator automagic-pathname-translator (clim:pathname clim:command filesystem-commands :gesture :select :priority 2 :tester ((object) (automagic-translator object)) :documentation ((object stream) (princ (nth-value 1 (automagic-translator object)) stream)) :pointer-documentation ((object stream) (princ (nth-value 2 (automagic-translator object)) stream))) (object) (values (automagic-translator object) 'command)) ;;; The directory stack. (defvar *directory-stack* nil) ;; FIXME: This should probably be a slot of the frame. (defun compute-dirstack-command-eligibility (frame) (let* ((stack *directory-stack*) (state (if stack t nil))) (setf (command-enabled 'com-drop-directory frame) state (command-enabled 'com-pop-directory frame) state (command-enabled 'com-swap-directory frame) state))) (defmacro with-directory-stack (() &body body) `(prog1 (if *directory-stack* (progn ,@body) (note "The directory stack is empty.")) (compute-dirstack-command-eligibility *application-frame*))) (define-command (com-push-directory :name "Push Directory" :menu t :command-table directory-stack-commands) ((pathname 'pathname :prompt "directory")) (let ((pathname (merge-pathnames (coerce-to-directory pathname)))) (if (not (probe-file pathname)) (note "~A does not exist.~%" pathname) (progn (push *default-pathname-defaults* *directory-stack*) (com-change-directory pathname)))) (compute-dirstack-command-eligibility *application-frame*)) (defun comment-on-dir-stack () (if *directory-stack* (progn (format t "~&The top of the directory stack is now ") (present (truename (first *directory-stack*))) (terpri)) (format t "~&The directory stack is now empty.~%"))) (define-command (com-pop-directory :name "Pop Directory" :menu t :command-table directory-stack-commands) () (with-directory-stack () (com-change-directory (pop *directory-stack*)) (comment-on-dir-stack))) (define-command (com-drop-directory :name "Drop Directory" :menu t :command-table directory-stack-commands) () (with-directory-stack () (setf *directory-stack* (rest *directory-stack*)) (comment-on-dir-stack))) (define-command (com-swap-directory :name "Swap Directory" :menu t :command-table directory-stack-commands) () (with-directory-stack () (psetf (first *directory-stack*) *default-pathname-defaults* *default-pathname-defaults* (first *directory-stack*)) (comment-on-dir-stack))) (define-command (com-display-directory-stack :name "Display Directory Stack" :menu t :command-table directory-stack-commands) () (with-directory-stack () (dolist (pathname *directory-stack*) (fresh-line) (pretty-pretty-pathname pathname *standard-output*) (terpri)))) (define-presentation-to-command-translator display-dir-stack-translator (directory-stack com-display-directory-stack filesystem-commands :gesture :select) () ()) (define-command (com-edit-file :name "Edit File" :menu t :command-table filesystem-commands :provide-output-destination-keyword nil) ((pathname 'pathname :prompt "pathname")) (clim-sys:make-process (lambda () (ed pathname)))) (define-presentation-to-command-translator edit-file (clim:pathname com-edit-file filesystem-commands :gesture :select :pointer-documentation ((object stream) (format stream "Edit ~A" object)) :documentation ((stream) (format stream "Edit File")) :tester ((object) (and (not (wild-pathname-p object)) (probe-file object) (pathname-name object) (let ((mime-type (pathname-mime-type object))) (and mime-type (subtypep mime-type 'text)))))) (object) (list object)) (define-command (com-show-file :name "Show File" :command-table filesystem-commands :menu t :provide-output-destination-keyword t) ((object 'pathname :prompt "pathname")) (show-file object)) (define-presentation-to-command-translator show-file (clim:pathname com-show-file filesystem-commands :gesture :select :pointer-documentation ((object stream) (format stream "Show ~A" object)) :documentation ((stream) (format stream "Show File")) :tester ((object) (and (not (wild-pathname-p object)) (probe-file object) (pathname-name object) (let ((mime-type (pathname-mime-type object))) (and mime-type (subtypep mime-type 'text)))))) (object) (list object)) (define-command (com-display-image :name t :command-table filesystem-commands :menu t) ((image-pathname 'pathname :default (user-homedir-pathname) :insert-default t)) (if (probe-file image-pathname) (let* ((type (funcall (case (readtable-case *readtable*) (:upcase #'string-upcase) (:downcase #'string-downcase) (t #'identity)) (pathname-type image-pathname))) (format (find-symbol type (find-package :keyword)))) (handler-case (let ((pattern (make-pattern-from-bitmap-file image-pathname :format format))) (with-room-for-graphics () (draw-pattern* *standard-output* pattern 0 0))) (unsupported-bitmap-format () (format t "Image format ~A not recognized" type)))) (format t "No such file: ~A" image-pathname))) (define-command (com-edit-definition :name "Edit Definition" :command-table lisp-commands :menu t :provide-output-destination-keyword nil) ((function-name 'function-name :prompt "function name")) (clim-sys:make-process (lambda () (ed function-name)))) (define-presentation-to-command-translator edit-definition (function-name com-edit-definition lisp-commands :gesture :select :pointer-documentation ((object stream) (format stream "Edit Definition of ~A" object)) :documentation ((stream) (format stream "Edit Definition"))) (object) (list object)) (defun show-file (pathname) (let ((*standard-output* (open-window-stream :scroll-bars :both)) ) (with-open-file (in pathname) (loop for line = (read-line in nil) while line do (progn (princ line) (terpri)))))) ;;; Eval (defun display-evalues (values) (labels ((present-value (value) ;; I would really prefer this to behave as below, as presenting ;; things as expressions causes translators applicable to expression ;; to override those which would be otherwise applicable (such as ;; the set-current-package translator). I retain the use of w-o-a-p, ;; swapping the inner/outer presentation types, with the assumption ;; that someone (the form reader?) really does want expressions, and ;; the presentation-type-of is seldom a subtype of expression. ;; Aside from that, the problem with my code below is that it ;; will use the default presentation method for the type, which will ;; not necessarily print in the fashion expected from the lisp REPL. ;; Possibly this +listener-view+ could save the day here, but I'm ;; unclear on why it exists. --Hefner ;; Okay, set-current-package translator now mysteriously works, but ;; I stand by the notion that 'expression should not be the type of ;; the innermost presentation. #+(or) (with-output-as-presentation (t value 'expression :single-box t) (present value (presentation-type-of value) :single-box t)) (with-output-as-presentation (t value (presentation-type-of value) :single-box t) (present value 'expression)))) (with-drawing-options (t :ink +olivedrab+) (cond ((null values) #+NIL (format t "No values.~%")) ((= 1 (length values)) (present-value (first values)) (fresh-line)) (t (do* ((i 0 (1+ i)) (items values (rest items)) (object (first items) (first items))) ((null items)) (with-drawing-options (t :ink +limegreen+) (with-text-style (t (make-text-style nil :italic :small)) (format t "~A " i))) (present-value object) (fresh-line))))))) (defun shuffle-specials (form values) (setf +++ ++ ++ + + form /// // // / / values *** ** ** * * (first values))) ;;; The background evaluation feature is neat, but there are thread ;;; safety issues doing output to streams, special variables have ;;; unexpected values, and input doesn't work right due to racing to ;;; read from the event queue. Sadly, I am forced to disable it by ;;; default. (defparameter *use-background-eval* nil "Perform evaluation in a background thread, which can be interrupted.") (define-command (com-eval :menu t :command-table lisp-commands) ((form 'clim:form :prompt "form")) (let ((standard-output *standard-output*) (standard-input *standard-input*) (debugger-hook *debugger-hook*) (application-frame *application-frame*)) (flet ((evaluate () (let ((- form) (*standard-output* standard-output) (*standard-input* standard-input) (*error-output* standard-output) (*debugger-hook* debugger-hook) (*application-frame* application-frame) error success) (if *use-background-eval* (unwind-protect (handler-case (prog1 (cons :values (multiple-value-list (eval form))) (setf success t)) (serious-condition (e) (setf error e) (error e))) (when (not success) (return-from evaluate (cons :error error)))) (cons :values (multiple-value-list (eval form))))))) ;; If possible, use a thread for evaluation, permitting us to ;; interrupt it. (let ((start-time (get-internal-real-time))) (destructuring-bind (result . value) (if (and *use-background-eval* clim-sys:*multiprocessing-p*) (catch 'done (let* ((orig-process (clim-sys:current-process)) (evaluating t) (eval-process (clim-sys:make-process #'(lambda () (let ((result (evaluate))) (when evaluating (clim-sys:process-interrupt orig-process #'(lambda () (throw 'done result))))))))) (unwind-protect (handler-case (loop for gesture = (read-gesture) when (and (typep gesture 'keyboard-event) (eq (keyboard-event-key-name gesture) :pause)) do (clim-sys:process-interrupt eval-process #'break)) (abort-gesture () (clim-sys:destroy-process eval-process) (cons :abort (/ (- (get-internal-real-time) start-time) internal-time-units-per-second)))) (setf evaluating nil)))) (evaluate)) (ecase result (:values (fresh-line) (shuffle-specials form value) (display-evalues value) (fresh-line)) (:error (with-text-style (t (make-text-style nil :italic nil)) (if value (with-output-as-presentation (t value 'expression) (format t "Aborted due to ~A: ~A" (type-of value) value)) (format t "Aborted for unknown reasons (possibly use of ~A)." 'break)))) (:abort (with-text-style (t (make-text-style nil :italic nil)) (format t "Aborted by user after ~F seconds." value))))))))) ;;; Some CLIM developer commands (define-command (com-show-command-table :name t :menu "Command Table" :command-table show-commands) ((table 'clim:command-table :prompt "command table") &key ;;(locally 'boolean :default nil :mentioned-default t) (show-commands 'boolean :default t)) (let ((our-tables nil) (processed-commands (make-hash-table :test #'eq))) (do-command-table-inheritance (ct table) (let ((commands nil)) (map-over-command-table-commands #'(lambda (command) (unless (gethash command processed-commands) (push command commands) (setf (gethash command processed-commands) t))) ct :inherited nil) (push (cons ct (sort commands (lambda (x y) (string-lessp (command-line-name-for-command x ct :errorp :create) (command-line-name-for-command y ct :errorp :create))))) our-tables))) (setq our-tables (nreverse our-tables)) (when show-commands ;; sure, why not? (dolist (foo our-tables) (let ((ct (car foo)) (commands (cdr foo))) (invoke-as-heading (lambda () (format t "Command table ") (with-output-as-presentation (t ct 'clim:command-table :single-box t) (princ (command-table-name ct))))) (if commands (format-items commands :printer (lambda (cmd s) (present cmd 'clim:command-name :stream s)) :move-cursor t) (note "Command table is empty.~%~%") )))))) ;;; Various Lisp goodies (define-presentation-type package () :inherit-from t) (define-presentation-method presentation-typep (object (type package)) (packagep object)) (define-presentation-method present (object (type package) stream (view textual-view) &key) (princ (package-name object) stream)) (define-presentation-method accept ((type package) stream (view textual-view) &key) (multiple-value-bind (object success) (completing-from-suggestions (stream) (loop for p in (list-all-packages) do (progn (suggest (package-name p) p) (loop for n in (package-nicknames p) do (suggest n p))))) (if success object (simple-parse-error "No package")))) (define-command (com-set-package :name t :menu t :command-table lisp-commands :provide-output-destination-keyword nil) ((p 'package)) (setf *package* p)) (define-presentation-to-command-translator set-current-package (package com-set-package lisp-commands :pointer-documentation ((object stream) (format stream "Set current package to ~A" (package-name object))) :documentation ((stream) (format stream "Set Package")) :menu t :tester ((object) (not (eql *package* object)))) (object) (list object)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/icons/0000755000175000017500000000000011347763412020612 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/icons/h.xpm0000644000175000017500000000112107706271476021572 0ustar pdmpdm/* XPM */ static char * h_xpm[] = { "16 16 15 1", " c None", ". c #707070", "+ c #E8E8E8", "@ c #FFFFFF", "# c #8C8382", "$ c #AAA5A4", "% c #5E514F", "& c #ADADAD", "* c #BAB5B5", "= c #C9C6C6", "- c #898989", "; c #636363", "> c #7C7271", ", c #6D6260", "' c #9B9493", " ......... ", " .+++++++.. ", " .+++++++.@. ", " .++##$++.@@. ", " .++%%#++....& ", " .++%%#+*=--;& ", " .++%%>,%%'+.& ", " .++%%%#%%%+.& ", " .++%%>+#%%+.& ", " .++%%#+#%%+.& ", " .++%%#+#%%+.& ", " .++%%#+#%%+.& ", " .++%%#+#%%+.& ", " .++++++++++.& ", " ............& ", " &&&&&&&&&&&& "}; cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/icons/document.xpm0000644000175000017500000000072007706271476023165 0ustar pdmpdm/* XPM */ static char * document_xpm[] = { "16 16 6 1", " c None", ". c #707070", "+ c #E8E8E8", "@ c #FFFFFF", "# c #898989", "$ c #636363", " ......... ", " .+++++++.. ", " .+++++++.@. ", " .+++++++.@@. ", " .+++++++....# ", " .++++++++##$# ", " .++++++++++.# ", " .++++++++++.# ", " .++++++++++.# ", " .++++++++++.# ", " .++++++++++.# ", " .++++++++++.# ", " .++++++++++.# ", " .++++++++++.# ", " ............# ", " ############ "}; cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/icons/folder.xpm0000644000175000017500000000077307706271476022632 0ustar pdmpdm/* XPM */ static char * folder_xpm[] = { "16 16 9 1", " c None", ". c #A0997B", "+ c #EFE5BA", "@ c #EFE3AE", "# c #ADADAD", "$ c #EDE09E", "% c #918A67", "& c #EADF93", "* c #777155", " ", " .... ", " .++++. ", ".++++++........ ", ".@@@@@@@@@@@@@.#", ".@@@@@@@@@@@@@.#", ".$$$$$$$$$$$$$.#", ".$$$$$$$$$$$$$.#", "%$$$$$$$$$$$$$%#", "%&&&&&&&&&&&&&%#", "%&&&&&&&&&&&&&%#", "*&&&&&&&&&&&&&*#", "***************#", " ###############", " ", " "}; cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/icons/object.xpm0000644000175000017500000000530607706271476022622 0ustar pdmpdm/* XPM */ static char * object_xpm[] = { "16 16 133 2", " c None", ". c #3A6A33", "+ c #40517A", "@ c #4C804C", "# c #4E824E", "$ c #589158", "% c #68A968", "& c #72BB72", "* c #6FBA6F", "= c #6CB36C", "- c #66A866", "; c #155493", "> c #538B53", ", c #64A164", "' c #74C074", ") c #7BCC7B", "! c #7ECA7E", "~ c #7AC57A", "{ c #70B970", "] c #69AE69", "^ c #1A5F9D", "/ c #1D71BD", "( c #76C276", "_ c #7BCE7B", ": c #7FD77F", "< c #83E283", "[ c #8DEF8D", "} c #8CE48C", "| c #7DD07D", "1 c #75C375", "2 c #1B68B4", "3 c #1F77CE", "4 c #2087E6", "5 c #7FD47F", "6 c #8CE88C", "7 c #98FE98", "8 c #ABFFAB", "9 c #ADFFAD", "0 c #A2F2A2", "a c #93E493", "b c #82D982", "c c #1864AB", "d c #1E72C3", "e c #2085E9", "f c #2190F9", "g c #92F492", "h c #A9FFA9", "i c #B8FFB8", "j c #BFFFBF", "k c #BDFFBD", "l c #ABF1AB", "m c #9AE99A", "n c #89E489", "o c #1660A4", "p c #1E6EBB", "q c #218EF5", "r c #FF7759", "s c #FF8E6A", "t c #FF9972", "u c #FFAA7D", "v c #FFB387", "w c #FFB483", "x c #F99B76", "y c #F88161", "z c #AE2D1D", "A c #165B9C", "B c #1B6AB4", "C c #2082DD", "D c #208AF0", "E c #FF7253", "F c #FF7F5D", "G c #FF8D65", "H c #FF9E72", "I c #FFB282", "J c #FFB988", "K c #FFB584", "L c #FF8D69", "M c #145898", "N c #1963AC", "O c #207FD8", "P c #2087EA", "Q c #FF6A4C", "R c #FF6E50", "S c #FF7757", "T c #FF8862", "U c #FF996E", "V c #FF9F73", "W c #FF9C74", "X c #FF906A", "Y c #145899", "Z c #1861A7", "` c #1F74CB", " . c #2087E9", ".. c #FF674C", "+. c #FF694C", "@. c #FF6D52", "#. c #FF7A5A", "$. c #FF8A65", "%. c #FF966F", "&. c #FF9870", "*. c #FF946E", "=. c #1660A6", "-. c #1C6CBA", ";. c #2080DD", ">. c #FD674C", ",. c #FF7553", "'. c #FF8B64", "). c #FD906B", "!. c #1968B4", "~. c #1F77C6", "{. c #EB6048", "]. c #F1624A", "^. c #FB674C", "/. c #FF7353", "(. c #FD8061", "_. c #F17859", ":. c #1A70C0", "<. c #DC5943", "[. c #E15B44", "}. c #E65E47", "|. c #EB614A", "1. c #F4634A", "2. c #F6644B", "3. c #ED634B", "4. c #E45D46", "5. c #DA5740", "6. c #DA5842", "7. c #D95841", "8. c #DC5942", "9. c #E35C45", "0. c #E65E46", "a. c #E05B43", "b. c #DF5942", " . . . . . . . . ", " + @ # $ % & * = - . ", " + ; > , ' ) ! ~ { ] . ", " + ^ / ( _ : < [ } | 1 . ", " + 2 3 4 5 6 7 8 9 0 a b . ", " + c d e f g h i j k l m n . ", " + o p e q r s t u v w x y z ", " + A B C D E F G H I J K L z ", " + M N O P Q R S T U V W X z ", " + Y Z ` ...+.@.#.$.%.&.*.z ", " + =.-.;.>.....Q ,.'.&.).z ", " + !.~.{.].^...../.(._.z ", " + :.<.[.}.|.1.2.3.4.z ", " + 5.6.7.8.9.0.a.b.z ", " z z z z z z z z ", " "}; cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/icons/c.xpm0000644000175000017500000000114007706271476021566 0ustar pdmpdm/* XPM */ static char * c_xpm[] = { "16 16 16 1", " c None", ". c #707070", "+ c #E8E8E8", "@ c #FFFFFF", "# c #B1B2B9", "$ c #ADADAD", "% c #D5D6D8", "& c #55596B", "* c #43475B", "= c #898989", "- c #636363", "; c #7A7C8A", "> c #9EA0A9", ", c #C3C4C9", "' c #676A7A", ") c #8C8E9A", " ......... ", " .+++++++.. ", " .+++++++.@. ", " .+++++++.@@. ", " .++++###....$ ", " .++%&****==-$ ", " .++&**;&**%.$ ", " .+#**>+%#++.$ ", " .+#**#+++++.$ ", " .+,**;+;*;,.$ ", " .++'*****&+.$ ", " .++%)***)%+.$ ", " .++++++++++.$ ", " .++++++++++.$ ", " ............$ ", " $$$$$$$$$$$$ "}; cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/icons/script.xpm0000644000175000017500000000075407706271476022662 0ustar pdmpdm/* XPM */ static char * script_xpm[] = { "16 16 8 1", " c None", ". c #514C35", "+ c #7C734C", "@ c #E0D29D", "# c #60593C", "$ c #D8C98C", "% c #D1BD7D", "& c #B2A46E", " ........... ", " .+.@@@@@@@@@. ", " ..#.@@@@@@@@@. ", " .+..@$@$@$@$@. ", " ...$@$@$@$@$. ", " .@$@$@$@$@. ", " .$@$$$@$$$. ", " .$$$@$$$@$. ", " .$$$$$$$$$. ", " .$$$$$$$$$. ", " ...$%$$$%$$$. ", " .+..%$%$%$%$%. ", " ..#.&%&%&%&%&. ", " .+.&&&&&&&&&. ", " ........... ", " "}; cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/icons/video.xpm0000644000175000017500000000410407706271476022455 0ustar pdmpdm/* XPM */ static char * video_xpm[] = { "16 16 93 2", " c None", ". c #686868", "+ c #76A34B", "@ c #76A349", "# c #515151", "$ c #4A4A4A", "% c #444444", "& c #494949", "* c #3C3C3C", "= c #676767", "- c #666666", "; c #656565", "> c #626262", ", c #5D5D5D", "' c #565656", ") c #4F4F4F", "! c #484848", "~ c #414141", "{ c #3B3B3B", "] c #373737", "^ c #646464", "/ c #616161", "( c #5B5B5B", "_ c #555555", ": c #4E4E4E", "< c #464646", "[ c #404040", "} c #3A3A3A", "| c #323232", "1 c #9FCAD2", "2 c #A4CED5", "3 c #A6D1D7", "4 c #AAD5DA", "5 c #A1CBD3", "6 c #A1CCD3", "7 c #343434", "8 c #313131", "9 c #303030", "0 c #5C5C5C", "a c #A9D4D9", "b c #AED9DC", "c c #B1DBDE", "d c #B2DDDF", "e c #B1DCDE", "f c #ACD7DB", "g c #2E2E2E", "h c #5F5F5F", "i c #595959", "j c #535353", "k c #ADD7DB", "l c #B0DBDD", "m c #B0DADD", "n c #A5CFD6", "o c #9EC9D2", "p c #2F2F2F", "q c #575757", "r c #93BDCA", "s c #9DC7D0", "t c #A0CBD3", "u c #99C3CE", "v c #8FB9C8", "w c #3F3F3F", "x c #8DB7C6", "y c #8FB9C7", "z c #88B3A4", "A c #7EAA72", "B c #7DA96E", "C c #84AF98", "D c #8CB6C4", "E c #76A34E", "F c #76A34A", "G c #7DA972", "H c #353535", "I c #363636", "J c #76A34D", "K c #333333", "L c #2D2D2D", "M c #383838", "N c #434343", "O c #4D4D4D", "P c #A8D3D8", "Q c #A5D0D6", "R c #ABD6DA", "S c #9AC5CF", "T c #AFDADD", "U c #B0DBDE", "V c #ACD6DB", "W c #9BC5CF", "X c #545454", "Y c #5A5A5A", "Z c #9DC7D1", "` c #9DC8D1", " . c #92BDCA", " . . . + + @ @ @ @ @ # $ % ", " . . @ @ @ @ @ @ @ & * ", " . . = - ; > , ' ) ! ~ { ] ", " . - ^ / ( _ : < [ } | ", " - ; > 1 2 3 4 3 5 6 7 8 9 ", " ^ 0 a b c d e f 4 8 g ", " h i j 5 k l m f n o p g g ", " q & r s t o u r v g 9 ", " : < w x y z A B C D g 9 | ", " % ] E F @ @ @ @ G 9 H ", " * I 8 @ @ @ @ @ @ J K ] { ", " H g L L g g 9 | H M N ", " 8 g g L g p 8 K ] { [ < O ", " g g o P Q 3 R 4 S $ q ", " L g 9 3 e T T U V W X Y h ", " g | Z P 4 f 3 ` ., ^ "}; cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/icons/pyramid.xpm0000644000175000017500000000306507706271476023021 0ustar pdmpdm/* XPM */ static char * pyramid_xpm[] = { "16 16 81 1", " c None", ". c #C6C7C9", "+ c #767E8F", "@ c #A5A8AF", "# c #D5D5D5", "$ c #B2B4B9", "% c #476285", "& c #265F9D", "* c #315079", "= c #CBCBCD", "- c #8D939F", "; c #3D6797", "> c #3D85D0", ", c #286DB7", "' c #215894", ") c #7B8493", "! c #DADADA", "~ c #68788F", "{ c #3F76AF", "] c #509BE6", "^ c #2B70BA", "/ c #2C4F7B", "( c #C6C6C8", "_ c #B4B7BC", ": c #4A678C", "< c #4481BE", "[ c #529EEA", "} c #3E84CD", "| c #225A96", "1 c #717B8F", "2 c #9299A6", "3 c #3F6C9D", "4 c #4686C6", "5 c #4E98E3", "6 c #2A6FB8", "7 c #274D7B", "8 c #BEBFC2", "9 c #949596", "0 c #3A6799", "a c #367EC8", "b c #225B98", "c c #67758A", "d c #949494", "e c #415C7D", "f c #4994DF", "g c #254E7F", "h c #B7B9BE", "i c #9A9A9A", "j c #666D7B", "k c #4889CB", "l c #337AC4", "m c #225B99", "n c #5D6D86", "o c #919398", "p c #345F8E", "q c #4690DB", "r c #224E82", "s c #ADB0B6", "t c #D3D3D4", "u c #40587B", "v c #2762A0", "w c #2566AC", "x c #286DAE", "y c #516581", "z c #6F7686", "A c #255083", "B c #215085", "C c #214F85", "D c #263D61", "E c #C7C8CA", "F c #CBCBCC", "G c #A9ACB2", "H c #C5C8D1", "I c #C9CCD4", "J c #CDD0D7", "K c #CFD1D9", "L c #D7D9DF", "M c #D9DBE1", "N c #DEDFE4", "O c #DFE1E5", "P c #E8E9EC", " ", " .+@ ", " #$%&*= ", " #-;>,')! ", " =~{]^,,/( ", " #_:<[},,,|1# ", "#234[56,,,,78 ", "90[[[a,,,,,bc# ", "de[[f,,,,,,,gh ", "ijk[l,,,,,,,mn# ", " opq,,,,,,,,,rs!", " tuvw,,,,,,,,xy#", " zABBBBBBBBBCDE", " FGHIJKLLMMNOP#", " ", " "}; cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/icons/text.xpm0000644000175000017500000000073307706271476022337 0ustar pdmpdm/* XPM */ static char * text_xpm[] = { "16 16 7 1", " c None", ". c #707070", "+ c #E8E8E8", "@ c #565656", "# c #FFFFFF", "$ c #898989", "% c #636363", " ......... ", " .+++++++.. ", " .++@@@@@.#. ", " .+++++++.##. ", " .+@@@@@@....$ ", " .++++++++$$%$ ", " .+@@@@@@@@+.$ ", " .++++++++++.$ ", " .+@@@@@@@@+.$ ", " .++++++++++.$ ", " .+@@@@@@@@+.$ ", " .++++++++++.$ ", " .+@@@@@@@@+.$ ", " .++++++++++.$ ", " ............$ ", " $$$$$$$$$$$$ "}; cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/icons/lambda.xpm0000644000175000017500000000233307706271476022571 0ustar pdmpdm/* XPM */ static char * lambda_xpm[] = { "16 16 58 1", " c None", ". c #707070", "+ c #E8E8E8", "@ c #E2DADA", "# c #D53D4E", "$ c #D53E4F", "% c #E3DBDD", "& c #FFFFFF", "* c #D8A6AB", "= c #D98992", "- c #D77B84", "; c #E6E7E6", "> c #E5E3E3", ", c #E4E4E5", "' c #D0626E", ") c #E5E7E6", "! c #ADADAD", "~ c #E5E5E6", "{ c #D34757", "] c #E1CBCD", "^ c #898989", "/ c #636363", "( c #DFC5C7", "_ c #D90A22", ": c #DA808A", "< c #E7E7E7", "[ c #D96674", "} c #D61128", "| c #D05865", "1 c #E6E6E6", "2 c #E2D6D6", "3 c #D7132A", "4 c #D86572", "5 c #D6808B", "6 c #DFC6C9", "7 c #D80B21", "8 c #E0C5C8", "9 c #E1CACD", "0 c #D97E88", "a c #E7E8E8", "b c #E3E0E2", "c c #D52337", "d c #D74C5B", "e c #CF5865", "f c #E0DBDD", "g c #D6929A", "h c #DA9BA2", "i c #D9081F", "j c #DAAEB4", "k c #E6E7E8", "l c #D5192D", "m c #D22D40", "n c #DDBDC1", "o c #DEA7AD", "p c #E6E4E4", "q c #E4E3E3", "r c #DC98A0", "s c #DEC5C7", " ......... ", " .+++++++.. ", " .+@#$%++.&. ", " .+*=-=;+.&&. ", " .+>;,')+....! ", " .+++~{]++^^/! ", " .+++(_:<+++.! ", " .++<[}|1+++.! ", " .++23456+++.! ", " .++:7890aa+.! ", " .+bcd<1efg+.! ", " .+hij c #707070", ", c #D4D4D4", "' c #E3E3E3", ") c #F0F0F0", "! c #F2F2F2", "~ c #F1F1F1", "{ c #EBEBEB", "] c #D3D3D3", "^ c #B1B1B1", "/ c #5D5D5D", "( c #D6D6D6", "_ c #DBDBDB", ": c #EEEEEE", "< c #F0EDED", "[ c #F2D7D7", "} c #EDEDED", "| c #C0C0C0", "1 c #A1A1A1", "2 c #565656", "3 c #E4E4E4", "4 c #FBF4F4", "5 c #FEFEFE", "6 c #FEE5E5", "7 c #FF3D3D", "8 c #FFFFFF", "9 c #FDFAFA", "0 c #D0D0D0", "a c #B5B5B5", "b c #9D9D9D", "c c #E5E5E5", "d c #EFEFEF", "e c #FE7A7A", "f c #FFB8B8", "g c #FFE5E5", "h c #FF7A7A", "i c #C3C3C3", "j c #A4A4A4", "k c #F1EFEF", "l c #FEADAD", "m c #FF5050", "n c #FF5757", "o c #FDADAD", "p c #E5E3E3", "q c #C9C9C9", "r c #ABABAB", "s c #FAFAFA", "t c #FECCCC", "u c #FF4646", "v c #FDFDFD", "w c #ACACAC", "x c #E0E0E0", "y c #EDEAEA", "z c #FE7979", "A c #FE4444", "B c #FF8787", "C c #FF4444", "D c #DFDDDD", "E c #C5C5C5", "F c #D7D7D7", "G c #FFE9E9", "H c #FFEAEA", "I c #FEB0B0", "J c #BEBEBE", "K c #A7A7A7", "L c #DCDCDC", "M c #FBFBFB", "N c #FDE9E9", "O c #FE5D5D", "P c #FAE6E6", "Q c #F9F9F9", "R c #CACACA", "S c #B3B3B3", "T c #A0A0A0", "U c #B2B2B2", "V c #E8E8E8", "W c #B9B9B9", "X c #A3A3A3", "Y c #BABABA", "Z c #CBCBCB", "` c #D2D2D2", " . c #C8C8C8", ".. c #B8B8B8", "+. c #A9A9A9", " . + + @ + + @ ", " # $ % & & & * = - ; # ", " # > , ' ) ! ! ~ { ] ^ / + ", " @ ( _ { : < [ < } = | 1 2 ", "# 3 3 & 4 5 6 7 6 8 9 0 a b @ ", "+ c ! d e f g 7 g f h _ i j + ", "+ c ! k l m n 7 n m o p q r + ", "+ ' ! ) s t u 7 u t v 3 q w + ", "# x : y z A B 7 B C z D E w + ", "$ F & * o G 6 7 6 H I ( J K + ", ". , 0 L : M N O P Q { R S T + ", " + U i ( = V * 3 L 0 W X 2 ", " + / X Y Z ` , ` ...j / + ", " + + T +.^ S ^ r 1 + + ", " + + + + + + + ", " "}; cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/icons/audio.xpm0000644000175000017500000000073407706271476022455 0ustar pdmpdm/* XPM */ static char * audio_xpm[] = { "16 16 7 1", " c None", ". c #707070", "+ c #E8E8E8", "@ c #FFFFFF", "# c #000000", "$ c #898989", "% c #636363", " ......... ", " .+++++++.. ", " .+++++++.@. ", " .++++++#.@@. ", " .++++++#....$ ", " .++++++#+$$%$ ", " .++++++#+++.$ ", " .++++++#+++.$ ", " .++++++#+++.$ ", " .++++###+++.$ ", " .+++####+++.$ ", " .+++####+++.$ ", " .++++##++++.$ ", " .++++++++++.$ ", " ............$ ", " $$$$$$$$$$$$ "}; cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/icons/design.xpm0000644000175000017500000000103207706271476022615 0ustar pdmpdm/* XPM */ static char * design_xpm[] = { "16 16 11 1", " c None", ". c #59534B", "+ c #DEE7B5", "@ c #FFB59C", "# c #ADADAD", "$ c #C3C99F", "% c #E5A490", "& c #DED6AD", "* c #FF8C84", "= c #C6BE9B", "- c #E57D79", " ", " .............. ", " .+++.@@@@@@@@.#", " .+++.@@@@@@@@.#", " .+++.@@@@@@@@.#", " .+++.@@@@@@@@.#", " .+++.@@@@@@@@.#", " .+++.@@@@@@@@.#", " .$$$.%%%%%%%%.#", " ..............#", " .&&&.********.#", " .&&&.********.#", " .&&&.********.#", " .===.--------.#", " ..............#", " ##############"}; cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/icons/image.xpm0000644000175000017500000000103107706271476022425 0ustar pdmpdm/* XPM */ static char * image_xpm[] = { "16 16 11 1", " c None", ". c #707070", "+ c #E8E8E8", "@ c #AFC2D6", "# c #FFFFFF", "$ c #B2CFE8", "% c #ADADAD", "& c #898989", "* c #636363", "= c #8FAD90", "- c #89BF8B", " ......... ", " .+++++++.. ", " .+@@@@@@.#. ", " .+@@@@@@.##. ", " .+@@@@$@....% ", " .+@$@@@@$&&*% ", " .+$@$@$@$@+.% ", " .+@$@$@$@$+.% ", " .+$$$$$$$$+.% ", " .+$$$====$+.% ", " .+========+.% ", " .+=-=-=-=-+.% ", " .+--------+.% ", " .++++++++++.% ", " ............% ", " %%%%%%%%%%%% "}; cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/icons/simple-object.xpm0000644000175000017500000000070607706271476024110 0ustar pdmpdm/* XPM */ static char * simple_object_xpm[] = { "16 16 5 1", " c None", ". c #6D6D6D", "+ c #FFFFFF", "@ c #C9C9C9", "# c #E2E2E2", " ", " ", " ", " ....... ", " ..+++++. ", " .@.+++++. ", " .@ ....... ", " .@@.#####. ", " .@@.#####. ", " .@@.#####. ", " .@.#####. ", " ..#####. ", " ....... ", " ", " ", " "}; cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/icons/invalid.xpm0000644000175000017500000000275207706271476023004 0ustar pdmpdm/* XPM */ static char * invalid_xpm[] = { "16 16 76 1", " c None", ". c #484848", "+ c #4A4A4A", "@ c #494949", "# c #474747", "$ c #4B4B4B", "% c #E1E1E1", "& c #E9E9E9", "* c #E7E7E7", "= c #DFDFDF", "- c #D5D5D5", "; c #505050", "> c #707070", ", c #D4D4D4", "' c #E3E3E3", ") c #F0F0F0", "! c #F2F2F2", "~ c #F1F1F1", "{ c #EBEBEB", "] c #D3D3D3", "^ c #B1B1B1", "/ c #5D5D5D", "( c #D6D6D6", "_ c #DBDBDB", ": c #EEEEEE", "< c #EFEFEF", "[ c #DCDCDC", "} c #C0C0C0", "| c #A1A1A1", "1 c #565656", "2 c #E4E4E4", "3 c #F0C5C5", "4 c #F5B4B4", "5 c #F3DEDE", "6 c #F1DCDC", "7 c #F2B1B1", "8 c #E9BFBF", "9 c #D0D0D0", "0 c #B5B5B5", "a c #9D9D9D", "b c #E5E5E5", "c c #F0DBDB", "d c #FF3D3D", "e c #FD5151", "f c #F4CACA", "g c #EED8D8", "h c #C3C3C3", "i c #A4A4A4", "j c #F6B5B5", "k c #C9C9C9", "l c #ABABAB", "m c #ACACAC", "n c #E0E0E0", "o c #EDEDED", "p c #FC6565", "q c #F98D8D", "r c #C5C5C5", "s c #D7D7D7", "t c #F1B1B1", "u c #FA7979", "v c #EEADAD", "w c #BEBEBE", "x c #A7A7A7", "y c #E8E8E8", "z c #CACACA", "A c #B3B3B3", "B c #A0A0A0", "C c #B2B2B2", "D c #B9B9B9", "E c #A3A3A3", "F c #BABABA", "G c #CBCBCB", "H c #D2D2D2", "I c #C8C8C8", "J c #B8B8B8", "K c #A9A9A9", " .++@++@ ", " #$%&&&*=-;# ", " #>,')!!~{]^/+ ", " @(_{:)~<&[}|1 ", "#22&345~67890a@ ", "+b! c #968974", ", c #94866E", "' c #8F8168", ") c #877A63", "! c #4E463A", "~ c #5D5954", "{ c #545049", "] c #6F685C", "^ c #827867", "/ c #9A8D76", "( c #A39377", "_ c #A49376", ": c #9F8E70", "< c #948469", "[ c #8B7C64", "} c #4E4639", "| c #5D5953", "1 c #5B564E", "2 c #6D6558", "3 c #9C8F7A", "4 c #A4947A", "5 c #AB997B", "6 c #B29E7C", "7 c #BEA883", "8 c #B8A37F", "9 c #A69374", "0 c #9C8B70", "a c #676157", "b c #766D5F", "c c #837865", "d c #A9997D", "e c #BAA685", "f c #CBB48C", "g c #D5BC91", "h c #D6BD92", "i c #CAB38C", "j c #BBA785", "k c #AD9C80", "l c #4E473B", "m c #5D5952", "n c #615B51", "o c #70675A", "p c #847966", "q c #8D7F67", "r c #C3AE8A", "s c #D4BB92", "t c #DBC195", "u c #DFC599", "v c #DEC498", "w c #CEB892", "x c #C1AD8D", "y c #B6A68B", "z c #5D5851", "A c #5D574E", "B c #6C6456", "C c #847967", "D c #8B7D66", "E c #AC9A7C", "F c #B4A07E", "G c #C3AD88", "H c #C1AC8A", "I c #B7A587", "J c #AC9D85", "K c #655D50", "L c #59544B", "M c #675F53", "N c #7E7462", "O c #887B66", "P c #A9987C", "Q c #AE9C7D", "R c #B29E7D", "S c #B8A482", "T c #C0AB89", "U c #C3AF8C", "V c #C1AE8F", "W c #B4A58C", "X c #565048", "Y c #625B50", "Z c #7C7261", "` c #857967", " . c #A5967B", ".. c #A7967A", "+. c #B09E80", "@. c #B6A384", "#. c #B9A789", "$. c #B9A88C", "%. c #B4A58D", "&. c #655D51", "*. c #5D5850", "=. c #565149", "-. c #5F584E", ";. c #756B5C", ">. c #A5977F", ",. c #A5977E", "'. c #A8987E", "). c #AC9C81", "!. c #B2A186", "~. c #B7A78C", "{. c #B7A78D", "]. c #B6A78E", "^. c #655E52", "/. c #5E584E", "(. c #6B6357", "_. c #7E7463", ":. c #A4967F", "<. c #A99A81", "[. c #B1A188", "}. c #B7A78E", "|. c #B4A791", "1. c #655E54", "2. c #5D574D", "3. c #665F54", "4. c #726A5C", "5. c #998E7C", "6. c #9D917D", "7. c #A3967F", "8. c #A59780", "9. c #A59881", "0. c #A99C86", "a. c #AFA28C", "b. c #A59A88", "c. c #655F55", "d. c #6D665A", "e. c #8F8575", "f. c #928877", "g. c #968B7A", "h. c #9A8F7E", "i. c #9F9481", "j. c #A09583", "k. c #9C9281", "l. c #958C7D", "m. c #655F57", "n. c #8D8476", "o. c #8E8577", "p. c #8F8677", "q. c #948B7B", "r. c #968D7E", "s. c #91897B", "t. c #90887C", "u. c #656059", "v. c #655F56", "w. c #656058", "x. c #65605A", " . + @ # $ % % % ", " & * = - ; > , ' ) ! ", " ~ { ] ^ / ( _ : < [ } ", " | 1 2 3 4 5 6 7 8 9 0 ! ", " | a b c d e f g h i j k l ", " m n o p q r s t u v w x y % ", " z A B C D E F 8 7 G H I J K ", " z L M N O P Q R S T U V W K ", " z X Y Z ` ...5 +.@.#.$.%.&. ", " *.=.-.;.C >.,.'.).!.~.{.].^. ", " A /.(._.:.>.,.,.<.[.}.|.1. ", " 2.3.4.5.6.7.8.9.0.a.b.c. ", " 2.d.e.f.g.h.i.j.k.l.m. ", " A n.o.n.p.q.r.s.t.u. ", " m.v.m.m.m.m.w.x. ", " "}; cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/icons/up-folder.xpm0000644000175000017500000000102207706271476023240 0ustar pdmpdm/* XPM */ static char * up_folder_new_xpm[] = { "16 16 10 1", " c None", ". c #6D9EB0", "+ c #BDE8FC", "@ c #B0E5FD", "# c #000000", "$ c #BCBCBC", "% c #9ADBFD", "& c #518598", "* c #8CD3FB", "= c #3A606D", " ", " .... ", " .++++. ", ".++++++........ ", ".@@@#@@@@@@@@@.$", ".@@###@@@@@@@@.$", ".%#%#%#%%%%%%%.$", ".%%%#%%%%%%%%%.$", "&%%%#%%%%%%%%%&$", "&****#********&$", "&*****#####***&$", "=*************=$", "===============$", " $$$$$$$$$$$$$$$", " ", " "}; cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/util.lisp0000644000175000017500000005436311345155772021362 0ustar pdmpdm(in-package :clim-listener) ;;; Miscellaneous utilities, UI tools, gross hacks, and non-portable bits. ;;; (C) Copyright 2003 by Andy Hefner (hefner1@umbc.edu) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;; multiple-value-or, ugh. Normal OR drops values except from the last form. (defmacro mv-or (&rest forms) (if (null forms) nil (let ((tmp (gensym))) `(let ((,tmp (multiple-value-list ,(first forms)))) (if (first ,tmp) (values-list ,tmp) (mv-or ,@(rest forms))))))) (defun directoryp (path) "Determine if PATH designates a directory" #+allegro (excl:file-directory-p path) #-allegro (flet ((f (x) (if (eq x :unspecific) nil x))) (if (or (f (pathname-name path)) (f (pathname-type path))) nil path))) (defun getenv (var) (or #+cmu (cdr (assoc var ext:*environment-list*)) #+scl (cdr (assoc var ext:*environment-list* :test #'string=)) #+sbcl (sb-ext:posix-getenv var) #+lispworks (lw:environment-variable var) #+openmcl (ccl::getenv var) #+clisp (ext:getenv var) nil)) (defun change-directory (pathname) "Ensure that the current directory seen by RUN-PROGRAM has changed, and update *default-pathname-defaults*" #+CMU (unix:unix-chdir (namestring pathname)) #+scl (unix:unix-chdir (ext:unix-namestring pathname)) #+clisp (ext:cd pathname) #+sbcl (sb-posix:chdir (namestring pathname)) (setf *default-pathname-defaults* pathname)) (defun resolve-stream-designator (desi default) (if (eq desi t) default (or desi default))) ;;; LIST-DIRECTORY is a wrapper for the CL DIRECTORY function. Work ;;; around various issues which may arise, such as: ;;; * Don't error in response to broken symlinks (as cl:truename might) ;;; * Ideally, don't return truenames at all. ;;; * Don't error in response to garbage filenames not conforming to ;;; the preferred encoding for filenames #+(or cmu scl) (defun list-directory (pathname) (directory pathname :truenamep nil)) #+sbcl (defun list-directory (pathname) ;; Sooner or later, I'm putting all the sb-posix junk back in. ;; I *really* don't like truenames. (directory pathname)) #+openmcl (defun list-directory (pathname) (directory pathname :directories t :follow-links nil)) #+ALLEGRO (defun list-directory (pathname) (directory pathname :directories-are-files nil)) ;; Fallback to ANSI CL #-(or cmu scl sbcl openmcl allegro) (defun list-directory (pathname) (directory pathname)) ;;; Calls LIST-DIRECTORY and appends the subdirectories of the directory ;;; PATHNAME to the output of LIST-DIRECTORY if PATHNAME is a wild pathname. (defun list-directory-with-all-direct-subdirectories (pathname) (let ((file-list (list-directory pathname))) (if (wild-pathname-p pathname) (nconc file-list (delete-if (lambda (directory) (member directory file-list :test #'equal)) (delete-if-not #'directoryp (list-directory (gen-wild-pathname (strip-filespec pathname)))))) file-list))) ;;; Native namestring. cl:namestring is allowed to do anything it wants to ;;; the filename, and some lisps do (CCL, for instance). (defun native-namestring (pathname-designator) #+sbcl (sb-ext:native-namestring pathname-designator) #+openmcl (ccl::native-untranslated-namestring pathname-designator) #-(or sbcl openmcl) (namestring pathname-designator)) (defun native-enough-namestring (pathname &optional (defaults *default-pathname-defaults*)) (native-namestring (enough-namestring pathname defaults))) ;;; A farce of a "portable" run-program, which grows as I need options from ;;; the CMUCL run-program. ;;; This ought to change the current directory to *default-pathname-defaults*.. ;;; (see above) (defun run-program (program args &key (wait t) (output *standard-output*) (input *standard-input*)) #+(or CMU scl) (ext:run-program program args :input input :output output :wait wait) #+SBCL (sb-ext:run-program program args :input input :search T :output output :wait wait) #+lispworks (system:call-system-showing-output ; Contributed by Neonsquare. (format nil "~A~{ ~A~}" program args) ; I am uneasy about shell quoting issues here.. :shell-type "/bin/sh" :output-stream output :wait wait) #+clisp (ext:run-program program :arguments args :wait wait) #+openmcl (ccl:run-program program args :input input :output output :wait wait) #-(or CMU scl SBCL lispworks clisp openmcl) (format t "~&Sorry, don't know how to run programs in your CL.~%")) ;;;; CLIM/UI utilities (defmacro bold ((stream) &body body) `(with-text-face (,stream :bold) ,@body)) (defmacro italic ((stream) &body body) `(with-text-face (,stream :italic) ,@body)) (defmacro bordering ((stream shape) &body body) `(surrounding-output-with-border (,stream :shape ,shape :move-cursor t) ,@body)) (defmacro underlining ((stream) &body body) `(surrounding-output-with-border (,stream :shape :underline :move-cursor nil) ,@body)) (defun note (string &rest args) (let ((stream *query-io*)) (italic (stream) (with-text-family (stream :sans-serif) (fresh-line stream) (apply #'format *query-io* string args) (fresh-line stream))))) (defun vertical-gap (stream &optional (fraction 3)) (when (eq stream t) (setf stream *standard-output*)) (stream-increment-cursor-position stream 0 (truncate (/ (text-style-ascent (medium-text-style stream) stream) fraction)))) (defun invoke-as-heading (cont &optional (ink +royal-blue+)) (with-drawing-options (t :ink ink :text-style (make-text-style :sans-serif :bold nil)) (fresh-line) (underlining (t) (funcall cont)) (fresh-line) (vertical-gap t))) (defun heading (control-string &rest args) (invoke-as-heading (lambda () (apply 'format t control-string args)))) (defun indent-to (stream x &optional (spacing 0) ) "Advances cursor horizontally to coordinate X. If the cursor is already past this point, increment it by SPACING, which defaults to zero." (stream-increment-cursor-position stream (if (> (stream-cursor-position stream) x) spacing (- x (stream-cursor-position stream))) 0)) (defun invoke-and-center-output (stream-pane continuation &key (horizontally t) (vertically t) (hpad 0) (vpad 0)) (let ((record (with-output-to-output-record (stream-pane) (funcall continuation)))) (with-bounding-rectangle* (sx0 sy0 sx1 sy1) (sheet-region stream-pane) (with-bounding-rectangle* (rx0 ry0 rx1 ry1) (bounding-rectangle record) (setf (output-record-position record) (values (if horizontally (+ rx0 (/ (- (- sx1 sx0) (- rx1 rx0)) 2)) (+ rx0 hpad)) (if vertically (+ ry0 (/ (- (- sy1 sy0) (- ry1 ry0)) 2)) (+ ry0 vpad)))))) (add-output-record record (stream-output-history stream-pane)) (repaint-sheet stream-pane record))) ;;; Pathnames are awful. (defun gen-wild-pathname (pathname) "Build a pathname with appropriate :wild components for the directory listing." (merge-pathnames pathname (make-pathname :name :wild :type :wild :version :wild))) (defun strip-filespec (pathname) "Removes name, type, and version components from a pathname." (make-pathname :name nil :type nil :version nil #+scl :query #+scl nil :defaults pathname)) (defun parent-directory (pathname) "Returns a pathname designating the directory 'up' from PATHNAME" (let ((dir (pathname-directory pathname ))) ;(if (probe-file pathname) ; pathname (when (and (eq (first dir) :absolute) (rest dir)) ;; merge-pathnames merges :back, but not :up (strip-filespec (merge-pathnames (make-pathname :directory '(:relative :back)) (truename pathname)))))) (defun coerce-to-directory (pathname) "Convert a pathname with name/version into a pathname with a similarly-named last directory component. Used for user input that lacks the final #\\/." (if (directoryp pathname) pathname (merge-pathnames (make-pathname :directory (if (pathname-name pathname) (list :relative (file-namestring pathname)) '(:relative))) (strip-filespec pathname)))) ;;;; Abbreviating item formatter ;;; Doesn't work as well as I'd like, due to the table formatter not sizing ;;; columns as anticipated. (defparameter *abbreviating-minimum-items* 6 "Minimum number of items needed to invoke abbreviation. This must be at least one.") (defparameter *abbreviating-outlier-threshold* 2.0 "Number of standard deviations beyond the mean needed to invoke abbreviation.") (defparameter *abbreviating-minimum-ratio* 1.2 "A minimum ratio of item width to the mean width, below which abbreviation will not be invoked. This is a safeguard to treat very uniform inputs more sanely, where the test against the standard deviation might behave undesirably.") (defparameter *abbreviating-maximum-cutoff* 1.8 "A maximum ratio of item width to mean width, beyond which abbreviation will always be invoked. This is useful to handle cases where one extreme outlier throws the standard deviation all out of whack.") (defun text-output-record-style (record) "Returns the text style used in RECORD, a text-displayed-output-record." (climi::graphics-state-text-style (first (slot-value record 'climi::strings)))) (defun find-text-record (record) "If RECORD contains exactly one text-displayed-output-record, we can abbreviate it. Otherwise, give up. Returns a string containing the contents of the record, and a text style." (declare (optimize (debug 3) (speed 1) (safety 3))) (let ((count 0) text-style result) (labels ((walk (record) (typecase record (climi::compound-output-record (map-over-output-records #'walk record)) (text-displayed-output-record (setf result record) (setf text-style (text-output-record-style record)) (incf count))))) (walk record) (values (if (= count 1) result nil) (or text-style (medium-text-style (slot-value record 'climi::medium))))))) (defun abbrev-guess-pos (medium string text-style desired-width start end) "Makes a guess where to split STRING between START and END in order to fit within WIDTH. Returns the ending character index." (let* ((length (- end start)) (actual-width (text-size medium string :text-style text-style :start start :end end)) (pixels-per-char (/ actual-width length)) (guess (truncate (/ desired-width pixels-per-char)))) (when (< actual-width desired-width) ; This almost certainly shouldn't happen. (return-from abbrev-guess-pos end)) ; But it could. (+ start guess))) ;; FIXME: I can do a bit better than this. ;; I'd like to use this only as a fallback, eventually. (defun abbreviate-string (medium string text-style max-width) "Returns an abbreviated version of STRING hopefully less than MAX-WIDTH, as it would be displayed on MEDIUM using TEXT-STYLE" (let* ((ellipsis-width (text-size medium "..." :text-style text-style)) (working-width (- max-width ellipsis-width))) (when (<= working-width 0) ; weird, just give up. (return-from abbreviate-string string)) ;; FIXME: I was planning to do several stages of refining the guess, but I got lazy.. ;; Now that I've thought about it, this sort of guesswork with counting text-sizes is ;; pretty disgusting anyway, and I ought to just be counting character sizes, and assume ;; that text-size isn't just somehow magically faster than doing it myself. ;; so.. FIXME! (concatenate 'string (subseq string 0 (abbrev-guess-pos medium string text-style working-width 0 (length string))) "..."))) (defun abbreviate-record (stream record width abbreviator) "Attempts to abbreviate the text contained in an output RECORD on STREAM to fit within WIDTH, using the function ABBREVIATOR to produce a shortened string." (declare (optimize (debug 3))) (multiple-value-bind (text-record text-style) (find-text-record record) (when text-record (multiple-value-bind (x y) (output-record-position text-record) (let* ((parent (output-record-parent text-record)) (medium (slot-value text-record 'medium)) (abbreviation (funcall abbreviator medium (text-displayed-output-record-string text-record) text-style (- width (- (bounding-rectangle-width record) (bounding-rectangle-width text-record)))))) (delete-output-record text-record parent) (with-text-style (medium text-style) (let ((new-record (with-output-to-output-record (stream) (write-string abbreviation stream)))) (setf (output-record-position new-record) (values x y)) (add-output-record new-record parent) #+IGNORE (tree-recompute-extent parent))))))) record) (defun abbreviating-format-items (items &rest args &key stream printer presentation-type (abbreviator #'abbreviate-string) &allow-other-keys) "Similar to FORMAT-ITEMS, but abbreviates excessively long text using a function specified by :ABBREVIATOR. Abbreviate is controlled by the variables *ABBREVIATING-OUTLIER-THRESHOLD*, *ABBREVIATING-MINIMUM-RATIO*, and *ABBREVIATING-MAXIMUM-CUTOFF*." (setf stream (resolve-stream-designator stream *standard-output*)) (let* ((length (length items)) (printer (or printer (lambda (item stream) (present item presentation-type :stream stream)))) (hash (make-hash-table :test 'eq :size (truncate (* 1.5 length)))) (mean 0.0) (deviation 0.0)) (when (< length *abbreviating-minimum-items*) (apply #'format-items items args) (return-from abbreviating-format-items)) (dolist (item items) (let ((record (with-output-to-output-record (stream) (with-end-of-line-action (stream :allow) (funcall printer item stream))))) (setf (gethash item hash) record) (incf mean (bounding-rectangle-width record)))) (setf mean (/ mean length)) (maphash (lambda (key val) (declare (ignore key)) (incf deviation (expt (- mean (bounding-rectangle-width val)) 2))) hash) (unless (= length 1) (setf deviation (sqrt (/ deviation (1- length))))) (setf args (copy-list args)) (remf args :printer) (let* ((stddev-max-width (+ mean (* *abbreviating-outlier-threshold* deviation))) (ratio-max-width (* mean *abbreviating-minimum-ratio*)) (cutoff-width (* mean *abbreviating-maximum-cutoff*)) (max-width (min cutoff-width (max stddev-max-width ratio-max-width)))) ; (hef:debugf mean deviation stddev-max-width ratio-max-width max-width) (apply #'format-items items :printer (lambda (item stream) (let ((record (gethash item hash))) (when (and (> (bounding-rectangle-width record) stddev-max-width) (> (bounding-rectangle-width record) ratio-max-width)) (setf record (abbreviate-record stream record max-width abbreviator))) (stream-add-output-record stream record))) args)))) ;;; An attempt at integrating RUN-PROGRAM closer with lisp. ;;; This code creates a macro on the #! character sequence which expands ;;; to a lambda closed over a call to RUN-PROGRAM invoked the program ;;; named by the following string, ex. (#!rm :r :f "foodir") ;;; My apologies to anyone using the #! character for something useful. ;; TODO: ;; * Environment variables? ;; * Figure out what to do with the input/output streams ;; * Ability to pipe programs together, input/output redirection. ;; * Utilities for getting data in and out of unix programs through streams ;; * Pseudoterminal support (yeah, right) (defparameter *program-wait* t) ;; Disgusting hacks to make input default to nil, as CMUCL's run-program seems ;; to hang randomly unless I do that. But sometimes I'll need to really change these.. ;; ** Goddamn CMUCL's run-program likes to hang randomly even with this dumb hack. Beware.. (defparameter *run-output* t) (defparameter *run-input* nil) ;; We attempt to translate keywords and a few types of lisp objects ;; used as arguments to make program wrappers feel more "lispy". (defgeneric transform-program-arg (arg)) (defmethod transform-program-arg ((arg t)) (values (prin1-to-string arg))) (defmethod transform-program-arg ((arg string)) arg) (defmethod transform-program-arg ((arg sequence)) (values-list (map 'list #'transform-program-arg arg))) (defmethod transform-program-arg ((arg symbol)) (let ((name (string-downcase (symbol-name arg)))) (if (keywordp arg) (values (concatenate 'string (if (= 1 (length name)) "-" "--") name)) name))) ;; do some less horrible DWIM downcasing of vanilla symbols? hmm.. (defmethod transform-program-arg ((arg pathname)) (if (wild-pathname-p arg) (values-list (mapcar #'transform-program-arg (directory arg))) ;; (with-fingers-crossed ...) (values (namestring arg)))) (defun transform-program-arguments (args) (let ((list nil)) (dolist (arg args) (setf list (nconc list (multiple-value-list (transform-program-arg arg))))) list)) (defun program-wrapper (name) "Returns a closure which invokes the NAMEd program through the operating system, with some attempt to convert arguments intelligently." (lambda (&rest args) (run-program name (transform-program-arguments args) :wait *program-wait* :output (resolve-stream-designator *run-output* *standard-output*) :input nil #+NIL (resolve-stream-designator *run-input* *standard-input*)) ;; It might be useful to return the exit status of the process, but our run-program ;; wrapper doesn't (values))) (defun read-stringlet (stream) (with-output-to-string (out) (unread-char (do ((c (read-char stream) (read-char stream))) ((or (member c '(#\Space #\Tab #\Newline #\Linefeed #\Page #\Return)) ;; What..?? (multiple-value-bind (a b) (get-macro-character c) (and a (not b)))) c) (when (eql c #\\) (setf c (read-char stream))) (write-char c out)) stream))) ;;; Don't install this by default, because no one uses it. #+NIL (set-dispatch-macro-character #\# #\! #'(lambda (stream char p) (declare (ignore char p)) (let ((name (read-stringlet stream))) `(lambda (&rest args) (apply (program-wrapper ,name) args))))) ;;;; Graphing and various helpers (defparameter *min-x* -7) (defparameter *max-x* 7) (defparameter *min-y* -7) (defparameter *max-y* 7) (defparameter *graph-size* 600) (defparameter *graph-width* nil) (defparameter *graph-height* nil) (defparameter *graph-ink* +black+) (defun draw-thin-bar-graph-1 (medium function scale min max dx) (loop for i from 0 below (floor (- max min) dx) for x = min then (+ x dx) do (draw-line* medium i 0 i (* scale (funcall function x))))) (defun draw-vector-bar-graph (vector &key (stream *standard-output*) (scale-y 1) (ink +black+) (key 'identity) (start 0) (end nil)) (let ((range (- (reduce 'max vector :start start :end end :key key) 0 #+NIL (reduce 'min vector :start start :end end :key key)))) ; totally wrong (with-room-for-graphics (stream :first-quadrant t) (with-new-output-record (stream) (with-drawing-options (stream :ink ink) (unless (zerop range) (when (eql t scale-y) (setf scale-y (/ 250 range))) (draw-thin-bar-graph-1 stream (lambda (i) (funcall key (aref vector i))) scale-y start (or end (length vector)) 1))))))) ;(defun draw-coordinate-labels (stream value-min val-max stream-min stream-max) ; ; (text-size stream (format nil "~4F" value) ;; Broken - min-y/max-y aren't, in the sense that it won't clip to ;; those values. (defun draw-function-filled-graph (function &key (stream *standard-output*) (min-x *min-x*) (max-x *max-x*) (min-y *min-y*) (max-y *max-y*) size (width (or size *graph-width* *graph-size*)) (height (or size *graph-height* *graph-size*)) (ink *graph-ink*)) (with-room-for-graphics (stream :first-quadrant t) (with-new-output-record (stream) (with-drawing-options (stream :ink ink) (draw-thin-bar-graph-1 stream function (float (/ height (- max-y min-y)) 0.0f0) min-x max-x (/ (- max-x min-x) width)))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/appearance.lisp0000644000175000017500000000140311077135035022457 0ustar pdmpdm (in-package :clim-listener) ;;; Apropos (defparameter *apropos-symbol-unbound-family* :fix) (defparameter *apropos-symbol-unbound-face* :roman) (defparameter *apropos-symbol-bound-family* :fix) (defparameter *apropos-symbol-bound-face* :roman) ;;; Show Class Slots (defparameter *slot-name-ink* +black+) (defparameter *slot-type-ink* +gray50+) (defparameter *slot-initargs-ink* +red+) (defparameter *slot-initform-ink* +goldenrod3+) (defparameter *slot-readers-ink* +black+) (defparameter *slot-writers-ink* +black+) (defparameter *slot-documentation-ink* +turquoise4+) ;;; Graphing (classes and packages) (defparameter *graph-edge-ink* (make-rgb-color 0.72 0.72 0.72)) (defparameter *graph-text-style* (make-text-style :fix :roman :normal)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Listener/asdf.lisp0000644000175000017500000001353711212677253021314 0ustar pdmpdm;;; This is a lisp listener. ;;; (C) Copyright 2009 by Andy Hefner (ahefner@gmail.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-listener) ;;;; CLIM defintions for interacting with ASDF (define-command-table asdf-commands :inherit-from nil) (define-presentation-type asdf-system ()) (define-presentation-type asdf-system-definition () :inherit-from 'pathname) (defclass asdf-attribute-view (textual-view) ((ignorable-attributes :reader ignorable-attributes :initform nil :initarg :ignore) (note-unloaded :reader note-unloaded :initform nil :initarg :note-unloaded) (default-label :reader default-attr-label :initform "" :initarg :default))) (defmethod ignorable-attributes (view) nil) (defmethod note-unloaded (view) nil) (defmethod default-attr-label (view) "") (defun asdf-loaded-systems () "Retrieve a list of loaded systems from ASDF" (let (systems) (maphash (lambda (name foo.system) (declare (ignore name)) (push (cdr foo.system) systems)) asdf::*defined-systems*) systems)) (defun asdf-get-central-registry () asdf::*central-registry*) (defun asdf-registry-system-files () "Retrieve the list of unique pathnames contained within the ASDF registry folders" (remove-duplicates (remove-if-not #'pathname-name (apply #'concatenate 'list (mapcar (lambda (form) (list-directory (merge-pathnames (eval form) #p"*.asd"))) (asdf-get-central-registry)))) :test #'equal)) (defun asdf-system-name (system) (slot-value system 'asdf::name)) (defun asdf-operation-pretty-name (op) (case op (asdf:compile-op "compiled") (asdf:load-op "loaded") (:unloaded "unloaded") (otherwise (prin1-to-string op)))) (defun asdf-system-history (system) (let (history) (maphash (lambda (operation time) (declare (ignore time)) (push operation history)) (slot-value system 'asdf::operation-times)) (nreverse history))) (define-presentation-method presentation-typep (object (type asdf-system)) (typep object 'asdf:system)) (define-presentation-method present (object (type asdf-system) stream (view textual-view) &key acceptably) (if acceptably (princ (asdf-system-name object) stream ) (let* ((history (asdf-system-history object)) (loaded-p (find 'asdf:load-op history)) (eff-history (set-difference history (ignorable-attributes view)))) (when (and (note-unloaded view) (not loaded-p)) (push :unloaded eff-history)) (format stream "~A~A" (asdf-system-name object) (if (null eff-history) (default-attr-label view) (format nil " (~{~a~^, ~})" (mapcar 'asdf-operation-pretty-name eff-history))))))) (define-presentation-method accept ((type asdf-system) stream (view textual-view) &key) (multiple-value-bind (object success) (completing-from-suggestions (stream) (dolist (system (asdf-loaded-systems)) (suggest (asdf-system-name system) system))) (if success object (simple-parse-error "Unknown system")))) (define-command (com-list-systems :name "List Systems" :command-table asdf-commands :menu t) () (format-items (asdf-loaded-systems) :printer (lambda (item stream) (present item 'asdf-system :stream stream :view (make-instance 'asdf-attribute-view :note-unloaded t :ignore '(asdf:compile-op asdf:load-op)))) :presentation-type 'asdf-system)) (define-command (com-show-available-systems :name "Show System Files" :command-table asdf-commands :menu t) () (format-items (asdf-registry-system-files) :presentation-type 'asdf-system-definition)) (define-command (com-operate-on-system :name "Operate On System" :command-table asdf-commands :menu t) ((system '(type-or-string asdf-system) :prompt "system") (operation '(member asdf::compile-op asdf::load-op) :default 'asdf::load-op :prompt "operation")) (asdf:oos operation system)) (define-command (com-load-system :name "Load System" :command-table asdf-commands :menu t) ((system '(type-or-string asdf-system) :prompt "system")) (asdf:oos 'asdf:compile-op system) (asdf:oos 'asdf:load-op system)) (defmethod mime-type-to-command ((mime-type text/x-lisp-system) pathname) (values `(com-load-system ,pathname) "Load System" (format nil "Load System ~A" pathname))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Functional-Geometry/0000700000175000017500000000000011347763412021573 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Functional-Geometry/functional-geometry.asd0000600000175000017500000000220010407462237026250 0ustar pdmpdm;;; -*- Mode: Lisp -*- ;;; ;;; (c) copyright 2006 by Timothy Moore (moore@bricoworks.com) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (defpackage :mcclim.functional-geometry.system (:use :asdf :cl)) (in-package :mcclim.functional-geometry.system) (defsystem #:functional-geometry :name #:functional-geometry :depends-on (:clim-listener) :components ((:file "package") (:file "geometry" :depends-on ("package")))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Functional-Geometry/package.lisp0000600000175000017500000000164610407462237024065 0ustar pdmpdm;;; ;;; (c) copyright 2006 by Timothy Moore (moore@bricoworks.com) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package #:cl-user) (defpackage #:functional-geometry (:use #:clim-lisp #:clim #:clim-listener)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Functional-Geometry/geometry.lisp0000600000175000017500000003102110407462237024313 0ustar pdmpdm;;; -*- Mode: Lisp -*- ;;; ;;; Copyright (c) 2005 by Frank Buss (fb@frank-buss.de) ;;; Clim interface by Rainer Joswig is in the public domain ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a ;;; copy of this software and associated documentation files (the "Software"), ;;; to deal in the Software without restriction, including without limitation ;;; the rights to use, copy, modify, merge, publish, distribute, sublicense, ;;; and/or sell copies of the Software, and to permit persons to whom the ;;; Software is furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; Functional Geometry ;;; ;;; Original idea by Peter Henderson, see ;;; http://www.ecs.soton.ac.uk/~ph/funcgeo.pdf ;;; and http://www.ecs.soton.ac.uk/~ph/papers/funcgeo2.pdf ;;; ;;; Implemented in Lisp by Frank Buss ;;; ;;; CLIM Listener interface by Rainer Joswig ;;; ;;; call it with (clim-plot *fishes*) from a Listener. ;;; ;;; the framework ;;; (in-package #:functional-geometry) (defun p* (vector m) "vector scalar multiplication" (destructuring-bind (vx vy) vector (list (* vx m) (* vy m)))) (defun p/ (vector d) "vector scalar division" (destructuring-bind (vx vy) vector (list (/ vx d) (/ vy d)))) (defun p+ (&rest vectors) "#'+ for vectors" (case (length vectors) (0 '(0 0)) (1 (car vectors)) (otherwise (flet ((p+p (v1 v2) (destructuring-bind (vx0 vy0) v1 (destructuring-bind (vx1 vy1) v2 (list (+ vx0 vx1) (+ vy0 vy1)))))) (reduce #'p+p vectors))))) (defun p- (&rest vectors) "#'- for vectors" (case (length vectors) (0 '(0 0)) (1 (p* (car vectors) -1)) (otherwise (flet ((p-p (v1 v2) (destructuring-bind (vx0 vy0) v1 (destructuring-bind (vx1 vy1) v2 (list (- vx0 vx1) (- vy0 vy1)))))) (reduce #'p-p vectors))))) (defun grid (m n s) "defines a picture from lines in a grid" (lambda (a b c) (loop for line in s collect (destructuring-bind ((x0 y0) (x1 y1)) line (list (p+ (p/ (p* b x0) m) a (p/ (p* c y0) n)) (p+ (p/ (p* b x1) m) a (p/ (p* c y1) n))))))) (defun polygon (points) "converts the points, which specifies a polygon, in a list of lines" (let ((start (car (last points)))) (loop for point in points collect (list start point) do (setf start point)))) (defun blank () "a blank picture" (lambda (a b c) (declare (ignore a b c)) '())) (defun beside (p q) "returns picture p besides picture q" (lambda (a b c) (let ((b-half (p/ b 2))) (union (funcall p a b-half c) (funcall q (p+ a b-half) b-half c))))) (defun above (p q) "returns picture q above picture p" (lambda (a b c) (let ((c-half (p/ c 2))) (union (funcall p (p+ a c-half) b c-half) (funcall q a b c-half))))) (defun rot (p) "returns picture p rotated by 90 degree" (lambda (a b c) (funcall p (p+ a b) c (p- b)))) (defun quartet (p1 p2 p3 p4) "returns the pictures p1-p4, layouted in a square" (above (beside p1 p2) (beside p3 p4))) (defun cycle (p) "returns four times the p, layouted in a square and rotated" (quartet p (rot (rot (rot p))) (rot p) (rot (rot p)))) #-(and) (defun plot (p) " saves a picture as postscript and shows it" (with-open-file (s "c:/tmp/test.ps" :direction :output :if-exists :supersede) (format s "500 500 scale~%") (format s ".1 .1 translate~%") (format s "0 setlinewidth~%") (format s "0 0 moveto 1 0 lineto 1 1 lineto 0 1 lineto 0 0 lineto~%") (dolist (line (funcall p '(0 0) '(1 0) '(0 1))) (destructuring-bind ((x0 y0) (x1 y1)) line (format s "~D ~D moveto ~D ~D lineto~%" (float x0) (float y0) (float x1) (float y1)))) (format s "stroke~%") (format s "showpage~%")) (sys:call-system "c:/gs/gs7.05/bin/gswin32.exe -g800x800 c:/tmp/test.ps")) ;;; ;;; a simple test ;;; ;; defines a man (defparameter *man* (grid 14 20 (polygon '((6 10) (0 10) (0 12) (6 12) (6 14) (4 16) (4 18) (6 20) (8 20) (10 18) (10 16) (8 14) (8 12) (10 12) (10 14) (12 14) (12 10) (8 10) (8 8) (10 0) (8 0) (7 4) (6 0) (4 0) (6 8))))) ;; demonstrates beside (defparameter *man-beside-man* (beside *man* *man*)) ;; demonstrates above (defparameter *man-above-man* (above *man* *man*)) ;; demonstrates rot (defparameter *man-rotated* (rot *man*)) ;; demonstrates quartet (defparameter *man-quartet* (quartet *man* *man* *man* *man*)) ;; demonstrates cycle (defparameter *man-cycle* (cycle *man*)) ;;; ;;; the fish ;;; ;; defines part p of the fish (defparameter *p* (grid 16 16 '(((4 4) (6 0)) ((0 3)(3 4)) ((3 4)(0 8)) ((0 8)(0 3)) ((4 5)(7 6)) ((7 6)(4 10)) ((4 10)(4 5)) ((11 0)(10 4)) ((10 4)(8 8)) ((8 8)(4 13)) ((4 13)(0 16)) ((11 0)(14 2)) ((14 2)(16 2)) ((10 4)(13 5)) ((13 5)(16 4)) ((9 6)(12 7)) ((12 7)(16 6)) ((8 8)(12 9)) ((12 9)(16 8)) ((8 12)(16 10)) ((0 16)(6 15)) ((6 15)(8 16)) ((8 16)(12 12)) ((12 12)(16 12)) ((10 16)(12 14)) ((12 14)(16 13)) ((12 16)(13 15)) ((13 15)(16 14)) ((14 16)(16 15))))) ;; defines part q of the fish (defparameter *q* (grid 16 16 '(((2 0)(4 5)) ((4 5)(4 7)) ((4 0)(6 5)) ((6 5)(6 7)) ((6 0)(8 5)) ((8 5)(8 8)) ((8 0)(10 6)) ((10 6)(10 9)) ((10 0)(14 11)) ((12 0)(13 4)) ((13 4)(16 8)) ((16 8)(15 10)) ((15 10)(16 16)) ((16 16)(12 10)) ((12 10)(6 7)) ((6 7)(4 7)) ((4 7)(0 8)) ((13 0)(16 6)) ((14 0)(16 4)) ((15 0)(16 2)) ((0 10)(7 11)) ((9 12)(10 10)) ((10 10)(12 12)) ((12 12)(9 12)) ((8 15)(9 13)) ((9 13)(11 15)) ((11 15)(8 15)) ((0 12)(3 13)) ((3 13)(7 15)) ((7 15)(8 16)) ((2 16)(3 13)) ((4 16)(5 14)) ((6 16)(7 15))))) ;; defines part r of the fish (defparameter *r* (grid 16 16 '(((0 12)(1 14)) ((0 8)(2 12)) ((0 4)(5 10)) ((0 0)(8 8)) ((1 1)(4 0)) ((2 2)(8 0)) ((3 3)(8 2)) ((8 2)(12 0)) ((5 5)(12 3)) ((12 3)(16 0)) ((0 16)(2 12)) ((2 12)(8 8)) ((8 8)(14 6)) ((14 6)(16 4)) ((6 16)(11 10)) ((11 10)(16 6)) ((11 16)(12 12)) ((12 12)(16 8)) ((12 12)(16 16)) ((13 13)(16 10)) ((14 14)(16 12)) ((15 15)(16 14))))) ;; defines part s of the fish (defparameter *s* (grid 16 16 '(((0 0)(4 2)) ((4 2)(8 2)) ((8 2)(16 0)) ((0 4)(2 1)) ((0 6)(7 4)) ((0 8)(8 6)) ((0 10)(7 8)) ((0 12)(7 10)) ((0 14)(7 13)) ((8 16)(7 13)) ((7 13)(7 8)) ((7 8)(8 6)) ((8 6)(10 4)) ((10 4)(16 0)) ((10 16)(11 10)) ((10 6)(12 4)) ((12 4)(12 7)) ((12 7)(10 6)) ((13 7)(15 5)) ((15 5)(15 8)) ((15 8)(13 7)) ((12 16)(13 13)) ((13 13)(15 9)) ((15 9)(16 8)) ((13 13)(16 14)) ((14 11)(16 12)) ((15 9)(16 10))))) ;; builds the fishes drawing (defparameter *t* (quartet *p* *q* *r* *s*)) (defparameter *u* (cycle (rot *q*))) (defparameter *side1* (quartet (blank) (blank) (rot *t*) *t*)) (defparameter *side2* (quartet *side1* *side1* (rot *t*) *t*)) (defparameter *corner1* (quartet (blank) (blank) (blank) *u*)) (defparameter *corner2* (quartet *corner1* *side1* (rot *side1*) *u*)) (defparameter *pseudocorner* (quartet *corner2* *side2* (rot *side2*) (rot *t*))) (defparameter *fishes* (cycle *pseudocorner*)) (define-presentation-type picture ()) (define-presentation-method presentation-typep (object (type picture)) (typep object 'function)) ;;; Plotting (define-command-table functional-geometry) (defmacro define-functional-geometry-command ((name &rest options) &body body) `(define-command (,name :command-table functional-geometry ,@options) ,@body)) (defun clim-plot (p &optional (stream *standard-output*)) (fresh-line stream) (with-output-as-presentation (stream p 'picture :single-box t) (with-room-for-graphics (stream) (with-scaling (stream 200 200) (with-translation (stream 0.1 0.1) (loop for (x0 y0 x1 y1) in '((0 0 1 0) (1 0 1 1) (1 1 0 1) (0 1 0 0)) do (draw-line* stream x0 y0 x1 y1)) (dolist (line (funcall p (list 0 0) (list 1 0) (list 0 1))) (destructuring-bind ((x0 y0) (x1 y1)) line (draw-line* stream x0 y0 x1 y1)))))))) (defun clim-plot-in-window (p &optional (stream *standard-output*)) (clim-plot p stream)) (defun clim-plot-to-postscript (p &optional (pathname "/Users/joswig/Desktop/test-clim.ps")) (with-open-file (file-stream pathname :direction :output :if-exists :supersede :if-does-not-exist :create) (with-output-to-postscript-stream (stream file-stream) (clim-plot p stream)))) ;;; XXX The use of EXPRESSION in the OR presentation type exposes a bug in the ;;; accept method for expression when rescanning; you have to hit ENTER three ;;; times when entering an expression (e.g., a variable name) as a picture ;;; value. This will be fixed after .9.2.2. -- moore (define-functional-geometry-command (plot :name t) ((picture '(or picture expression) :provide-default nil :prompt "picture")) (unless (presentation-typep picture 'picture) (setq picture (eval picture)) (clim-plot-in-window picture) picture)) (define-functional-geometry-command(save-picture-as-postscript :name t) ((picture 'picture :provide-default nil :prompt "picture") (file 'pathname :provide-default nil :prompt "file")) (clim-plot-to-postscript picture file) (values file picture)) (define-functional-geometry-command (com-beside :name t) ((picture0 'picture :provide-default nil :prompt "picture 0") (picture1 'picture :provide-default nil :prompt "picture 1")) (let ((new-picture (beside picture0 picture1))) (clim-plot new-picture) new-picture)) (define-functional-geometry-command (com-above :name t) ((picture0 'picture :provide-default nil :prompt "picture 0") (picture1 'picture :provide-default nil :prompt "picture 1")) (let ((new-picture (above picture0 picture1))) (clim-plot new-picture) new-picture)) (define-functional-geometry-command (com-rot :name t) ((picture 'picture :provide-default nil :prompt "picture")) (let ((new-picture (rot picture))) (clim-plot new-picture) new-picture)) (define-functional-geometry-command (com-cycle :name t) ((picture 'picture :provide-default nil :prompt "picture")) (let ((new-picture (cycle picture))) (clim-plot new-picture) new-picture)) (define-functional-geometry-command (com-quartet :name t) ((picture0 'picture :provide-default nil :prompt "picture 0") (picture1 'picture :provide-default nil :prompt "picture 1") (picture2 'picture :provide-default nil :prompt "picture 2") (picture3 'picture :provide-default nil :prompt "picture 3")) (let ((new-picture (quartet picture0 picture1 picture2 picture3))) (clim-plot new-picture) new-picture)) (define-presentation-to-command-translator rot (picture com-rot functional-geometry :menu t :gesture nil) (object) (list object)) (define-presentation-to-command-translator cycle (picture com-cycle functional-geometry :menu t :gesture nil) (object) (list object)) (define-drag-and-drop-translator besides (picture command picture functional-geometry :tester ((object destination-object) (not (eq object destination-object)))) (object destination-object) `(com-beside ,object ,destination-object)) (pushnew 'functional-geometry (command-table-inherit-from (find-command-table 'clim-listener::listener))) (defun run-functional-geometry (&rest args) "Run a Lisp Listener augmented with functional geometry commands." (let ((*package* (find-package '#:functional-geometry))) (apply #'run-listener (append args '(:process-name "Functional Geometry" :height 800))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/0000755000175000017500000000000011347763412017452 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/README0000644000175000017500000000603007750444411020327 0ustar pdmpdm-------------- Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. -------------- Scigraph Scientific Graphing Package Scigraph is a an object-oriented library for doing x-vs-y plots. It can be embedded in other applications. Scigraph's functionality includes scatter plots, linear plots, bar charts, contour plots, and symbolic equations. Scatter, linear, and bar plots are fast and reliable. It runs in Dynamic Windows and every version of CLIM under Symbolics, Allegro, Lucid, and MCL. Graphs and data points are mouse-sensitive. You may either interactively or programmatically control zooming, annotating, setting colors and symbols, and the usual features you would expect. Scigraph is available via anonymous ftp from cambridge.apple.com in the directory pub/clim/clim-1-and-2/scigraph. There are three subdirectories to this directory, scigraph, dwim, and contrib. Scigraph, contains the main body of the source code. This source code looks a lot like dynamic windows because that is where the system grew up. Documentation for scigraph, including how to compile and load it, is in scigraph/scigraph.doc. Dwim, contains a set of utilities for scigraph that make the various lisps compatible and make every version of CLIM look like dynamic windows. DWIM can be thought of as a thin layer of syntax that buffers Scigraph from the winds of CLIM change. Contrib, is where users may contribute patches and extensions to Scigraph. We may periodically peek in this directory to merge contributions into the main source code. There is also a compressed tar file, scigraph.tar.Z, containing a copy of the above files. Questions and comments should be addressed to the authors. Jeff Morrill (jmorrill@bbn.com) Ken Anderson (kanderson@bbn.com) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph.asd0000640000175000017500000000317110666602330021733 0ustar pdmpdm;;; -*- lisp -*- (defpackage :scigraph.system (:use :cl :asdf)) (in-package :scigraph.system) ;;; This won't load in SBCL, either. I have really crappy code to ;;; extract dependency information from :serial t ASDF systems, but ;;; this comment is too narrow to contain it. (defsystem :scigraph :depends-on (:mcclim) ;; The DWIM part of SCIGRAPH :serial t :components ( (:file "dwim/package") (:file "dwim/feature-case") (:file "dwim/macros") (:file "dwim/tv") (:file "dwim/draw") (:file "dwim/present") (:file "dwim/extensions") (:file "dwim/wholine") (:file "dwim/export") ;; The Scigraph part (:file "scigraph/package") (:file "scigraph/copy") (:file "scigraph/dump") (:file "scigraph/duplicate") (:file "scigraph/random") (:file "scigraph/menu-tools") (:file "scigraph/basic-classes") (:file "scigraph/draw") (:file "scigraph/mouse") (:file "scigraph/color") (:file "scigraph/basic-graph") (:file "scigraph/graph-mixins") (:file "scigraph/axis") (:file "scigraph/moving-object") (:file "scigraph/symbol") (:file "scigraph/graph-data") (:file "scigraph/legend") (:file "scigraph/graph-classes") (:file "scigraph/present") (:file "scigraph/annotations") (:file "scigraph/annotated-graph") (:file "scigraph/contour") (:file "scigraph/equation") (:file "scigraph/popup-accept") (:file "scigraph/popup-accept-methods") (:file "scigraph/duplicate-methods") (:file "scigraph/frame") (:file "scigraph/export") (:file "scigraph/demo-frame")))cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/dwim/0000755000175000017500000000000011347763412020412 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/dwim/macros.lisp0000640000175000017500000007115210561555366022575 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: DWIM-*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :dwim) #+(and (not ansi-cl) (or genera lucid allegro)) (defmacro printing-random-object ((object stream . options) &body body) #+genera `(si:printing-random-object (,object ,stream . ,options) ,@body) #+lucid `(system:printing-random-object (,object ,stream . ,options) ,@body) #+allegro `(progn (if *print-readably* (error "Can't print readably")) (write-string "#<" ,stream) (unless ,(null (member :typep options)) (format ,stream "~S " (class-name (class-of ,object)))) ,@body (when ,(null (member :no-pointer options)) (write-char #\space ,stream) (format ,stream " ~X" (excl::pointer-to-fixnum ,object))) (write-string ">" ,stream))) #+ansi-cl (defmacro printing-random-object ((object stream &rest options) &body body) `(print-unreadable-object (,object ,stream :type ,(member :typep options) :identity ,(not (member :no-pointer options))) ,@body)) (defmacro with-stack-list ((var &rest elements) &body body) #+Genera `(scl:with-stack-list (,var ,@elements) ,@body) #+allegro `(excl:with-stack-list (,var ,@elements) ,@body) #+(and (not genera) (not allegro)) `(funcall #'(lambda (&rest ,var) (declare (dynamic-extent ,var)) ,@body) ,@elements)) (defmacro with-stack-array ((var length &rest options) &body body) #+genera `(sys:with-stack-array (,var ,length ,@options) ,@body) #-genera `(let ((,var (make-array ,length ,@options))) (declare (dynamic-extent ,var)) ,@body)) (defmacro store-conditional (place old new) "Atomically change the value of PLACE from OLD to NEW." #+genera `(si:store-conditional (scl:locf ,place) ,old ,new) #-genera (declare (ignore old)) #-genera `(setf ,place ,new)) (defmacro stack-let (forms &body body) #+genera `(si:stack-let ,forms ,@body) #-genera (labels ((get-vars (let-vars) (mapcar #'(lambda (v) (if (symbolp v) v (car v))) let-vars))) `(let ,forms (declare (dynamic-extent ,@(get-vars forms))) ,@body))) #-(or openmcl-native-threads sb-thread scl) (defmacro without-interrupts (&body body) #FEATURE-CASE ((:genera `(scl::without-interrupts ,@body)) (:lucid `(lcl:with-scheduling-inhibited ,@body)) (:allegro `(excl:without-interrupts ,@body)) (:mcl `(ccl:without-interrupts ,@body)))) #+(or openmcl-native-threads sb-thread scl) (progn (defparameter *dwim-giant-lock* (clim-sys:make-lock "dwim giant lock")) (defmacro without-interrupts (&body body) `(clim-sys:with-lock-held (*dwim-giant-lock*) ,@body))) (defmacro handler-case (form &rest clauses) #FEATURE-CASE ((:genera `(future-common-lisp:handler-case ,form ,@clauses)) (:lucid `(lcl:handler-case ,form ,@clauses)) (:allegro `(lisp:handler-case ,form ,@clauses)) ((or :mcl :ansi-cl) `(COMMON-LISP:handler-case ,form ,@clauses)))) (defmacro handler-bind (bindings &body forms) #FEATURE-CASE ((:genera `(future-common-lisp:handler-bind ,bindings ,@forms)) (:lucid `(lcl:handler-bind ,bindings ,@forms)) (:allegro `(lisp:handler-bind ,bindings ,@forms)) ((or :mcl :ansi-cl) `(COMMON-LISP:handler-bind ,bindings ,@forms)) )) (defmacro condition-case ((&rest varlist) form &rest clauses) #+genera (declare (zwei:indentation 1 4 2 2)) #+genera `(scl:condition-case ,varlist ,form ,@clauses) #-genera `(let ,(cdr varlist) (handler-case ,form ,@(mapcar #'(lambda (cl) `(,(first cl) ,(if (first varlist) (list (first varlist))) ,@(cdr cl))) clauses)))) (defmacro ignore-errors (&body body) #FEATURE-CASE ((:Allegro `(lisp:ignore-errors ,@body)) ((or :mcl :ansi-cl) `(COMMON-LISP:ignore-errors ,@body)) (:Lucid `(lcl:ignore-errors ,@body)) (:Xerox `(xcl:ignore-errors ,@body)) (:Genera `(future-common-lisp:ignore-errors ,@body)))) (defmacro with-simple-restart ((name format-string &rest format-args) &body body) #FEATURE-CASE ((:allegro `(lisp:with-simple-restart (,name ,format-string ,@format-args) ,@body)) (:lucid `(lcl:with-simple-restart (,name ,format-string ,@format-args) ,@body)) (:genera `(future-common-lisp:with-simple-restart (,name ,format-string ,@format-args) ,@body)) ((or :mcl :ansi-cl) `(COMMON-LISP:with-simple-restart (,name ,format-string ,@format-args) ,@body)) )) (defmacro restart-case (expression &body clauses) #FEATURE-CASE ((:genera `(future-common-lisp:restart-case ,expression ,@clauses)) (:lucid `(lcl:restart-case ,expression ,@clauses)) (:allegro `(lisp:restart-case ,expression ,@clauses)) ((or :mcl :ansi-cl) `(COMMON-LISP:restart-case ,expression ,@clauses)))) (defun invoke-restart (restart &rest values) #FEATURE-CASE ((:genera (apply #'future-common-lisp:invoke-restart restart values)) (:lucid (apply #'lcl:invoke-restart restart values)) (:allegro (apply #'lisp:invoke-restart restart values)) ((or :mcl :ansi-cl) (apply #'COMMON-LISP:invoke-restart restart values)))) (defun find-restart (name &optional condition) #FEATURE-CASE ((:genera (future-common-lisp:find-restart name condition)) (:lucid (lcl:find-restart name condition)) (:allegro (lisp:find-restart name condition)) ((or :mcl :ansi-cl) (COMMON-LISP:find-restart name condition)))) (defmacro make-command-table (name &key inherit-from) (when (and (consp inherit-from) (eq (car inherit-from) 'quote)) ;; dequotify (setq inherit-from (second inherit-from))) #-clim `(cp:make-command-table ',name :if-exists :update-options :INHERIT-FROM ',inherit-from) #+clim `(clim:define-command-table ,name :inherit-from ,inherit-from)) (defmacro define-command-table (name &key inherit-from) `(make-command-table ,name :inherit-from ,inherit-from)) (defun find-command-table (NAME &key (errorp t)) #FEATURE-CASE ((:CLIM-0.9 (clim:find-command-table NAME :if-does-not-exist (and errorp :error))) ((or :clim-2 :clim-1.0) (clim:find-command-table NAME :errorp errorp)) ((not :CLIM) (cp:find-command-table name :if-does-not-exist (and errorp :error))))) (defmacro command-table-inherit-from (NAME) #FEATURE-CASE ((:CLIM `(clim::command-table-inherit-from ,NAME)))) (defun command-pretty-name (string) "COM-SHOW-FILE -> 'Show File'" (cond ((and (> (length string) 4) (string-equal string "COM-" :end1 4)) (command-pretty-name (subseq string 4))) (t (dotimes (i (length string)) (if (char= (aref string i) #\-) (setf (aref string i) #\space))) (dotimes (i (length string)) (cond ((= i 0) (setf (aref string i) (char-upcase (aref string i)))) ((char= (aref string (1- i)) #\space) (setf (aref string i) (char-upcase (aref string i)))) (t (setf (aref string i) (char-downcase (aref string i)))))) string))) (defmacro define-command ((command-name &key (command-table :global) keystroke name menu (provide-output-destination-keyword t)) arguments &body body) #+clim (declare (ignore provide-output-destination-keyword)) #+genera (declare (zwei:indentation 1 3 2 2)) #FEATURE-CASE (((not :clim) `(cp:define-command (,command-name :command-table ,command-table :name ,name :provide-output-destination-keyword ,provide-output-destination-keyword) ,arguments ,@body)) (:clim-0.9 ;; define-command doesn't work because it doesn't take care of the hidden frame ;; argument. define-frame-command doesn't work unless the command table is also ;; the name of a frame type. jpm. `(progn (ws::define-specializable-command ,command-name (,ws::*frame-parameter* t) ,arguments ,@body) (install-command ,command-table ',command-name ,name))) (:clim-1.0 `(clim:define-command (,command-name :command-table ,(eval command-table) :menu ,menu :name ,(or name (command-pretty-name (copy-seq (string command-name))))) ,arguments ,@body)) (clim-2 `(clim:define-command (,command-name :command-table ,(eval command-table) :keystroke ,keystroke :menu ,menu :name ,(or name (command-pretty-name (copy-seq (string command-name)))) #+mcclim :provide-output-destination-keyword #+mcclim ,provide-output-destination-keyword) ,arguments ,@body)))) (defun install-command (command-table command-symbol &optional command-name) (or command-name (setq command-name (command-pretty-name (copy-seq (string command-symbol))))) #FEATURE-CASE (((or :clim-1.0 :clim-2) (clim:add-command-to-command-table command-symbol command-table :name command-name :errorp nil)) (:clim-0.9 (clim:add-command-to-command-table command-name command-symbol command-table)) ((not :clim) (let ((tab (cp:find-command-table command-table :if-does-not-exist nil))) (and tab (cp:command-table-delete-command-symbol tab command-symbol :if-does-not-exist nil)) (cp:install-command command-table command-symbol command-name))))) (defun canonicalize-argument-list (list) (remove '&key list)) (defun canonicalize-command-table (command-table) (if (symbolp command-table) command-table (eval command-table))) #+clim-0.9 (defun canonicalize-documentation (documentation) (if (stringp documentation) `((stream) (write-string ,documentation stream)) documentation)) #-clim (defun canonicalize-documentation (documentation) documentation) #+(or :clim-1.0 :clim-2) (defun canonicalize-documentation (documentation) documentation) (defmacro define-presentation-to-command-translator (name (presentation-type &key (menu t) gesture documentation (pointer-documentation documentation) command-name tester command-table) arguments &body body) #+genera (declare (zwei:indentation 1 2 3 1)) (setq documentation (canonicalize-documentation documentation) command-table (canonicalize-command-table command-table)) #FEATURE-CASE (((not :clim) `(dw:define-presentation-to-command-translator ,name (,presentation-type :documentation ,documentation :tester ,tester :gesture ,gesture :menu ,menu) ,arguments (cons ',command-name ,@body))) (:clim-0.9 (let ((to-type (if command-table `(command :command-table ,command-table) 'command))) `(clim:define-presentation-translator ,name (,presentation-type ,to-type :tester ,(if tester (cons (canonicalize-argument-list (car tester)) (cdr tester))) :gesture ,gesture :menu ,menu :documentation ,documentation) ,(canonicalize-argument-list arguments) (cons ',command-name (progn ,@body))))) ((or :clim-1.0 :clim-2) `(clim:define-presentation-to-command-translator ,name (,presentation-type ,command-name ,command-table :tester ,(if tester (cons (canonicalize-argument-list (car tester)) (cdr tester))) :gesture ,gesture :menu ,menu :pointer-documentation ,pointer-documentation :documentation ,documentation) ;; Don't know who's right, but my reading of the spec suggests ;; that &key shouldn't be in the argument list. -- moore #-mcclim ,arguments #+mcclim ,(canonicalize-argument-list arguments) ,@body)))) (defmacro define-presentation-translator (name (from-type to-type &key (menu t) (gesture :select) command-table documentation tester do-not-compose) arguments &body body) #+genera (declare (zwei:indentation 1 2 3 1)) (setq documentation (canonicalize-documentation documentation) command-table (canonicalize-command-table command-table)) #FEATURE-CASE (((not :clim) `(dw:define-presentation-translator ,name (,from-type ,to-type :documentation ,documentation :tester ,tester :gesture ,gesture :menu ,menu :do-not-compose ,do-not-compose) ,arguments ,@body)) (:clim-0.9 (let ((test tester)) (when do-not-compose (setq test `(,(first test) (values (progn ,@(rest test)) t)))) `(clim:define-presentation-translator ,name (,from-type ,to-type :tester ,(if test (cons (canonicalize-argument-list (car test)) (cdr test))) :gesture ,gesture :menu ,menu :documentation ,documentation) ,arguments ,@body))) ((or :clim-1.0 :clim-2) (let ((test tester)) `(clim:define-presentation-translator ,name (,from-type ,to-type ,command-table :tester ,(if test (cons (canonicalize-argument-list (car test)) (cdr test))) :gesture ,gesture :menu ,menu :tester-definitive ,do-not-compose :documentation ,documentation) ,arguments ,@body))))) (defmacro define-presentation-action (name (from-type to-type &key command-table gesture tester documentation (menu t)) arglist &body body) ;; This is similar to define-presentation-translator, except that the body of the ;; action is not intended to return a value, but should instead side-effect some ;; sort of application state. ;; ;; D. Moon says actions should be used not to side-effect the application state, ;; but rather to do something to the display. It has to make sense while in the ;; middle of parsing a command (i.e. expand ellipsis), otherwise it should be a ;; presentation-to-command-translator. #+genera (declare (zwei:indentation 1 2 3 1)) (setq documentation (canonicalize-documentation documentation) command-table (canonicalize-command-table command-table)) #FEATURE-CASE (((not :clim) `(dw:define-presentation-action ,name (,from-type ,to-type :gesture ,gesture :tester ,tester :menu ,menu :documentation ,documentation) ,arglist ,@body)) (:clim-0.9 (progn (or (member 'window arglist :test #'string-equal) (push 'window arglist)) (or (member 'gesture arglist :test #'string-equal) (push 'gesture arglist)) ;; To prevent the body from getting evaluated in the process of testing the ;; applicability of the translator, the tester should return T as the second ;; value. (cond ((not tester) (setq tester `((presentation) (values (ci::presentation-matches-type-p presentation ',from-type) t)))) (t (setq tester `(,(first tester) (values (progn ,@(rest tester)) t))))) (when (and command-table (eql to-type 'command)) (setq to-type `(command :command-table ,command-table))) (let ((g (find 'gesture arglist :test #'string-equal)) (w (find 'window arglist :test #'string-equal))) `(clim:define-presentation-translator ,name (,from-type ,to-type :tester ,tester :gesture ,gesture :menu ,menu :documentation ,documentation) ,arglist (when (not (eq ,g :for-menu)) ,@body ;; pretty big hammer, but we need to get blips etc out of the input buffer. (clim:stream-clear-input ,w) '(ignore)))))) ((or :clim-1.0 :clim-2) `(clim:define-presentation-action ,name (,from-type ,to-type ,command-table :gesture ,gesture :tester ,(if tester (cons (canonicalize-argument-list (car tester)) (cdr tester))) :menu ,menu :documentation ,documentation) ,arglist ,@body)))) (defmacro define-presentation-type (name arglist &key parser printer abbreviation-for (no-deftype t) typep describer description accept-values-displayer highlighter INHERIT-FROM) (if (null no-deftype) (format t "Presentation type ~A, :NO-DEFTYPE option is obsolete and is ignored." name)) (if (and (consp arglist) (consp (car arglist))) (error "Obsolete arglist. Use (&REST ARGS) rather than ((&REST ARGS))")) #FEATURE-CASE (((not :clim) (progn ;; DW needs extra listification of the arglist because it ;; distinguishes between data type arguments and formatting arguments. (if arglist (setq arglist (list arglist))) `(progn #+genera (scl:record-source-file-name ',name 'define-presentation-type) (dw:define-presentation-type ,name ,arglist :description ,description :typep ,typep :describer ,describer ,@(if (not abbreviation-for) `(:no-deftype t)) :abbreviation-for ,abbreviation-for :parser ,parser :printer ,printer :choose-displayer ,accept-values-displayer)))) (:clim-0.9 `(clim:define-presentation-type ,name ,arglist :describer ,(or describer `((stream) (format stream ,description))) :abbreviation-for ,abbreviation-for :object-validator ,typep :supertype ,inherit-from ;; should really check there's only one... :parser ,(if parser (let ((args (first parser)) (body (rest parser))) (when (not (member '&rest args)) (setq args (append args '(&rest rest))) (push (copy-list '(declare (ignore rest))) body)) `(,args ,@body))) :printer ,(if printer (let ((args (first printer)) (body (rest printer))) (when (not (member '&key args)) (setq args (append args '(&key)))) (when (not (member '&allow-other-keys args)) (setq args (append args '(&allow-other-keys)))) `(,args ,@body))) :accept-values-displayer ,accept-values-displayer)) ((or :clim-1.0 :clim-2) `(progn ;; Methods automatically get lexical access to the presentation arguments. ;; TO DO: handle the keywords from :parser and :printer arglists. ,(let ((superclasses (cond (INHERIT-FROM (list (eval INHERIT-FROM))) ((find-class name nil) (mapcar #'class-name (#+mcclim clim-mop:class-direct-superclasses #-mcclim class-direct-superclasses (find-class name))))))) (if superclasses (setq superclasses (if (cdr superclasses) (cons 'and superclasses) (car superclasses)))) (if abbreviation-for `(clim:define-presentation-type-abbreviation ,name ,arglist ,abbreviation-for) `(clim:define-presentation-type ,name ,arglist :description ,description :inherit-from ,(and superclasses `',superclasses)))) ,(when parser (let ((args (canonicalize-argument-list (first parser))) (body (rest parser))) `(clim:define-presentation-method clim:accept ((type ,name) stream (view clim:textual-view) &key) (let ((,(first args) stream)) ,@body)))) ,(when describer (let ((args (canonicalize-argument-list (first describer))) (body (rest describer))) `(clim:define-presentation-method clim:describe-presentation-type ((type ,name) stream plural-count) (let ((,(first args) stream)) plural-count ,@body)))) ,(when typep (let ((args (canonicalize-argument-list (first typep))) (body (rest typep))) `(clim:define-presentation-method clim:presentation-typep ((,(car args) t) (type ,name)) ,@body))) ,(when printer (let ((args (canonicalize-argument-list (first printer))) (body (rest printer))) `(clim:define-presentation-method clim:present (object (type ,name) stream (view clim:textual-view) &key) (let ((,(first args) object) (,(second args) stream)) ,@body)))) ,(when accept-values-displayer (let* ((arglist (car accept-values-displayer)) (stream (first arglist)) (default (second arglist)) (query-identifier (third arglist))) `(clim:define-presentation-method clim:accept-present-default ((type ,name) ,stream (view #+clim-1.0 clim:dialog-view #+clim-2 clim:gadget-dialog-view) ,default default-supplied-p present-p ,query-identifier #+(and clim-2 (not mcclim)) &key) (declare (ignore default-supplied-p present-p)) ,@(cdr accept-values-displayer)))) ,(when highlighter (let ((args (first highlighter))) `(clim:define-presentation-method clim:highlight-presentation ((type ,name) ,@ARGS) ,@(cdr highlighter))))))) ) (defmacro with-output-as-presentation ((&key stream object (type ''expression) single-box (allow-sensitive-inferiors t) dont-snapshot-variables record-type) &body body) dont-snapshot-variables allow-sensitive-inferiors #FEATURE-CASE (((not :clim) (progn (or record-type (setq record-type ''dw::presentation)) `(graphics:with-output-as-graphics-presentation (,stream :object ,object :type ,type :single-box ,single-box :allow-sensitive-inferiors ,allow-sensitive-inferiors :dont-snapshot-variables ,dont-snapshot-variables) ,@body))) (:clim-0.9 (progn (or record-type (setq record-type ''clim::presentation)) `(clim:with-output-as-presentation (:stream ,stream :object ,object :type ,type ;; :allow-sensitive-inferiors ,allow-sensitive-inferiors :single-box ,single-box :record-type ,record-type) ,@body))) (:clim-1.0 (progn (or record-type (setq record-type ''clim::standard-presentation)) `(if (clim:extended-input-stream-p ,stream) (clim:with-output-as-presentation (:stream ,stream :object ,object :type ,type :allow-sensitive-inferiors ,allow-sensitive-inferiors :single-box ,single-box :record-type ,record-type) ,@body) (progn ,@body)))) (:clim-2 (or record-type (setq record-type ''clim::standard-presentation)) `(clim:with-output-as-presentation (,stream ,object ,type :allow-sensitive-inferiors ,allow-sensitive-inferiors :single-box ,single-box :record-type ,record-type) ,@body)))) (defmacro with-output-as-graphics-presentation ((&key stream object type single-box (allow-sensitive-inferiors t) dont-snapshot-variables) &body body) stream object type single-box allow-sensitive-inferiors dont-snapshot-variables body (error "WITH-OUTPUT-AS-GRAPHICS-PRESENTATION is not supported. ~ Use WITH-OUTPUT-AS-PRESENTATION instead")) (defmacro with-output-truncation ((stream) &body body) #FEATURE-CASE (((not :clim) `(dw:with-output-truncation (,stream :horizontal t :vertical t) ,@body)) ((or :clim-0.9 :clim-1.0) `(clim:with-end-of-line-action (:allow ,stream) (clim:with-end-of-page-action (:allow ,stream) ,@body))) (:clim-2 `(clim:with-end-of-line-action (,stream :allow) (clim:with-end-of-page-action (,stream :allow) ,@body))))) (defmacro with-output-recording-enabled ((stream &optional (record-p t)) &body body) #FEATURE-CASE (((or :clim-0.9 :clim-1.0) `(clim:with-output-recording-options (,stream :record-p ,record-p :draw-p t) ,@body)) ((not :clim) `(dw:with-output-recording-enabled (,stream ,record-p) ,@body)) (:clim-2 `(clim:with-output-recording-options (,stream :record ,record-p :draw t) ,@body)))) (defmacro with-output-recording-disabled ((stream) &body body) `(with-output-recording-enabled (,stream nil) ,@body)) (defmacro with-redisplayable-output ((&key stream (unique-id nil unique-id-p) (id-test '#'eq) (cache-value nil cache-value-p) (cache-test '#'eql) copy-cache-value) &body body) #+clim `(if (clim:extended-input-stream-p ,stream) (clim:updating-output (,stream ,@(if unique-id-p `(:unique-id ,unique-id)) :id-test ,id-test ,@(if cache-value-p `(:cache-value ,cache-value)) :cache-test ,cache-test :copy-cache-value ,copy-cache-value) ,@body) (progn ,@body)) #-clim `(dw:with-redisplayable-output (:stream ,stream :id-test ,id-test ,@(if unique-id-p `(:unique-id ,unique-id)) :cache-test ,cache-test :copy-cache-value ,copy-cache-value ;; I hate behavior that depends on ;; whether or not you supply the default value. ,@(if cache-value-p `(:cache-value ,cache-value))) ,@body)) (defmacro with-character-face ((face &optional (stream t)) &body body) #FEATURE-CASE (((not :clim) `(scl:with-character-face (,face ,stream :bind-line-height t) ,@body)) ((or :clim-0.9 :clim-1.0) `(clim:with-text-face (,face ,stream) ,@body)) (:clim-2 `(clim:with-text-face (,stream ,face) ,@body)))) (defmacro with-text-face ((face stream) &body body) `(with-character-face (,face ,stream) ,@body)) (defmacro with-character-style ((style &optional (stream t)) &body body) #FEATURE-CASE (((not :clim) `(scl:with-character-style (,style ,stream :bind-line-height t) ,@body)) ((or :clim-0.9 :clim-1.0) `(clim:with-text-style (,style ,stream) ,@body)) (:clim-2 `(clim:with-text-style (,stream ,style) ,@body)))) (defmacro with-text-style ((style stream) &body body) `(with-character-style (,style ,stream :bind-line-height t) ,@body)) (defmacro with-character-size ((style &optional (stream t)) &body body) #FEATURE-CASE (((not :clim) `(scl:with-character-size (,style ,stream :bind-line-height t) ,@body)) ((or :clim-0.9 :clim-1.0) `(clim:with-text-size (,style ,stream) ,@body)) (:clim-2 `(clim:with-text-size (,stream ,style) ,@body)))) (defmacro with-character-family ((family &optional (stream t)) &body body) #FEATURE-CASE (((not :clim) `(scl:with-character-family (,family ,stream :bind-line-height t) ,@body)) ((or :clim-0.9 :clim-1.0) `(clim:with-text-family (,family ,stream) ,@body)) (:clim-2 `(clim:with-text-family (,stream ,family) ,@body)))) (defmacro with-frame ((symbol) &body body) #FEATURE-CASE (((not :clim) `(let ((,symbol (if (boundp 'dw:*program-frame*) dw:*program-frame*))) ,@body)) (:clim-0.9 `(clim:with-frame (,symbol) ,@body)) ((or :clim-1.0 :clim-2) `(let ((,symbol (if (boundp 'clim:*application-frame*) clim:*application-frame*))) ,@body)))) (defmacro with-program ((symbol) &body body) #+clim `(with-frame (,symbol) ,@body) #-clim `(let ((,symbol (if (boundp 'dw:*program*) dw:*program*))) ,@body)) (defmacro accepting-values ((stream &key own-window label (abort-value :ABORT) (exit-boxes ''((:exit " OK ") (:abort " Cancel ")))) &body body) ;; add :exit-boxes arg #FEATURE-CASE ((:clim-0.9 `(if (eq :abort (clim:accepting-values (,stream :own-window ,own-window) ,@(if label `((format ,stream "~A~%~%" ,label))) ,@body)) ,abort-value t)) (:clim-1.0 `(if (eq :abort (restart-case (clim:accepting-values (,stream :own-window ,own-window :label ,label :exit-boxes ,exit-boxes :resynchronize-every-pass t ;; get these things to come up ;; in some nonrandom location :x-position 200 :y-position 200) (setf (clim:medium-text-style ,stream) (parse-text-style '(:fix :roman :normal))) ,@body) (abort () :abort))) ;; If you quit using a keyboard accelerator, clim leaves the keystroke ;; in the input buffer (clim bug). ,abort-value t)) (:clim-2 `(if (eq :abort (restart-case (clim:accepting-values (,stream :own-window ,own-window :label ,label :exit-boxes ,exit-boxes :resynchronize-every-pass t ;; get these things to come up ;; in some nonrandom location :x-position 200 :y-position 200 ,@(when (fboundp (intern "COLOR-STREAM-P" 'clim)) ;; Scroll bars don't work till clim 2.0.beta2. `(:scroll-bars :both))) ,@body) (abort () :abort))) ;; If you quit using a keyboard accelerator, clim leaves the keystroke ;; in the input buffer (clim bug). ,abort-value t)) ((not :clim) `(condition-case () (progn (dw:accepting-values (,stream :own-window ,own-window :label ,label :changed-value-overrides-default t) ,@body) t) ;; catch aborts and act like clim. (sys:abort ,abort-value))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/dwim/dwim-system.lisp0000640000175000017500000001534310561555366023573 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: User -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :user) #| SYSTEM DWIM DWIM is an interface to graphical user interface systems. We are concerned (so far) with Dynamic Windows (DW) and CLIM. This system is written for programs that: 1. Were originally written with DW in mind, 2. But now want to run in clim on other hardware platforms, 3. But want to retain backward compatibility with DW. The policy of DWIM is to provide the most commonly used functionality from the symbolics interface in a package from which applications may inherit symbols. Application packages generally would inherit from DWIM, CL, and CLOS. Porting source code is then largely a process of removing package prefixes. Much of the syntax and nomenclature of CLIM is also provided by DWIM. In many cases, however, name conflicts occur (e.g. with-output-as-presentation), and in such cases the DW syntax will be preferred. The bias does not reflect a belief that DW is better, but rather that most applications will be going from DW to CLIM and not the other way, therefore porting effort is minimized. It is not our goal to define a third interface management language, but rather to provide a tool for easing the porting process. There are several exceptions to this rule of DW portability. a. DWIM is small so far, so the more obscure functions from TV and DW may not yet be there. We expect this library to grow as more applications use it. b. SEND will not be supported by DWIM. In these cases, DWIM will provide a function. So for example, (send stream :line-height) would be rewritten as (stream-line-height stream). Generally, the name of the function will be the name used by CLIM. c. Some DW macros, such as define-program-framework, are too hard to parse and will not be supported in DWIM. DWIM-LISP is what user programs should use as the lisp package. It's purpose is to handle all the hairy importing and shadowing constraints so that users don't have to go through this every time they define a package that uses dwim stuff. DWIM-LISP exports Common Lisp, CLOS, and the relevant DWIM symbols. User package definitions should look very simple, e.g. (in-package 'my-package :use '(dwim-lisp)) PACKAGES: DWIM, DWIM-LISP. SUBSYSTEMS: None. |# #-clim (eval-when (compile load eval) (when (find-package 'clim) (pushnew :clim *features*))) ; Add a CLIM feature. (eval-when (compile load eval) ;; CLIM 1 doesn't affect the *features*. Here's a rule of thumb ;; that seems to work. (when (and (find-package 'clim) (not (boundp (intern "CLIM-VERSION" 'clim))) ; from clim 0.9 (not (fboundp (intern "STREAM-CURSOR-POSITION" 'clim))) ; from clim 2 (not (member :clim-2 *features*)) (not (member :clim-0.9 *features*))) (pushnew :clim-1 *features*) (pushnew :clim-1.0 *features*))) (defun file-type-for-sources () #+MCL #.(pathname-type *.lisp-pathname*) #+genera "LISP" #+unix "lisp" #+(and (not mcl) (not genera) (not unix)) (error "Not yet implemented.")) (defun file-type-for-binaries () #+MCL #.(pathname-type *.fasl-pathname*) #+genera si:*default-binary-file-type* #+(or allegro sbcl) #.(if (fboundp 'compile-file-pathname) (pathname-type (compile-file-pathname "foo")) "fasl") #+scl (pathname-type (compile-file-pathname "foo")) #+lucid (car lcl:*load-binary-pathname-types*) #+(and (not genera) (not allegro) (not lucid) (not mcl) (not sbcl)) (error "Not yet implemented.")) #+genera (setq *load-pathname* (make-pathname :defaults si:fdefine-file-pathname :name nil :type nil :version nil)) (defun suggest-bin-directory (&optional (base *load-pathname*) (prefix "BIN-")) ;; The number of different binaries you must have is ;; the cross product of the instruction set and the gui. (let ((instruction-set #+MCL "MCL" #+GENERA "GENERA" #+LUCID "LUCID" #+ALLEGRO "ALLEGRO" #+SBCL "SBCL" #+scl "SCL") (GUI #+(and mcl (not clim)) "MAC" #+(and genera (not clim)) "DW" #+clim-0.9 "CLIM-0-9" #+clim-1.0 "CLIM-1-0" #+clim-1.1 "CLIM-1-1" #+clim-2 "CLIM-2")) (namestring (make-pathname :directory (append (if base (pathname-directory base) '(:relative)) (list (string-downcase (format nil "~A~A-~A" prefix instruction-set gui)))))))) (defsys:defsystem dwim (:default-pathname *load-pathname* :default-binary-pathname (suggest-bin-directory) :default-optimizations () :patch-file-pattern NIL :needed-systems () :load-before-compile ()) ("package") ("feature-case" :load-before-compile ("package")) ("macros" :load-before-compile ("feature-case")) ("tv" :load-before-compile ("macros")) ("draw" :load-before-compile ("tv")) ("present" :load-before-compile ("draw")) ("extensions" :load-before-compile ("present")) ("wholine" :load-before-compile ("extensions")) ("export" :load-before-compile ("wholine")) ) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/dwim/extensions.lisp0000640000175000017500000004112210561555366023502 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: DWIM -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :dwim) ;;;***************** ;;; Lisp Extensions ;;;***************** #-(and) (unless (fboundp 'ignore) ;; Define IGNORE to be like our old friend from Genera. ;; This practice is frowned upon because IGNORE is in the ;; common lisp package (it is a declaration) and changing ;; anything about those symbols is frowned upon. So we ;; should learn to live without this old friend some day. #FEATURE-CASE ((:allegro (excl:without-package-locks (setf (symbol-function 'ignore) #'(lambda (&rest args) (declare (ignore args) (dynamic-extent args)) nil)))) ((not allegro) (unless (fboundp 'ignore) (setf (symbol-function 'ignore) #'(lambda (&rest args) (declare (ignore args) (dynamic-extent args)) nil)))))) (defmacro with-rem-keywords ((new-list list keywords-to-remove) &body body) `(let ((,new-list (with-rem-keywords-internal ,list ,keywords-to-remove))) ,@body)) (defun with-rem-keywords-internal (keyword-list keywords-to-remove) ;; Remove leading keywords. (loop (unless (member (car keyword-list) keywords-to-remove) (return)) (setf keyword-list (cddr keyword-list))) (when keyword-list (do* ((kwl keyword-list cons2) (cons1 (cdr kwl) (cdr kwl)) (cons2 (cdr cons1) (cdr cons1))) ((null cons2) keyword-list) (when (member (car cons2) keywords-to-remove) (setf (cdr cons1) (cddr cons2)) (setf cons2 kwl))))) (defun rem-keywords (list keywords-to-remove) (with-rem-keywords (new-list list keywords-to-remove) (copy-list new-list))) ;;;Still need Genera (eval-when (compile eval load) #+lucid (import '(#-clim-1.0 lcl:*load-pathname* lcl:*source-pathname*)) #+allegro (import 'excl:*source-pathname*)) #1feature-case ((:lucid (eval-when (compile eval load) ;;Just use the existing Lucid definition (import 'lcl:working-directory))) (:allegro (defun working-directory () (excl:current-directory)) (defsetf working-directory excl:chdir))) ;;; ************************** ;;; UNIX Environmental Support ;;; ************************** (defun getenv (string) "Get the value of the environment variable named STRING." (assert (stringp string)) #FEATURE-CASE ((:lucid (lucid::environment-variable string)) (:allegro (system:getenv string)) (:genera (let ((symbol (intern string :scl))) (and (boundp symbol) (symbol-value symbol)))) (:openmcl (ccl::getenv string)) (:sbcl (sb-ext:posix-getenv string)) (:scl (cdr (assoc string ext:*environment-list* :test #'string=))) )) #+allegro ;;>> Allegro 4.2 supports SYSTEM:GETENV. How do I set an environment variable? ;;>> I expected a SETF method or a SETENV function. ;;Franz sez: Well here's one way of doing it: foreign call putenv from libc.a. (progn (load "" :unreferenced-lib-names `(,(ff:convert-to-lang "putenv"))) (ff:defforeign 'putenv :arguments '(integer))) #+sbcl (sb-alien:define-alien-routine ("putenv" putenv) sb-alien:int (name sb-alien:c-string)) (defsetf getenv (string) (new-value) #FEATURE-CASE ((:allegro `(putenv (ff:string-to-char* (format nil "~A=~A" ,string ,new-value)))) (:lucid `(setf (lcl:environment-variable ,string) ,(princ-to-string new-value))) (:genera `(setf (symbol-value ,(intern string :scl)) ,new-value)) (:openmcl `(ccl::setenv string new-value)) (:sbcl `(putenv (format nil "~A=~A" ,string ,new-value))))) (defun run-shell-command (command &rest args &key input output error-output (wait t) arguments if-input-does-not-exist if-output-exists if-error-output-exists) "Runs a shell command. See documentation for Allegro CL version of this for return value details. Command can include the arguments, or they can be additionally be specified by the :ARGUMENTS keyword arg." (declare (ignore input output error-output if-input-does-not-exist if-output-exists if-error-output-exists #-lucid wait)) (assert (listp arguments)) ;;Should be a list of strings (let ((command-with-arguments (format nil "~A~{ ~A~}" command arguments))) #FEATURE-CASE ((:allegro (with-rem-keywords (args1 args '(:arguments)) (apply #'excl:run-shell-command command-with-arguments args1))) (:lucid (let* ((end-of-command-pos (position #\space command-with-arguments :test #'char=)) (command-only (if end-of-command-pos (subseq command-with-arguments 0 end-of-command-pos) command-with-arguments)) (real-arguments (string-trim " " (subseq command-with-arguments end-of-command-pos)))) (with-rem-keywords (args1 args '(:arguments)) (multiple-value-bind (stream1 stream2 exit-status process-id) (apply #'lcl:run-program command-only :arguments real-arguments args1) (if wait exit-status (values stream1 stream2 process-id)))))) ((and :mcl (not :openmcl)) (with-rem-keywords (args1 args '(:arguments)) (apply #'ccl:run-fred-command command-with-arguments args1))) ((or :openmcl :sbcl) (with-rem-keywords (args1 args '(:arguments)) (apply #+sbcl #'sb-ext:run-program #+openmcl #'ccl:run-program command arguments args1))) (:genera (not-done))))) (defun current-process () #FEATURE-CASE ((:genera process::*current-process*) (:allegro mp::*current-process*) (:lucid nil) (:clim-1.0 clim-utils::*current-process*) (:clim-2 (clim-sys:current-process)))) (defun process-wait (whostate predicate) #FEATURE-CASE ((genera (scl:process-wait whostate predicate)) (lucid (lcl:process-wait whostate predicate)) (allegro (mp:process-wait whostate predicate)) (clim-1.0 (clim-utils:process-wait whostate predicate)) (clim-2 (clim-sys:process-wait whostate predicate)))) (defun process-run-function (name-or-keywords function &rest args) (let* ((new-args (copy-list args)) ; in case of stack-allocation (predicate (if args #'(lambda () (apply function new-args)) function))) #FEATURE-CASE ((:ALLEGRO (funcall #'mp:process-run-function name-or-keywords predicate)) (:GENERA (funcall #'scl:process-run-function name-or-keywords predicate)) (:LUCID (flet ((lucid-procees-run-function-hack (NAME-OR-KEYWORDS &rest FNCT-LIST) (let ((FNCT-NAME (first FNCT-LIST)) (FNCT-ARGS (copy-list (cdr FNCT-LIST)))) (if (consp NAME-OR-KEYWORDS) (apply #'lcl::make-process :function FNCT-NAME :args FNCT-ARGS NAME-OR-KEYWORDS) (lcl::make-process :name NAME-OR-KEYWORDS :function FNCT-NAME :args FNCT-ARGS))))) (apply #'lucid-procees-run-function-hack name-or-keywords function args))) ((and :MCL (not :openmcl)) ;; No multiprocessing. Fake it. (funcall predicate)) (:CLIM-1.0 (clim-utils::make-process predicate :name name-or-keywords)) ((and :clim-2 :cmu (not :x86)) ;; This is a hack for CMUCL (funcall predicate)) (:CLIM-2 ;; The Spec says that make-process takes a keyword arg... -- moore (CLIM-SYS:make-process predicate #+mcclim :name name-or-keywords))))) (defun activate-process (p) #FEATURE-CASE ((:lucid (lcl::activate-process p)) (:allegro (mp:process-enable p)) (:clim-2 (clim-sys:enable-process p)))) (defun deactivate-process (p) #FEATURE-CASE ((:lucid (lcl::deactivate-process p)) (:allegro (mp:process-disable p)) (:clim-2 (clim-sys:disable-process p)))) (defun process-interrupt (p function &rest args) #FEATURE-CASE ((:allegro (apply #'mp:process-interrupt p function args)))) (defun kill-process (p) #FEATURE-CASE ((:genera (process:kill p)) (:clim-0.9 (ci::destroy-process p)) (:clim-1.0 (clim-utils:destroy-process p)) (:clim-2 (clim-sys:destroy-process p)))) (defmacro with-process-lock ((lock) &body body) "Grant current process exclusive access to some resource. Wait for access if necessary." #+allegro `(progn (or ,lock (setf ,lock (mp:make-process-lock))) (mp:with-process-lock (,lock) ,@body)) #+lucid `(lucid::with-process-lock (,lock) ,@body) #+clim-2 `(clim-sys:with-lock-held (,lock) ,@body) #+genera (let ((me (gensym))) `(let ((,me scl:*current-process*)) (if (eq ,lock ,me) (error "Lock already locked by this process.")) (unwind-protect (if (or (si:store-conditional (scl:locf ,lock) nil ,me) (and (process::safe-to-process-wait-p scl:*current-process*) (scl:process-wait "Lock" #'(lambda (locative) (declare (sys:downward-function)) (si:store-conditional locative nil ,me)) (scl:locf ,lock)))) (when (eq ,lock ,me) ,@body)) (si:store-conditional (scl:locf ,lock) ,me nil))))) ;;;Loop unrolling can increase the performance of big loops by 10 to 30% if the body ;;; is fast relative to the price of an iteration. Here is a portable version of ;;; DOTIMES that unrolls its body. The argument BLOCKING must be an integer; the ;;; compiler unrolls the loop BLOCKING number of times. A good number to use is 8. ;;; Avoid choosing a really big integer because your compiled code will be huge. (defmacro dotimes-unrolled ((var init countform blocking &optional resultform) &body body) (unless (integerp blocking) (error "To unroll this loop, ~S must be an integer." blocking)) `(let ((,var ,init)) (dotimes (ignore (floor ,countform ,blocking)) ,@(let ((result nil)) (setq body (append body `((incf ,var)))) (dotimes (ignore blocking) (setq result (nconc (copy-list body) result))) result)) (dotimes (ignore (mod ,countform ,blocking) ,resultform) ,@body))) #+test (defun roll-test (n) (let ((number 2.1)) (multiple-value-bind (val time) (the-time (dotimes (i n) (* number number))) (print val) (print time)) (multiple-value-bind (val time) (the-time (dotimes-unrolled (i 0 n 20) (* number number))) (print val) (print time)) )) ;;; Zetalisp function. (defmethod instancep ((object t)) nil) (defmethod instancep ((object standard-object)) t) (defun type-specifier-p (object) "Determine if OBJECT is a valid type specifier" ;; A somewhat consful implementation, but entirely portable. (let ((test #'(lambda (x) (typep 't x)))) (when (or (symbolp object) (listp object)) (multiple-value-bind (v errorp) (ignore-errors (funcall test object)) (declare (ignore v)) (not errorp))))) (defun file-type-for-binaries () #FEATURE-CASE ((:genera si:*default-binary-file-type*) ((or :allegro :sbcl) #.(if (fboundp 'compile-file-pathname) (pathname-type (compile-file-pathname "foo")) "fasl")) (:scl (pathname-type (compile-file-pathname "foo"))) (:lucid (car lcl:*load-binary-pathname-types*)) (:mcl #.(pathname-type ccl:*.fasl-pathname*)) )) (defun file-type-for-sources () #FEATURE-CASE ((:genera "LISP") (:unix "lisp") (:mcl "lisp") )) ;;;************ ;;; DUMPER ;;;************ ;;; Here is the simplest possible dumper that worries about the EQ-ness of shared ;;; objects. Objects that satisfy INSTANCEP are put into a hash table. References ;;; to such objects are replaced with corresponding GETHASH forms: ;;; ;;; `(progn (setq frog #) (setq reptile #)) ;;; ;;; becomes something like ;;; ;;; (let ((*dump-table* (make-hash-table))) ;;; (setf (gethash 0 *dump-table*) (make-instance 'frog)) ;;; (progn (setq frog (gethash 0 *dump-table*))) ;;; (setq reptile (gethash 0 *dump-table*)))) ;;; ;;; Thus the dumper augments the forms being dumped with appropriate calls to ;;; MAKE-HASH-TABLE and GETHASH. Thus any Common Lisp reader is sufficient ;;; to parse this ASCII file. ;;; ;;; KRA has pointed out that when you load via (EVAL (READ)), the form being read ;;; can be as large as the object being recreated. After the EVAL, the form is ;;; thrown away, which may be somewhat difficult for the GC to swallow if it is ;;; large. A better dumper would be more considerate of the GC. ;;; ;;; Some day, this dumper should probably be extended to worry about structure-sharing ;;; of all structures, particularly lists and instances of STRUCTURE-OBJECT. (defvar *dump-table* (make-hash-table) "Hash table used by the dumper.") (defvar *dump-index* 0 "Counter used by the dumper.") (defmacro writing-dump-file ((stream-var file) &body body) `(let ((*dump-table* (make-hash-table)) (*dump-index* 0)) (with-open-file (,stream-var ,file :direction :output :if-exists :supersede) ,@body))) (defun enter-table (object) (setf (gethash object *dump-table*) t) (incf *dump-index*)) (defun finish-enter-table (object index) (setf (gethash object *dump-table*) (1- index))) (defun dump-form-to-eval (form stream) "Dump a form directly to the stream." (print form stream)) (defun dump-instance (object stream) "Use MAKE-LOAD-FORM to dump this object to the stream." (multiple-value-bind (maker initializer) (make-load-form object) (let ((index (enter-table object)) (symbol (intern "*DUMP-TABLE*"))) (dump-form-to-file `(setf (gethash ,(1- index) ,symbol) ,maker) stream) (finish-enter-table object index) (when initializer (dump-form-to-file initializer stream))))) (defun dump-form-to-file (form stream) "Dump a form that may refer to instances." (labels ((tree-search (tree predicate) (if (atom tree) (if (funcall predicate tree) (return-from tree-search t) nil) (dolist (element tree) (if (tree-search element predicate) (return-from tree-search t))))) (need-full-dump (object) (or (instancep object) (and (arrayp object) (not (stringp object))) (hash-table-p object ))) (traverse (form) (let (index) (cond ((need-full-dump form) (cond ((setq index (gethash form *dump-table*)) (if (not (numberp index)) (error "Circular dependency encountered.") `(gethash ,index ,(intern "*DUMP-TABLE*")))) (t (dump-instance form stream) (traverse form)))) ((atom form) form) ((not (eq (first form) 'quote)) ;; The normal case, an unquoted form. (mapcar #'traverse form)) ((tree-search form #'need-full-dump) ;; KRA has pointed out that LIST can take no more than 512 ;; arguments in Lucid. That means the following will break ;; if the list is a long one. (if (atom (second form)) (traverse (second form)) ; quoted instance (traverse ; list contains instances `(list ,@(mapcar #'(lambda (x) `(quote ,x)) (second form)))))) (t form))))) (dump-form-to-eval (traverse form) stream))) (defun dump-objects-to-file (file objects &optional (package #+ansi-cl :common-lisp-user #-ansi-cl :user)) "Use the MAKE-LOAD-FORM protocol to dump a list of objects to the specified file." (or (and (symbolp package) (find-package package)) (error "Package ~A does not exist" package)) (setq file (namestring (pathname file))) (let ((*package* (find-package package))) (writing-dump-file (stream file) (format stream ";-*- Package: ~A; Syntax: Common-Lisp -*-" (package-name *package*)) (format stream "~%(lisp::in-package ~S)" (package-name *package*)) (format stream "~%(let ((~S (make-hash-table)))" (intern "*DUMP-TABLE*")) (dolist (object objects) (dump-instance object stream)) (format stream "~%)")))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/dwim/load-dwim.lisp0000640000175000017500000001211010561555366023153 0ustar pdmpdm;; -*- mode: common-lisp; package: user -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package #-ansi-cl :user #+ansi-cl :common-lisp-user) #-clim (eval-when (compile load eval) (when (find-package 'clim) (pushnew :clim *features*))) ; Add a CLIM feature. ;;; McCLIM tries to implement the spec for CLIM 2.0, so :clim-2 should ;;; generally be appropriate. Except when clim-2 is used to ;;; conditionalize access to internal CLIM functions... #+mcclim (eval-when (compile load eval) (pushnew :clim-2 *features*)) (eval-when (compile load eval) ;; CLIM 1 doesn't affect the *features*. Here's a rule of thumb ;; that seems to work. (when (and (find-package 'clim) (not (boundp (intern "CLIM-VERSION" 'clim))) ; from clim 0.9 (not (fboundp (intern "STREAM-CURSOR-POSITION" 'clim))) ; from clim 2 (not (member :clim-2 *features*)) (not (member :clim-0.9 *features*))) (pushnew :clim-1 *features*) (pushnew :clim-1.0 *features*))) (defun file-type-for-sources () #+MCL #.(pathname-type *.lisp-pathname*) #+genera "LISP" #+unix "lisp" #+(and (not mcl) (not genera) (not unix)) (error "Not yet implemented.")) (defun file-type-for-binaries () #+MCL #.(pathname-type *.fasl-pathname*) #+genera si:*default-binary-file-type* #+(or allegro sbcl) #.(if (fboundp 'compile-file-pathname) (pathname-type (compile-file-pathname "foo")) "fasl") #+scl (pathname-type (compile-file-pathname "foo")) #+lucid (car lcl:*load-binary-pathname-types*) #+(and (not genera) (not allegro) (not lucid) (not mcl) (not sbcl)) (error "Not yet implemented.")) #+genera (setq *load-pathname* (make-pathname :defaults si:fdefine-file-pathname :name nil :type nil :version nil)) (defun suggest-bin-directory (&optional (base *load-pathname*) (prefix "BIN-")) ;; The number of different binaries you must have is ;; the cross product of the instruction set and the gui. (let ((instruction-set #+(and :mcl (not :openmcl)) "MCL" #+GENERA "GENERA" #+LUCID "LUCID" #+ALLEGRO "ALLEGRO" #+OPENMCL "OPENMCL" #+SBCL "SBCL" #+scl "SCL") (GUI #+(and mcl (not clim)) "MAC" #+(and genera (not clim)) "DW" #+clim-0.9 "CLIM-0-9" #+clim-1.0 "CLIM-1-0" #+clim-1.1 "CLIM-1-1" #+clim-2 "CLIM-2")) (namestring (make-pathname :directory (append (if (and base (pathname-directory base)) (pathname-directory base) '(:relative)) (list (string-downcase (format nil "~A~A-~A" prefix instruction-set gui)))))))) (defun compile-and-load-file (name) (let* ((source-dir (make-pathname :defaults *load-pathname* :name name)) (source (make-pathname :defaults source-dir :type (file-type-for-sources))) (bin-dir (suggest-bin-directory *load-pathname*)) (binary (make-pathname :defaults bin-dir :name name :type (file-type-for-binaries)))) (ensure-directories-exist bin-dir) (when (or (not (probe-file binary)) (< (file-write-date binary) (file-write-date source))) (compile-file source :output-file binary)) (load binary))) (eval-when (load eval) (map nil #'compile-and-load-file '( "package" "feature-case" "macros" "tv" "draw" "present" "extensions" "wholine" "export" ))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/dwim/present.lisp0000600000175000017500000010243210423413302022735 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: DWIM -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :dwim) #+clim ;;; I guess this is as good of a place as any to put this. (make-command-table :global) #+clim (defun continuation-output-rectangle (continuation stream) ;; Repositioning the cursor seems to improve the reliability of ;; this computation in clim 0.9. #-clim-2 (with-output-truncation (stream) (multiple-value-bind (x y) (stream-cursor-position* stream) (unwind-protect (progn (stream-set-cursor-position* stream 100 100) (let ((record (clim:with-output-to-output-record (stream) (funcall continuation stream)))) (clim:bounding-rectangle record))) (stream-set-cursor-position* stream x y)))) #+clim-2 (let ((record (clim:with-output-to-output-record (stream) (funcall continuation stream)))) (clim:bounding-rectangle record))) (defun continuation-output-size (continuation stream) ;;(declare (values width height)) #FEATURE-CASE (((not :clim) (dw:continuation-output-size continuation stream)) (:clim-0.9 (multiple-value-bind (width height) (clim:bounding-rectangle-dimensions (continuation-output-rectangle continuation stream)) ;; edges can be floats, so truncate them. (values (truncate width) (truncate height)))) ((or :clim-1.0 :clim-2) (clim:rectangle-size (continuation-output-rectangle continuation stream))))) ;;; ;;; Manipulating presentations ;;; #+clim-1.0 (progn (clim:define-gesture-name :left :button :left) (clim:define-gesture-name :middle :button :middle) (clim:define-gesture-name :right :button :right)) #+clim-2 (progn (clim:define-gesture-name :left :pointer-button :left) (clim:define-gesture-name :middle :pointer-button :middle) (clim:define-gesture-name :right :pointer-button :right)) (defun erase-graphics-presentation (presentation &key (stream *standard-output*)) #FEATURE-CASE (((not :clim) ;; Ordinarily, graphics:erase-graphics-presentation would be the right thing. ;; This modification makes one slight change to the procedure ;; so that the entire area is cleared at once, rather than erasing ;; every inferior ad nauseum. (when (typep stream 'dw:dynamic-window) (labels ((eraser (p) (when (typep p 'dw:presentation) (dolist (inf (scl:symbol-value-in-instance p 'dw::inferiors)) (eraser inf)) (setf (scl:symbol-value-in-instance p 'dw::inferiors) nil)) ;; delete from coordinate sorted set of window: (if (typep p 'dw::text-displayed-presentation) (dw::erase-displayed-presentation p stream t nil t) (send stream :delete-graphics-displayed-presentation p)))) (eraser presentation)) ;; Delete from superior's list of inferiors: (send stream :delete-displayed-presentation presentation) ;; Clear the rectangle and redraw overlapping presentations: (send stream :redraw-inside-sets (dw:presentation-displayed-box presentation) t))) ((or :clim-0.9 :clim-1.0) ;; If clim can't find the presentation, it signals an error. ;; As far as I'm concerned, if it can't find it, it's as good as erased. (multiple-value-bind (value errorp) (ignore-errors (clim:erase-output-record presentation stream)) (if errorp ;; If an error happened, the display is probably screwed up. ;; So beep to admit responsibility and try somehow to recover. (progn #+ig (beep) (clim:output-recording-stream-replay stream presentation)) value))) (:clim-2 (clim:erase-output-record presentation stream nil)))) (defun presentation-under-pointer (stream) #FEATURE-CASE (((not :clim) (scl:send stream :last-highlighted-presentation)) (:clim-0.9 (ci::highlighted-presentation stream)) (:clim-1.0 (multiple-value-bind (x y) (clim:stream-pointer-position* stream) (clim::find-innermost-applicable-presentation '((t)) stream x y))) (:clim-2 (multiple-value-bind (x y) (clim:stream-pointer-position stream) (clim::find-innermost-applicable-presentation '((t)) stream x y))))) (defun presentation-p (object) #FEATURE-CASE (((not :clim) (typep object 'dw::presentation)) (:clim-0.9 (ci::presentation-p object)) ((or :clim-1.0 :clim-2) (typep* object 'clim:presentation)))) (defun presentation-superior (presentation) #+clim (clim:output-record-parent presentation) #-clim (dw:presentation-superior presentation)) (defun presentation-object (presentation) #-clim (dw:presentation-object presentation) #+clim (if (presentation-p presentation) (clim:presentation-object presentation))) (defun presentation-subtypep (subtype supertype) #-clim (dw:presentation-subtypep subtype supertype) #+clim (clim:presentation-subtypep subtype supertype)) (defun presentation-type-p (type) #-clim (dw:presentation-type-p type) #+clim (clim:presentation-type-specifier-p type)) (defun describe-presentation-type (type &optional (stream *standard-output*)) #-clim (dw:describe-presentation-type type stream) #+clim (clim:describe-presentation-type type stream)) (defun bounding-rectangle* (presentation) "Get the bounding edges of the presentation." ;;(declare (values left top right bottom)) #FEATURE-CASE (((not :clim) (when (presentation-p presentation) (let ((box (dw:presentation-displayed-box presentation))) (if box (dw:box-edges box))))) (:clim-0.9 (multiple-value-bind (left top right bottom) (clim:bounding-rectangle* presentation) ;; edges can be floats, so truncate them. (values (truncate left) (truncate top) (truncate right) (truncate bottom)))) ((or :clim-1.0 :clim-2) (let ((stream *standard-output*)) ;; Seem to need to know the stream under the presentation. ;; Take a wild guess. (multiple-value-bind (xoff yoff) (#-mcclim clim::convert-from-relative-to-absolute-coordinates #+mcclim climi::convert-from-relative-to-absolute-coordinates stream (clim::output-record-parent presentation)) (clim:with-bounding-rectangle* (left top right bottom) presentation (values (+ left xoff) (+ top yoff) (+ right xoff) (+ bottom yoff)))))))) (defun redisplay (record stream) #FEATURE-CASE (((not :clim) (dw:do-redisplay record stream :truncate-p nil)) ((or :clim-1.0 :clim-2) (clim:redisplay record stream :check-overlapping nil)))) (defun redisplayable? (stream) #FEATURE-CASE ((:clim-2 (clim:redisplayable-stream-p stream)) (:clim-1.0 (clim:stream-redisplayable-p stream)) (:clim-0.9 (clim-internals::stream-redisplayable-p stream)) ((not :clim) stream))) (defun redisplayable-format (stream string &rest args) (if (eq stream 't) (setq stream *standard-output*)) (if (redisplayable? stream) (let ((a (copy-list args))) (with-redisplayable-output (:stream stream :unique-id string :cache-value a :cache-test #'equal) (apply #'format stream string a))) (apply #'format stream string args))) (defun accept (presentation-type &key (view nil view-p) (stream *standard-output*) (prompt #+clim t #-clim :enter-type) default query-identifier) #FEATURE-CASE (((not :clim) (dw:accept presentation-type :stream stream :prompt prompt :default default :query-identifier query-identifier :newline-after-query nil)) (:clim-0.9 (clim:accept presentation-type :stream stream :prompt prompt :default default :query-identifier query-identifier)) ((or :clim-1.0 :clim-2) (if view-p (clim:accept presentation-type :view view :stream stream :prompt prompt :default default :display-default nil :query-identifier query-identifier) (clim:accept presentation-type :stream stream :prompt prompt :default default :display-default nil :query-identifier query-identifier))))) #+(and clim-1.0 (not mcl)) (progn ;;CLIM additions to the input editor to conform to my old EMACs ways (clim::add-input-editor-command #\meta-< 'clim::com-ie-beginning-of-buffer) (clim::add-input-editor-command #\meta-> 'clim::com-ie-end-of-buffer) (clim::add-input-editor-command #\meta-\b 'clim::com-ie-backward-word) (clim::add-input-editor-command #\meta-\f 'clim::com-ie-forward-word) (clim::add-input-editor-command #\meta-rubout 'clim::com-ie-rubout-word) (clim::add-input-editor-command #\meta-\d 'clim::com-ie-delete-word) (clim::add-input-editor-command #\control-meta-\y 'clim::com-ie-history-yank) (clim::add-input-editor-command #\meta-\y 'clim::com-ie-yank-next) (clim::add-input-editor-command #\meta-\v 'clim::com-ie-scroll-backward)) ;;;Alas there is no key so let's fake it out with the key #+(and clim-1.0 (not genera) (not mcl)) (clim::define-accept-values-command (com-exit-avv :keystroke #\control-\d) () (invoke-restart 'clim::frame-exit)) (defun accept-values (descriptions &key (prompt nil) (stream *query-io*) (own-window nil)) (values-list (accepting-values (stream :own-window own-window :label prompt) (mapcar #'(lambda (description) (destructuring-bind (type &rest options) description (prog1 (apply #'accept type :stream stream :query-identifier (getf options :query-identifier (car description)) options) (terpri stream)))) descriptions)))) (defun menu-choose (choices &key (prompt "Choose:") default-choice) #FEATURE-CASE ((:clim-0.9 (prog1 (clim:menu-choose choices :label prompt :associated-window *standard-input* :default-item default-choice ) ;; kludge city. menu-lose leaves your mouse click in the buffer. (stream-clear-input *standard-input*))) (:clim-1.0 (clim:menu-choose choices :associated-window *standard-input* :label prompt :default-item default-choice)) (:clim-2 (clim:menu-choose choices :associated-window *standard-input* :label prompt :default-item default-choice)) ((not :clim) (dw:menu-choose choices :prompt prompt)))) ;;; ;;; formatting table etc. ;;; (defmacro formatting-table ((stream &key (inter-column-spacing 8)) &body body) #FEATURE-CASE (((not :clim) `(dw:formatting-table (,stream :dont-snapshot-variables t :inter-column-spacing ,inter-column-spacing) ,@body)) (:clim-0.9 `(clim:formatting-table (,stream) ,@body)) (:clim-1.0 `(clim:formatting-table (,stream :inter-column-spacing ,inter-column-spacing) ,@body)) (:clim-2 `(clim:formatting-table (,stream :x-spacing ,inter-column-spacing) ,@body)))) (defmacro formatting-row ((stream) &body body) #-clim `(dw:formatting-row (,stream :dont-snapshot-variables t) ,@body) #+clim `(clim:formatting-row (,stream) ,@body)) (defmacro formatting-column ((stream) &body body) #-clim `(dw:formatting-column (,stream :dont-snapshot-variables t) ,@body) #+clim `(clim:formatting-column (,stream) ,@body)) (defmacro formatting-column-headings ((stream &key (underline-p nil)) &body body) #-clim `(dw:formatting-column-headings (,stream :underline-p ,underline-p :dont-snapshot-variables t) ,@body) ;; dont have the time to do this one justice. #+clim (if underline-p `(formatting-row (,stream) (with-underlining (,stream) ,@body)) `(formatting-row (,stream) ,@body))) (defmacro formatting-cell ((stream &key (align-x :left) align-y) &body body) #+clim `(clim:formatting-cell (,stream ,@(if align-x `(:align-x ,align-x)) ,@(if align-y `(:align-y ,align-y))) ,@body) #-clim `(dw:formatting-cell (,stream :align-x ,align-x :align-y ,align-y) ; :dont-snapshot-variables t ;;++This seems to not work ,@body)) (defmacro formatting-item-list ((stream &rest options) &body body) #+clim `(clim:formatting-item-list (,stream ,@options) ,@body) #-clim `(dw:formatting-item-list (,stream ,@options) ,@body)) (defmacro format-item-list (list &rest keys) #-clim `(dw:format-item-list ,list ,@keys) #+clim (let ((stream (or (second (member :stream keys)) t))) `(formatting-item-list (,stream) (dolist (item ,list) (formatting-cell (,stream) (format ,stream "~A" item)))))) ;;; ;;; Presentation parser primitives ;;; (defun read-char-for-accept (stream) #+clim (read-char stream nil nil) #-clim (let ((char (loop thereis (send stream :any-tyi) until (not (interactive-stream-p stream ))))) ;bug in IE (cond ((listp char) char) #+dw-is-brain-damaged ((accept-blip-p char) (list ':accept char nil)) (t char)))) (defun unread-char-for-accept (char stream) #FEATURE-CASE (((or :clim-0.9 :clim-1.0) (if (clim::activation-character-p char) ;; unreading an activation character causes problems for stream-unread-gesture. (clim:with-activation-characters (nil :override t) (unread-char char stream)) (unread-char char stream))) (:clim-2 (if (clim:activation-gesture-p char) ;; unreading an activation character causes problems for stream-unread-gesture. (clim:with-activation-gestures (nil :override t) (unread-char char stream)) (unread-char char stream))) ((not :clim) (dw:unread-char-for-accept char stream)))) (defun peek-char-for-accept (stream &optional hang) (let ((ch (and (or hang (not (interactive-stream-p stream)) (< (input-position stream) (insertion-pointer stream))) (read-char-for-accept stream)))) (when ch (unread-char-for-accept ch stream)) ch)) (defun compare-char-for-accept (char-from-accept comparandum) (and char-from-accept (typecase char-from-accept (character (char-equal comparandum char-from-accept)) (list ;; this should only happen in DW. (and (member (first char-from-accept) '(:activation :blip-character :accept)) (characterp (second char-from-accept)) (char-equal comparandum (second char-from-accept))))))) (defun read-token (stream) #+clim (clim:read-token stream) #-clim (dw:read-standard-token stream)) (defun input-position (stream) ;; This location identifies the current position of the parser in a (buffered) ;; input stream. When a character gets read by read-char-for-accept, this pointer ;; gets incremented. Upon failure, the parser backtracks by decrementing it. #FEATURE-CASE (((not :clim) (scl:send stream :read-location)) (:clim-0.9 (clim::input-position stream)) (:clim-1.0 (if (clim:extended-input-stream-p stream) (clim::input-position stream) (file-position stream))) (:clim-2 (if (clim:input-editing-stream-p stream) (clim:stream-scan-pointer stream) (file-position stream))))) (defmethod (setf input-position) (new stream) #FEATURE-CASE (((not :clim) (scl:send stream :set-location new)) (:clim-1.0 (if (clim:extended-input-stream-p stream) (setf (clim::input-position stream) new) (file-position stream new))) (:clim-2 (if (clim:input-editing-stream-p stream) (setf (clim:stream-scan-pointer stream) new) (file-position stream new))))) (defun insertion-pointer (stream) (cond ((interactive-stream-p stream) #FEATURE-CASE (((not :clim) (scl:send stream :typein-location)) (:clim-0.9 (ci::insertion-pointer stream)) (:clim-1.0 (clim::insertion-pointer stream)) (:clim-2 (clim:stream-insertion-pointer stream)))) (t ; string-input-stream #FEATURE-CASE ((:genera (scl:send stream :length)) (:allegro (slot-value stream 'excl::buffer-ptr)))))) (defvar *%%ready-to-catch%%* nil) (defmacro catching-parser-failures (form &rest failure-actions) "Use this to catch a parser failure and do something about it." (let ((normal (gensym))) `(let ((*%%ready-to-catch%%* t)) (catch ',normal (catch 'catch-parser-failures (handler-bind ((error #'(lambda (error) #+clim-2 (when (and (typep error 'clim:abort-gesture) (find-restart 'abort)) (invoke-restart 'abort)) (throw 'catch-parser-failures t)))) (throw ',normal ,form))) ,@failure-actions)))) (defun input-not-of-required-type (stream object type) "Use this to signal a parser failure and cause backtracking." (declare (ignore stream)) ;; Used by faes expression editor. Don't use the one from clim or dw, ;; it's so fancy that it outsmarts itself. (if *%%ready-to-catch%%* (throw 'catch-parser-failures t)) #FEATURE-CASE (((or clim-1.0 clim-2) (if (eq object :failure) (parse-error "The input read was not of the required type.") (clim:input-not-of-required-type object type))) (clim-0.9 (clim:input-not-of-required-type stream object type)) ((not clim) (zl:parse-ferror "The input read, ~A, was not ~A" object type)))) (defun parse-error (format-string &rest args) #FEATURE-CASE (((or :clim-0.9 :clim-1.0) (apply #'clim::parse-error format-string args)) (:clim-2 (apply #'clim:simple-parse-error format-string args)) ((not :clim) (apply #'sys::parse-error format-string args)))) (defun validate-object (object ptype) #FEATURE-CASE (((and (not :clim) :slow) (dw::ptypep object ptype)) ((not :clim) ;; This is at least 6x faster than dw::ptypep. I hope it works as well. (let ((name (cond ((symbolp ptype) ptype) ((symbolp (car ptype)) (car ptype)) (t (caar ptype))))) (cond ((member name '(t sys:expression)) t) ((member name '(and or not)) (return-from validate-object (typep object (if (or (symbolp ptype) (symbolp (car ptype))) ptype (car ptype))))) ((dw::with-type-descriptor ((type-desc expanded-type) ptype :exact-only t) (when type-desc (dw:with-type-decoded (type-sym type-dargs) expanded-type (declare (ignore type-sym)) (let* ((typep-function (dw::presentation-type-descriptor-typep-function type-desc)) (predicate (when typep-function (dw::compute-type-predicate typep-function type-dargs nil)))) (return-from validate-object (if predicate (funcall predicate object) t))))))) ((multiple-value-bind (flavor-or-class structure-p typep) (dw::symbol-flavor-or-cl-type name) (when (or flavor-or-class structure-p typep) (return-from validate-object (typep object (if (or (symbolp ptype) (symbolp (car ptype))) ptype (car ptype))))))) (t t)))) (:clim-0.9 (ci::validate-object object ptype)) ((or :clim-1.0 :clim-2) (let ((p (clim:expand-presentation-type-abbreviation ptype))) (clim::presentation-typep object p))))) (defmacro with-accept-activation-chars ((additional-characters &key override) &body body) #FEATURE-CASE (((not :clim) `(dw:with-accept-activation-chars (,additional-characters :override ,override) ,@body)) ((or :clim-0.9 :clim-1.0) `(clim:with-activation-characters (,additional-characters :override ,override) ,@body)) (:clim-2 `(clim:with-activation-gestures (,additional-characters :override ,override) ,@body)))) (defun accept-activation-p (char &optional (achars #-clim dw::*accept-activation-chars* #+clim-0.9 nil #+clim-1.0 clim:*activation-characters*)) (declare (ignore bchars)) (declare (ignorable achars)) #FEATURE-CASE ((:clim-0.9 (clim::activation-character-p char)) (:clim-2 (clim:activation-gesture-p char)) ((or :clim-1.0 :clim-2 (not :clim)) (and (if (consp char) (setq char (second char)) t) (dolist (l achars nil) (if (member char l) (return t))))))) (defmacro with-accept-blip-chars ((additional-characters &key override) &body body) #FEATURE-CASE (((not :clim) `(dw:with-accept-blip-chars (,additional-characters :override ,override) ,@body)) ((or :clim-0.9 :clim-1.0) `(clim:with-blip-characters (,additional-characters :override ,override) ,@body)) (:clim-2 `(clim:with-delimiter-gestures (,additional-characters :override ,override) ,@body)))) (defun accept-blip-p (char &optional (chars #-clim dw::*accept-blip-chars* #+clim-1.0 clim:*blip-characters* #+clim-0.9 nil)) (declare (ignorable chars)) #FEATURE-CASE ((:clim-0.9 (clim::blip-character-p char)) (:clim-2 (clim:delimiter-gesture-p char)) ((or :clim-1.0 :clim-2 (not :clim)) (loop for l in chars thereis (and (characterp char) (member char l :test #'char-equal)))))) (defmacro with-activation-characters ((additional-characters &key override) &body body) `(with-accept-activation-chars (,additional-characters :override ,override) ,@body)) (defmacro with-blip-characters ((additional-characters &key override) &body body) `(with-accept-blip-chars (,additional-characters :override ,override) ,@body)) (defmacro completing-from-suggestions ((stream &key delimiters allow-any-input (initially-display-possibilities nil idp) (type nil typep)) &body body) #+clim (declare (ignore initially-display-possibilities type)) #-clim (declare (ignore idp typep)) #-clim `(dw:completing-from-suggestions (,stream :allow-any-input ,allow-any-input :delimiters ,delimiters :type ,type :initially-display-possibilities ,initially-display-possibilities) ,@body) #+clim (progn (if idp (format t "~% completing-from-suggestions :initially-display-possibilities not supported.")) (if typep (format t "~% completing-from-suggestions :type not supported.")) `(clim:completing-from-suggestions (,stream :partial-completers ,delimiters :allow-any-input ,allow-any-input) ,@body))) (eval-when (compile load eval) (import #-clim 'dw::suggest #+clim 'clim:suggest 'dwim)) (defun complete-from-sequence (sequence stream &key type (name-key #'string)) #+clim (declare (ignore type)) (completing-from-suggestions (stream #-clim :type #-clim type) (map nil #'(lambda (elt) (suggest (funcall name-key elt) elt)) sequence))) ;;; JPM. This isn't really portable because it generates a ;;; DWish blip object. Use with-input-context below, if you can. (defmacro with-presentation-input-context ((PRESENTATION-TYPE &rest OPTIONS) (&optional (BLIP-VAR '.BLIP.)) NON-BLIP-FORM &body CLAUSES) #+Genera (declare (zwei:indentation 0 2 2 4 3 2)) #-clim `(dw:with-presentation-input-context (,PRESENTATION-TYPE ,@OPTIONS) (,BLIP-VAR) ,NON-BLIP-FORM ,@CLAUSES) #+clim `(clim:with-input-context (,PRESENTATION-TYPE :override ,(getf options :inherit)) (.object. .presentation-type. .gesture.) ,NON-BLIP-FORM ,@(mapcar #'(lambda (clause) `(,(first clause) (let ((,blip-var (list .presentation-type. .gesture. .object.))) ,blip-var ,@(rest clause)))) CLAUSES))) (defmacro with-input-context ((PRESENTATION-TYPE &key OVERRIDE STREAM) (&optional (OBJECT-VAR '.object.) (PT-VAR '.presentation-type.) (GESTURE-VAR '.gesture. gesture-p)) NON-BLIP-FORM &body CLAUSES) #+Genera (declare (zwei:indentation 0 2 2 4 3 2)) #-clim (let ((blip-var '.blip.)) `(dw:with-presentation-input-context (,PRESENTATION-TYPE :inherit (not ,override) :stream ,stream) (,BLIP-VAR) ,NON-BLIP-FORM ,@(mapcar #'(lambda (clause) `(,(first clause) (let ((,object-var (dw:presentation-blip-object ,blip-var)) (,pt-var (dw:presentation-blip-presentation-type ,blip-var)) (,gesture-var (dw:presentation-blip-mouse-char ,blip-var))) (and ,object-var ,pt-var ,gesture-var) ,@(rest clause)))) clauses))) #+clim (declare (ignore stream)) #+clim `(clim:with-input-context (,PRESENTATION-TYPE :override ,OVERRIDE) (,OBJECT-VAR ,PT-VAR ,@(if gesture-p GESTURE-VAR)) ,NON-BLIP-FORM ,@CLAUSES)) ;;; ;;; Presentation types ;;; (define-presentation-type sheet () :parser ((stream) #+clim (progn (read-char stream) (error "The SHEET presentation type is broken. Sorry.")) #-clim (dw:accept 'tv:sheet :stream stream :prompt nil)) :printer ((window stream) (let ((*print-readably* nil)) #-ansi-cl (declare (special *print-readably*)) #+clim (format stream "~A" window) #-clim (present window 'tv:sheet :stream stream))) :description "a window") #-clim (eval-when (compile load eval) (import 'dw:alist-subset 'dwim)) #+(or clim-1.0 clim-2) (clim:define-presentation-type-abbreviation alist-member (&key alist (test 'eql)) `(clim:member-alist ,alist :test ,test)) (defun menu-execute-no-side-effects (item) (cond ((atom item) item) ((atom (cdr item)) (cdr item)) ((atom (cddr item)) (cadr item)) ((eq (second item) :value) (third item)))) (defun token-element-string (element) (typecase element (null (symbol-name element)) (cons (string (first element))) (symbol (string-capitalize (symbol-name element))) (string element) (otherwise (present-to-string element)))) (defun make-accept-values-choices (&key query-identifier sequence select-action) (declare (ignorable sequence)) #FEATURE-CASE ((:clim-2 (clim-internals::make-accept-values-multiple-choices :query-identifier query-identifier :select-action select-action)) (:clim-1.0 (clim::make-accept-values-multiple-choices :query-identifier query-identifier :select-action select-action)) (:clim-0.9 (ci::make-accept-values-choices :query-identifier query-identifier :sequence sequence :select-action select-action)) ((not :clim) (dw::make-accept-values-choices :query-identifier query-identifier :sequence sequence :select-action select-action)))) (defun make-accept-values-choice (&key choices choice value documentation) #+clim (declare (ignore documentation)) (declare (ignorable choice)) #FEATURE-CASE ((:clim-2 (clim-internals::make-accept-values-multiple-choice :choices choices :value value)) (:clim-1.0 (clim::make-accept-values-multiple-choice :choices choices :value value)) (:clim-0.9 (ci::make-accept-values-choice :choices choices :choice choice :value value)) ((not :clim) (dw::make-accept-values-choice :choices choices :choice choice :value value :documentation documentation)))) (defun type-for-avv-choice () #FEATURE-CASE ((:clim-2 'clim-internals::accept-values-one-of) (:clim-1.0 'clim::accept-values-one-of) (:clim-0.9 'ci::accept-values-choice-display) ((not :clim) 'dw::accept-values-choice-display))) (defun accept-values-choose-from-sequence (stream sequence selected-value query-identifier &key drawer select-action n-columns n-rows (selection-test #'eq) (value-key #'menu-execute-no-side-effects) (name-key #'token-element-string) (choice-type (type-for-avv-choice)) (make-choices #'make-accept-values-choices) (make-choice #'make-accept-values-choice)) "Used for the ACCEPT-VALUES method of some presentation types." ;; This is how ALIST-MEMBER works. ;; DRAWER: how to draw an element in the sequence. ;; SELECT-ACTION: how to combine the selected choice with the default value. (when (not drawer) (setq drawer #'(lambda (str obj name selected) (declare (ignore obj)) (formatting-cell (str) (if selected (with-text-face (:bold str) (write-string name str)) (write-string name str)))))) (when (not select-action) (setq select-action #'(lambda (choice default-val) (declare (ignore default-val)) choice))) (let ((choices (funcall make-choices :query-identifier query-identifier :sequence sequence :select-action select-action)) ;;(width (- (stream-viewport-size stream) (stream-cursor-position* stream))) ) (labels ((draw-one (item value pretty-name selected-p stream) (with-output-as-presentation (:type choice-type :stream stream :object (funcall make-choice :choices choices :choice item :value value :documentation pretty-name) :single-box t) #+clim-0.9 (formatting-cell (stream) (funcall drawer stream value pretty-name selected-p)) #+(not clim) (formatting-cell (stream) (funcall drawer stream value pretty-name selected-p)) #+(or clim-1.0 clim-2) (clim:with-room-for-graphics (stream) (formatting-cell (stream) (funcall drawer stream value pretty-name selected-p))))) (draw-all (sequence stream) (dolist (item sequence) (let* ((value (funcall value-key item)) (pretty-name (funcall name-key item)) (selected-p (funcall selection-test value selected-value))) (draw-one item value pretty-name selected-p stream))))) (with-output-as-presentation (:stream stream :single-box t) (formatting-item-list (stream :n-columns n-columns :n-rows n-rows ;;#+clim :max-width #-clim :inside-width width #-clim-2 :inter-column-spacing #+clim-2 :x-spacing '(2 :character)) (draw-all sequence stream)))))) #+clim (define-presentation-type alist-subset (&key alist) ;; Yes, I know clim 1.0 has one of these, but it doesn't work in avv mode!. :parser ((stream) (accept `(sequence (alist-member :alist ,alist)) :stream stream :prompt nil)) :printer ((object stream) (do ((sequence object (cdr sequence))) ((null sequence)) (let ((element (find (first sequence) alist :key #'menu-execute-no-side-effects))) (write-string (token-element-string element) stream)) (unless (= (length sequence) 1) (write-string ", " stream)))) :typep ((object) (block testem (dolist (element object) (or (find element alist :key #'menu-execute-no-side-effects) (return-from testem nil))) t)) :describer ((stream) (write-string "any of " stream) ;; -- CLIM doesn't have a general list formatter yet (let (length) (do ((rest-of-elements alist (rest rest-of-elements))) ((not rest-of-elements)) (setq length (length rest-of-elements)) (format stream "~A" (token-element-string (car rest-of-elements))) (cond ((> length 2) (write-string ", " stream)) ((= length 2) (write-string " or " stream)))))) :accept-values-displayer ((stream object query-identifier) ;; OBJECT is the currently chosen subset. ;; OBJECT is the currently chosen subset. (accept-values-choose-from-sequence stream alist object query-identifier :select-action #'(lambda (new list) (cond ((not (listp list)) (list new)) ((member new list) (remove new list)) (t (adjoin new list)))) :selection-test #'member :drawer #'(lambda (stream object name selected-p) (declare (ignore object)) (if selected-p (with-character-face (:bold stream) (format stream "~A" name)) (format stream "~A" name)))))) (defun all-characters (&optional (n (1+ (char-code #\rubout)))) (let ((list nil)) (dotimes (i n) (push (code-char i) list)) list)) (defvar *all-characters* nil) (defun readline-no-echo (stream) #FEATURE-CASE ((:clim-2 (clim:with-output-recording-options (stream :draw nil :record nil) (accept 'string :stream stream :prompt nil :default nil))) (:clim-1.0 (let ((clim::*disable-input-editor-echo* t)) (declare (ignorable clim::*disable-input-editor-echo*)) ;; This variable is defined in a patch file (echo-patch.lisp) ;; that came from Scott MacKay and has not been made a part of DWIM. ;; You must load it separately. (accept 'string :stream stream :prompt nil :default nil))) ((not :clim) (let ((all-characters (or *all-characters* (setq *all-characters* (all-characters)))) (return (elt (format nil "~%") 0))) ;; The trick to echo suppression is to define every character as an ;; activation character. (with-accept-activation-chars (all-characters :override t) (let ((line (make-array 1 :fill-pointer 0 :adjustable t :element-type #+genera 'string-char #-genera 'character))) (loop (let ((char (read-char-for-accept stream))) (if (consp char) (setq char (second char))) (cond ((eql char return) (return (values line char))) ((eql char #\rubout) (if (zerop (fill-pointer line)) (beep) (decf (fill-pointer line)))) ((not (characterp char)) (beep)) (t (vector-push-extend char line))))))))))) ;;; A hack so the user doesnt have to see some ugly commands get echoed. ;;; Also seems like a useful way to read a password. (define-presentation-type invisible-object () :parser ((stream) (values (readline-no-echo stream) 'invisible-object)) :printer ((object stream) (declare (ignore object)) (write-string "*" stream))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/dwim/package.lisp0000600000175000017500000000707110423413302022653 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: User -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package #+ansi-cl :common-lisp-user #-ansi-cl :user) #+mcclim (eval-when (compile load eval) (pushnew :clim-2 *features*)) (eval-when (compile load eval) (#+genera future-common-lisp::defpackage #-genera defpackage dwim #-clim (:shadowing-import-from "CLOS" "SETF" "DOCUMENTATION") ;;Get the ANSI Version of Loop. #+lucid (:shadowing-import-from "LOOP" "LOOP") #+kcl (:shadowing-import-from "SLOOP" "LOOP") #+genera (:shadowing-import-from "FUTURE-COMMON-LISP" "LOOP") (:shadow ignore-errors handler-case restart-case handler-bind invoke-restart find-restart with-simple-restart parse-error *default-server-path*) #+clim (:use clim-lisp) #-clim (:use lisp clos))) (eval-when (compile load eval) #+genera (import '(future-common-lisp:defpackage) 'dwim) ;; GUI stuff we want imported. (import #+clim '(clim:present-to-string clim:presentation-type clim:present) #-clim '(dw:present-to-string dw:presentation-type dw:present scl:send) 'dwim) ;;import the presentation types. (import #+clim '(clim:boolean #+clim-0.9 clim:alist-member clim:expression clim:command) #-clim '(dw:boolean dw:alist-member sys:expression cp:command) 'dwim) ;;declarations we want to work. #+lucid (import '(lcl:dynamic-extent) 'dwim) #+allegro (import '(excl::dynamic-extent) 'dwim) #+genera (import '(sys:downward-funarg sys:downward-function sys:array-register) 'dwim) ) (eval-when (compile load eval) (proclaim '(declaration ;; March 1989, X3J13 votes to subsume downward-funarg & downward-function ;; by dynamic-extent. Get rid of the next two eventually. jpm. dwim::downward-funarg dwim::downward-function #-ansi-cl dwim::dynamic-extent dwim::array-register))) #+openmcl (eval-when (:compile-toplevel :load-toplevel :execute) (proclaim '(declaration values))) #+genera (si:enable-who-calls :new) #+genera (TV:ENABLE-OBSOLETE-CONSOLE-COMPILER-WARNINGS) ;;; Need to load postscript stuff because it defines a package ;;; that dwim references. #+(and clim-2 (not mcclim)) (eval-when (compile load eval) (require :climps)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/dwim/wholine.lisp0000600000175000017500000005560710423413302022735 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: DWIM -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :dwim) (eval-when (compile load eval) (export '(status-pane status-line set-status-line mouse-documentation-pane *include-machine-name-in-status-line-p* *frame-for-status-line* *time-type* initialize-status-line make-status-line refresh-status-line noting-progress note-progress) 'dwim)) ;;; The status line is a small pane associated with a frame which provides ;;; status information, such as: ;;; 1. time of day ;;; 2. user name ;;; 3. process state, usually one of "User Input", "Run", "GC", or "Error!". ;;; 4. progress notes ;;; ;;; To use this code, you must: ;;; a. Provide a method STATUS-PANE that takes your frame as an argument ;;; and that returns some pane of your frame. ;;; Such a pane needs a redisplay function. REFRESH-STATUS-LINE is ;;; defined below for this purpose. ;;; b. Provide a method STATUS-LINE which returns an instance of the ;;; status-line structure. The best way to do this is to provide ;;; a slot on your frame whose :initform is (MAKE-STATUS-LINE stream) and ;;; whose :accessor is STATUS-LINE. (The stream argument to MAKE-STATUS-LINE ;;; should be the status pane.) ;;; c. Initialize the status line (and for clim-0.9, ;;; bind *frame-for-status-line*): ;;; ;;; (defmethod dart-frame-top-level ((frame dart-frame)) ;;; (initialize-status-line) ;;; (let ((*frame-for-status-line* frame)) ;;; (loop ;;; (lcl:with-simple-restart ;;; (dart-top-level "Abort to DART Top Level") ;;; (clim:clim-top-level frame))))) ;;; ;;; ;;; ;;; If you modify this code, be careful. These things should happen with ;;; little or no overhead. In addition, this code must be error free; an ;;; error while advising the GC or debugger could cause lisp to terminate ;;; itself rather hastily. ;;; default width of a field; (defconstant *status-width* 150) ;;; leftmost positions of each field, as a percentage of pane width: (defconstant time-left .05) (defconstant username-left .25) (defconstant process-left .4) (defconstant progress-left .6) (defparameter *include-machine-name-in-status-line-p* nil) (defun whoami () #FEATURE-CASE ((:unix (let ((host-string (and *include-machine-name-in-status-line-p* (let ((raw-host-string (getenv "HOST"))) (cond ((null raw-host-string) nil) ((let ((dot-pos (position #\. raw-host-string))) (if dot-pos (subseq (the string raw-host-string) 0 dot-pos) raw-host-string))))))) (user-string (getenv "USER"))) (if host-string (concatenate 'string user-string "@" host-string) user-string))) (:lispm (let ((me si:*user*)) (and me (scl:send me :lispm-name)))))) ;;; frequently used strings: (defconstant empty-string " ") (defparameter run-string "Please Wait") (defparameter input-string "Ready") (defparameter error-string "Unexpected Condition") (defparameter GC-string "Reclaiming Memory") (defparameter expand-string "Expanding Memory") (defclass status-line () ((stream :initform nil :initarg :stream :accessor status-line-stream) (time :initform empty-string :accessor status-line-time) (ptime :initform nil :accessor status-line-ptime) (username :initform (whoami) :accessor status-line-username) (pusername :initform nil :accessor status-line-pusername) (process :initform run-string :accessor status-line-process) (pprocess :initform nil :accessor status-line-pprocess) (progress :initform empty-string :accessor status-line-progress) (pprogress :initform nil :accessor status-line-pprogress) (thermometer :initform 0 :accessor status-line-thermometer))) (defun make-status-line (stream) (make-instance 'status-line :stream stream)) (defvar *frame-for-status-line* nil "Used for progress notes, but only for clim 0.9.") (defun frame-for-status-line () #FEATURE-CASE ((:clim-0.9 *frame-for-status-line*) ((or :clim-1.0 :clim-2) (and (boundp 'clim:*application-frame*) clim:*application-frame*)) ((not :clim) (and (boundp 'dw:*program-frame*) dw:*program-frame*)))) (defmethod status-pane ((any t)) #+clim nil #-clim (if (typep any 'dw::program-frame) (status-pane (send any :program)))) (defmethod status-line ((any t)) #+clim nil #-clim (if (typep any 'dw::program-frame) (status-line (send any :program)))) (defmethod mouse-documentation-pane ((any t)) #+clim nil #-clim (if (typep any 'dw::program-frame) (mouse-documentation-pane (send any :program)))) (defvar *status-line-sheet-lock* nil) (defmacro sheet-lock ((window) &body body) "Get a lock on this window, or wait for it." (declare (ignore window)) ;; Yes, yes, I know I should have a different lock for each status ;; pane. But after all, there is almost always only one of them, ;; and the time spent updating a status line is very small indeed. `(with-process-lock (*status-line-sheet-lock*) ,@body)) (defmethod draw-status-element ((status-line status-line) (element-name t) string x y stream) (draw-string string x y :stream stream)) (defmethod process-status-element ((status-line status-line) field-name presentation-name string column &optional (record-p t) (status-width *status-width*)) (let* ((stream (status-line-stream status-line)) presentation) (when (and stream status-line) (multiple-value-bind (left top right bottom) (stream-viewport stream) (setq column (truncate (* column (- right left)))) (sheet-lock (stream) (setf (slot-value status-line field-name) string) (setq presentation (slot-value status-line presentation-name)) (setf (slot-value status-line presentation-name) nil) (if (and record-p presentation) (erase-graphics-presentation presentation :stream stream)) (let* ((minx column) (maxx (+ column status-width)) (miny top) (fudge-factor 15) (maxy bottom)) (with-output-recording-disabled (stream) (draw-rectangle minx maxx maxy miny :stream stream :filled t :alu %erase)) (if record-p (setf (slot-value status-line presentation-name) (with-output-as-presentation (:stream stream :object string :type 'string) (draw-status-element status-line field-name string minx (+ miny fudge-factor) stream))) (with-output-recording-disabled (stream) (draw-status-element status-line field-name string minx (+ miny fudge-factor) stream))) (force-output stream) )))))) (defmethod set-status-line ((frame t) (field (eql 'status-line-time)) string &optional (record-p t)) (let* ((status-line (status-line frame))) (when status-line (process-status-element status-line 'time 'ptime string time-left record-p)))) (defmethod set-status-line ((frame t) (field (eql 'status-line-username)) string &optional (record-p t)) (let* ((status-line (status-line frame))) (when status-line (process-status-element status-line 'username 'pusername string username-left record-p)))) (defmethod set-status-line ((frame t) (field (eql 'status-line-process)) string &optional (record-p t)) (let* ((status-line (status-line frame))) (when status-line (process-status-element status-line 'process 'pprocess string process-left record-p)))) (defmethod set-status-line ((frame t) (field (eql 'status-line-progress)) string &optional (record-p t)) (let* ((status-line (status-line frame))) (when status-line (process-status-element status-line 'progress 'pprogress string progress-left record-p 400)))) (defmacro with-status-line ((string field &optional (frame '(frame-for-status-line)) (record-p t)) &body body) (let ((old (gensym)) (f (gensym)) (status-line (gensym))) `(let* ((,f ,frame) (,status-line (and ,f (status-line ,f))) (,old (and ,status-line (funcall ,field ,status-line)))) (unwind-protect (progn (or (not ,f) (set-status-line ,f ,field ,string ,record-p)) ,@body) (or (not ,f) (set-status-line ,f ,field ,old ,record-p)))))) (defmacro with-process-state ((string) &body body) `(with-status-line (,string 'status-line-process) ,@body)) (defun set-all-status-lines (string field &key how-many (record-p t)) "Find all frames and notify them with this string" ;; HOW-MANY can be used to limit the number of frames notified. ;; This is used to limit the amount of consing. (let ((count 0)) (for-each-frame (frame) (when (and (status-pane frame) (or (not how-many) (< count how-many))) (set-status-line frame field string record-p) (incf count))))) (defmethod refresh-status-line (frame pane) "Redisplay a pane that is a status line." (declare (ignore pane)) (let* ((line (status-line frame))) (when line (dolist (field '(status-line-time status-line-username status-line-process status-line-progress)) (set-status-line frame field (funcall field line)))))) (defun advise (name old-name new-function) (unless (fboundp old-name) (setf (symbol-function old-name) (symbol-function name)) (setf (symbol-function name) new-function) name)) (defun unadvise (name old-name) (when (fboundp old-name) (setf (symbol-function name) (symbol-function old-name)) (fmakunbound old-name) name)) (defun string-for-process-whostate (process) (let ((whostate #+allegro (mp:process-whostate process) #+lucid (lcl::process-whostate process) #+genera (scl:send-if-handles process :whostate))) (if (and whostate (search "Input" whostate :test #'equalp)) input-string run-string))) (defun repair-unbelievable-status-lines () ;; Sometimes the status line does not get reset properly, ;; particularly after a GC event. So this ;; function is used by the clock process to repair mistakes. (for-each-frame (frame) (when (status-pane frame) (set-status-line frame 'status-line-process (let* ((p (frame-top-level-process frame))) (if p (string-for-process-whostate p) "no process")))))) (defvar *time-type* :normal "user-customizable feature") (defvar *months* (vector nil "Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")) (defun integer-string (integer) "Stringify an integer (without using the pretty printer)." ;; We seem to be having some wierd lucid bug involving the ;; pretty printer, so don't pretty print. (let* ((posint (abs integer)) (order (if (zerop integer) 1 (+ (truncate (log posint 10)) (if (minusp integer) 2 1)))) (string (make-string order :initial-element #\0)) digit) (when (minusp integer) (setf (elt string 0) #\-)) (loop (if (zerop posint) (return)) (multiple-value-setq (posint digit) (truncate posint 10)) (decf order) (setf (elt string order) (code-char (+ digit 48)))) string)) (defun time-string (&optional (type *time-type*)) ;; This used to be done with ~D format directives, but there ;; seems to be some kind of lucid bug that I can't identify. (multiple-value-bind (sec min hour day month) (get-decoded-time) (declare (ignore sec)) (ecase type ((:normal :12-hour) (let ((morning (< hour 12))) (setq hour (cond ((> hour 12) (- hour 12)) ((= hour 0) 12) (t hour))) (concatenate 'string (aref *months* month) " " (integer-string day) " " (integer-string hour) ":" (if (<= min 9) "0" "") (integer-string min) (if morning "am" "pm")))) ((:military :24-hour) (concatenate 'string (integer-string day) " " (aref *months* month) " " (integer-string hour) (if (<= min 9) ":0" ":") (integer-string min)))))) (defvar *clock-quantum* 20 "Seconds between clock ticks.") (defun clock-top-level (&optional (quantum *clock-quantum*)) "What the clock process actually does." (loop (ignore-errors ;; Ignore them because they arise unavoidably at times when ;; the number of frames is changing and when somebody bypasses ;; my simple window lock. You might miss one clock cycle but ;; the next one will (probably) work fine. (set-all-status-lines (time-string) 'status-line-time) #+lucid (repair-unbelievable-status-lines) (sleep quantum)))) (let ((clock-process nil)) (defun start-clock () (or clock-process (setq clock-process (process-run-function "Clock Process" 'clock-top-level)))) (defun clock () clock-process) (defun stop-clock () (let ((process clock-process)) (when process (kill-process process) (setq clock-process nil)))) ) ;;; ;;; The application must initialize this facility explicitly at run time ;;; by calling the function (INITIALIZE-STATUS-LINE). Do not initialize ;;; at load time, that is too early. ;;; (defun realize-username (&optional (string (whoami))) "Update all status lines with the current username." (set-all-status-lines string 'status-line-username)) (defun initialize-status-line () "Do this once at run time to get everything started." #+lucid (setq lucid::*gc-silence* #'gc-notify-users) (advise-debugger) (advise-read-frame) (advise-menus) (start-clock) (realize-username)) (defun halt-status-line () "Undo the side effects of INITIALIZE-STATUS-LINE." #+lucid (setq lucid::*gc-silence* nil) (unadvise-debugger) (unadvise-read-frame) (stop-clock)) (defmacro noting-progress ((string) &body body) "Place STRING in the right side of the current status pane." `(let ((frame (frame-for-status-line))) (if (and frame (status-line frame)) (with-status-line (,string 'status-line-progress frame) (unwind-protect (progn ,@body) (note-progress 0.0 1.0 frame))) #-genera (progn ,@body) #+genera (tv:noting-progress (,string) ,@body)))) (defun note-progress (numerator &optional (denominator 1.0) (frame (frame-for-status-line))) "Move the status line progress thermometer." (let ((status-line (and frame (status-line frame)))) (if status-line (when (not (eq (status-line-progress status-line) empty-string)) (let ((stream (status-line-stream status-line)) (old-therm (status-line-thermometer status-line)) (new-therm (max 0.0 (min (float (/ numerator denominator)) 1.0)))) (when (and stream (not (eql old-therm new-therm))) (setf (status-line-thermometer status-line) new-therm) (multiple-value-bind (left top right) (stream-viewport stream) (let* ((column (truncate (* progress-left (- right left)))) (x column) (y (+ top 20)) (width (- right left))) (with-output-recording-disabled (stream) (when (< new-therm old-therm) (draw-line x y (+ x (* old-therm (- width x))) y :stream stream :alu %erase)) (when (and (plusp new-therm) (> new-therm old-therm)) (draw-line (+ x (* old-therm (- width x))) y (+ x (* new-therm (- width x))) y :stream stream :alu %draw) ;; KRA 09JUL93: JM had this f-o commented out. However, ;; it lets user see actual progress. If this is too ;; slow we should be smarter about drawing fewer lines. (force-output stream)))))))) #+genera (if (boundp 'tv:*current-progress-note*) (tv:note-progress numerator denominator))))) ;;; ;;; Modify the underlying system. ;;; #+clim-0.9 (defmethod graft-children ((graft clim-shared::graft)) ;; Hack to provide optimized access. (slot-value graft 'silica::children)) #+clim-0.9 (defmethod clim:read-frame-command :around ((frame t) stream) (with-process-state (input-string) (call-next-method))) #+clim-0.9 (defmethod ci::accept-values-top-level :around ((frame t) &rest args) (with-process-state (input-string) (call-next-method))) #+clim-0.9 (defmethod clim:execute-frame-command :around ((frame t) command &optional run) (with-process-state (run-string) (call-next-method))) (defun advise-menus () "Modify menus so that the process state is 'Ready'" #+clim-0.9 (advise 'ci::menu-choose-from-drawer 'old-menu-choose-from-drawer #'(lambda (&rest arguments) (with-process-state (input-string) (apply 'old-menu-choose-from-drawer arguments)))) #+(or clim-1.0 clim-2) (advise 'clim::menu-choose-from-drawer 'old-menu-choose-from-drawer #'(lambda (&rest arguments) (with-process-state (input-string) (apply 'old-menu-choose-from-drawer arguments))))) #+(or clim-1.0 clim-2) (defmethod clim:read-frame-command :around ((frame t) &key stream) (declare (ignore stream)) (with-process-state (input-string) (call-next-method))) #+(or clim-1.0 clim-2) (defmethod clim:execute-frame-command :around ((frame t) command) (declare (ignore command)) (with-process-state (run-string) (call-next-method))) #-clim (scl:defwhopper (dw::program-command-evaluator dw::program) () (let ((e (or (scl:continue-whopper) #'(lambda (program command arguments) (declare (ignore program)) (apply command arguments))))) #'(lambda (program command arguments) (if (status-line program) (with-process-state (run-string) (funcall e program command arguments)) (funcall e program command arguments))))) #-clim (scl:defwhopper (tv:who-line-screen-mouse-documentation-update-internal tv:generic-who-line-screen-mixin) () (let ((old-doc (send (tv:get-who-line-field :mouse-documentation scl:self) :who-line-item-state))) (prog1 (scl:continue-whopper) (let ((doc (send (tv:get-who-line-field :mouse-documentation scl:self) :who-line-item-state))) (when (not (eq old-doc doc)) (for-each-frame (frame) (let ((pane (mouse-documentation-pane frame))) (when pane (window-clear pane) (and doc (write-string doc pane)))))))))) (defun advise-read-frame () #+clim-1.0 (advise 'clim::accept-values-1 'old-accept-values-1 #'(lambda (&rest arguments) (with-process-state (input-string) (apply 'old-accept-values-1 arguments)))) #+clim-2 (advise 'clim-internals::invoke-accepting-values 'old-invoke-accepting-values #'(lambda (&rest arguments) (with-process-state (input-string) (apply 'old-invoke-accepting-values arguments)))) #-clim (advise 'dw::read-program-command 'old-read-program-command #'(lambda (&rest arguments) (let ((program (car arguments))) (if (or (status-line program) (and (typep program 'dw:accept-values) (not (dw::program-frame program)))) (with-process-state (input-string) (apply 'old-read-program-command arguments)) (apply 'old-read-program-command arguments)))))) (defun unadvise-read-frame () #+clim-1.0 (unadvise 'clim::accept-values-1 'old-accept-values-1) #+clim-2 (unadvise 'clim-internals::invoke-accepting-values 'old-invoke-accepting-values) #-clim (unadvise 'dw::read-program-command 'old-read-program-command)) #+lucid (defun gc-notify-users (when) "Because *gc-silence* procedures are called when normal memory allocation is impossible, an executing function that is bound to *gc-silence* should not use more than the amount of storage that is reserved by the value of the keyword :reserved-dynamic. This value defaults to 1024. (WE SHOULD SET IT TO 10000.) In addition, because *gc-silence* procedures are called when scheduling is inhibited, such procedures should not try to acquire process locks... for example, writing to a window uses locks. (WE ACQUIRE THEM ANYWAY BY BINDING LUCID::*POTENTIAL-DEADLOCK-ACTION*)" (let ((LUCID::*POTENTIAL-DEADLOCK-ACTION* :IGNORE)) (case when (:before (format *terminal-io* "~%;;;GC~%") (set-all-status-lines GC-string 'status-line-process :how-many 1 :record-p nil)) (:dynamic-expansion (format *terminal-io* "~%;;;Dynamic Expansion~%") (set-all-status-lines expand-string 'status-line-process :how-many 1 :record-p nil)) (:reserved-expansion (format *terminal-io* "~%;;;Reserved Expansion~%") (set-all-status-lines expand-string 'status-line-process :how-many 1 :record-p nil)) (otherwise ;; We don't really know what state those processes are in, ;; so take a guess. Ideally, we should store those states ;; away and restore them when GC is done. (set-all-status-lines run-string 'status-line-process :how-many 1 :record-p nil))))) #+debug (defun tester () (lucid::with-scheduling-inhibited (time ;; Conses somewhere between 1100 and 1350 bytes. ;; Dont know why the variation exists. (gc-notify-users :before)))) #+somewhere-else (lcl:change-memory-management :reserved-dynamic 10000) (defvar *panic* nil ; dont panic yet "Dynamically bound to prevent recursively entering the debugger.") (defvar *debugger-name* #+lucid 'lcl::invoke-debugger #+allegro 'excl::internal-invoke-debugger #-(or lucid allegro) nil) (defun unadvise-debugger () (unadvise *debugger-name* 'old-invoke-debugger)) (defun advise-debugger () "Modify debugger behavior such that if we fall into the debugger, all our applications find out via the process status string." (unadvise-debugger) (when *debugger-name* (advise *debugger-name* 'old-invoke-debugger #'(lambda (&rest arguments) (if *panic* (apply #'old-invoke-debugger arguments) (let* ((*panic* t) (*standard-input* #+lucid lcl::*initial-io* #-lucid *terminal-io*) (*standard-output* *standard-input*) (*query-io* *standard-input*) (*terminal-io* *standard-input*) (*trace-output* *standard-input*)) (unwind-protect (progn (ignore-errors (set-all-status-lines error-string 'status-line-process)) (apply #'old-invoke-debugger arguments)) (ignore-errors (set-all-status-lines run-string 'status-line-process) )))))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/dwim/feature-case.lisp0000644000175000017500000001226707751457764023675 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: DWIM -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :dwim) ;;;*********************************************************** ;;; #FEATURE-CASE( ... ) :: The FEATURE-CASE MACRO. ;;; A CASE-like reader-macro that dispatches on Features. ;;; ;;;(defun sheet-parent (sheet) ;;; #FEATURE-CASE ;;; (((not :clim) (send sheet :superior)) ;;; (:clim-0.9 (clim:sheet-parent sheet)) ;;; ((or :clim-1.0 :clim-2) (clim:window-parent sheet)))) ;;; ;;; This is nearly equivalent to: ;;; ;;;(defun sheet-parent (sheet) ;;; #-clim (send sheet :superior) ;;; #+clim-0.9 (clim:sheet-parent sheet) ;;; #+(or :clim-1.0 :clim-2) (clim:window-parent sheet)) ;;; ;;; These two examples differ in that feature-case provides an implicit ;;; otherwise clause that will generate a useful error message if no ;;; feature matches the current environment, something like: ;;; ;;; ERROR: Sorry, this portion of the program is only supported for: ;;; (not :clim) ;;; :clim-0.9 ;;; (or :clim-1.0 :clim-2) ;;; ;;; An ARG to FEATURE-CASE (e.g. #1FEATURE-CASE) suppresses the OTHERWISE/T clause. ;;; Of course, you are always free to rewrite the clause yourself. ;;; ;;; NOTE: This uses *read-suppress* just like #+ and #- so that illegal syntax ;;; is not a problem unless the feature matches the current environment. ;;;***************************************************************** (defun feature-case-error (features) (error "Sorry, this portion of this program is currently supported only for the following:~{~%~S ~}" features)) (defun stringify (thing) (typecase thing (string thing) (symbol (string thing)) (t (princ-to-string thing)))) (defun feature-p (feature) (if (atom feature) (not (null (member (stringify feature) *features* :key #'stringify :test #'equalp))) (ecase (car feature) (not (not (feature-p (second feature)))) (and (every #'feature-p (cdr feature))) (or (some #'feature-p (cdr feature)))))) (defun feature-case-macro-function (STREAM CHAR ARG) (cond (*read-suppress* (read stream) (read stream)) (t (let ((object (read stream))) (unless (and (symbolp object) (equalp (string object) "EATURE-CASE")) (error "Unknown #~C Macro: ~A~A" char char object))) (let* ((features nil)) (flet ((make-default-clause () (if (not arg) `(feature-case-error ',features))) (skip-whitespace () (loop (let ((char (peek-char nil stream))) (cond ((member char '(#\Space #\Tab #\Return #\Newline)) (read-char stream)) ((eql char #\;) (read-line stream)) (t (return))))))) (skip-whitespace) (let ((char (read-char stream))) (or (eql char #\() (error "Illegal #FEATURE-CASE syntax (unexpected character ~C)" char))) (loop (skip-whitespace) (let ((char (read-char stream))) (cond ((eql char #\)) (return (make-default-clause))) ((eql char #\()) (t (error "Illegal #FEATURE-CASE syntax (unexpected character ~C)" char)))) (let ((feature (read stream))) (cond ((feature-p feature) (return (let ((forms (read-delimited-list #\) stream))) ;; consume any remaining clauses before returning: (let ((*READ-SUPPRESS* t)) (read-delimited-list #\) STREAM)) (if (cdr forms) `(progn ,@forms) (car forms))))) (t (push feature features) ;; Consume the rest of this clause and throw it away: (let ((*READ-SUPPRESS* t)) (read-delimited-list #\) STREAM))))))))))) ;;; This used to be (eval-when (compile load eval) ...), but ;;; compile-time definition of the read macro is obviously incorrect. (progn (set-dispatch-macro-character #\# #\F 'feature-case-macro-function) (set-dispatch-macro-character #\# #\f 'feature-case-macro-function) ) (defun not-done () (error "This operation not completed for this platform/system")) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/dwim/tv.lisp0000644000175000017500000007230511345155772021745 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: DWIM -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :dwim) (defun typep* (OBJECT SIMPLE-TYPE) ;; NLC21MAY92 ;; We need the following because the Lucid compiler seems to lose sometimes ;; when compiling certain forms. E.g. when doing a compile-file on: ;; (TYPEP STREAM 'CLIM::CLX-WINDOW) ;; We get the following error: ;; >>Error: MAKE-LOAD-FORM is too complicated. ;; (MAKE-LOAD-FORM #) => ;; # NIL (typep OBJECT SIMPLE-TYPE)) ;;; ;;; Operations associated with tv windows (mostly). ;;; (defun window-under-mouse () #FEATURE-CASE ((:mcclim (clim:pointer-sheet (clim:port-pointer (clim:port clim:*application-frame*)))) (:clim-2 (clim-internals::find-appropriate-window *standard-input*)) (:clim-1.0 (clim::find-appropriate-window *standard-input*)) (:clim-0.9 (ci::find-appropriate-window *standard-input*)) ((not :clim) (tv:window-under-mouse)))) (defun window-clear (window) #FEATURE-CASE (((not :clim) (send window :clear-history)) (:clim-0.9 (ci::window-clear window)) ((or :clim-1.0 :clim-2) (clim:window-clear window)))) ;;; This doesn't appear to be used at all with CLIM. #-mcclim (defun change-size (window new-width new-height) #FEATURE-CASE (((not :clim) (send window :set-size new-width new-height)) (:clim-0.9 (ci::change-size window new-width new-height)) ((or :clim-1.0 :clim-2) (clim::window-set-inside-size window new-width new-height)))) (defun pane-frame (pane) #FEATURE-CASE (((not :clim) (scl:send pane :superior)) ((or :clim-0.9 :clim-2) (clim:pane-frame pane)) (:clim-1.0 (let ((p pane) f) (loop (or p (return)) (when (setq f (clim::window-stream-to-frame p)) (return f)) (setq p (clim:window-parent p))))))) (defun redisplay-frame-pane (pane &optional (force-p t)) #FEATURE-CASE ((:clim-0.9 (clim:redisplay-frame-pane pane)) ((or :clim-1.0 :clim-2) ;; force-p is probably wrong for redisplayable panes: (clim:redisplay-frame-pane (pane-frame pane) pane :force-p force-p)) ((not :clim) (let ((frame (scl:send pane :superior))) (scl:send frame :redisplay-pane pane force-p))))) (defun sheet-parent (sheet) #FEATURE-CASE (((not :clim) (send sheet :superior)) (:clim-0.9 (clim:sheet-parent sheet)) ((or :clim-1.0 (and :clim-2 (not :mcclim))) (clim:window-parent sheet)) (:mcclim (clim:sheet-parent sheet)))) (defmethod (setf sheet-parent) (new sheet) #FEATURE-CASE (((not :clim) (send sheet :set-superior new)) (:clim-0.9 (setf (clim:sheet-parent sheet) new)) ((or :clim-1.0 (and :clim-2 (not :mcclim))) (setf (clim:window-parent sheet) new)) (:mcclim (sheet-adopt-child sheet new)))) (defun stream-current-text-style (STREAM) #FEATURE-CASE ((:clim-0.9 (clim:stream-current-text-style (if (typep stream 'ci::encapsulating-stream-mixin) (slot-value stream 'ci::stream) stream))) (:CLIM-1.0 ;; Functions such as stream-line-height and stream-string-width ;; need a fully merged text style. This makes sure all text styles ;; are fully merged. (slot-value stream 'clim::merged-text-style)) (:CLIM-2 (clim:medium-text-style stream)))) (defun stream-merged-text-style (STREAM) #FEATURE-CASE ((:CLIM-1.0 (slot-value stream 'clim::merged-text-style)) (:CLIM-2 (clim:medium-merged-text-style stream)))) (defun parse-text-style (LIST) #FEATURE-CASE ((:CLIM (clim:parse-text-style LIST)) )) (defun stream-line-height (stream &optional TEXT-STYLE) #FEATURE-CASE (((NOT :CLIM) TEXT-STYLE ; wrong - but what's right? (MT) (or (scl:send-if-handles stream :line-height) 12)) (:CLIM-0.9 (if TEXT-STYLE (clim:stream-line-height stream TEXT-STYLE) (clim:stream-line-height stream (stream-current-text-style stream)))) ((or :CLIM-1.0 :clim-2) (if TEXT-STYLE (truncate (clim:stream-line-height stream #+mcclim :text-style TEXT-STYLE)) (truncate (clim:stream-line-height stream)))))) (defun stream-character-width (stream &optional (char #\m)) ;; "m" is the usual character (the term "ems" is often used in typesetting ;; to indicate units of width). #FEATURE-CASE (((not :clim) (or (scl:send-if-handles stream :character-width char) 8)) (:clim-0.9 (clim:stream-character-width STREAM char)) (:clim-1.0 (if (clim:extended-output-stream-p stream) (clim:stream-character-width STREAM char) 8)) (:clim-2 (if (clim:extended-output-stream-p stream) (clim:stream-character-width STREAM char) 8)))) (defun stream-string-width (STREAM string &key (start 0) end text-style) #FEATURE-CASE ((:CLIM-1.0 (when (eq text-style clim:*null-text-style*) (setq text-style (stream-current-text-style stream))) (clim:stream-string-width STREAM string :start START :end END :text-style TEXT-STYLE)) (:CLIM (clim:stream-string-width STREAM string :start START :end END :text-style TEXT-STYLE)) )) (defmethod stream-cursor-position* (stream) #FEATURE-CASE (((not :clim) (send stream :read-cursorpos)) (:clim-0.9 (clim:stream-cursor-position* stream)) (:clim-1.0 (cond ((clim:extended-output-stream-p stream) (clim:stream-cursor-position* stream)) ((typep* stream 'clim::encapsulating-stream-mixin) (stream-cursor-position* (slot-value stream 'clim::stream))) (t (values 0 0)))) (:clim-2 (if (clim:extended-output-stream-p stream) (multiple-value-bind (x y) (clim:stream-cursor-position stream) ;; Its nice to assume that cursor positions are fixnums, ;; even though postscript streams meaningfully use floats. (values (truncate x) (truncate y))) (values 0 0))))) (defmethod stream-set-cursor-position* (stream x y) #FEATURE-CASE (((not :clim) (send stream :set-cursorpos x y)) ((or :clim-0.9 :clim-1.0) (clim:stream-set-cursor-position* stream x y)) ((and :clim-2 (not :mcclim)) (clim:stream-set-cursor-position stream x y)) (:mcclim (setf (clim:stream-cursor-position stream) (values x y))))) (defmethod stream-increment-cursor-position* (stream x y) #FEATURE-CASE (((not :clim) (send stream :increment-cursorpos x y)) (:clim-0.9 (clim:stream-increment-cursor-position* stream x y)) (:clim-1.0 (if (typep* stream 'clim::output-protocol-mixin) (clim:stream-increment-cursor-position* stream x y))) (:clim-2 (clim:stream-increment-cursor-position stream x y)))) (defmethod stream-viewport (stream) ;;(declare (values left top right bottom)) #FEATURE-CASE (((not :clim) (send stream :visible-cursorpos-limits)) (:clim-0.9 (clim:bounding-rectangle* (clim:sheet-region (clim:pane-viewport stream)))) (:clim-1.0 (if (typep stream 'clim::postscript-stream) (values 0 0 700 700) ; anything will do... (multiple-value-bind (left top right bottom) (clim:rectangle-edges* (clim:window-viewport stream)) (multiple-value-bind (xoff yoff) (if (typep* stream 'clim::avv-stream) (values 0 0) (clim:window-margins stream)) (values left top (- right xoff) (- bottom yoff)))))) (:clim-2 (cond ((not (clim:extended-output-stream-p stream))) ((and (type-specifier-p #-mcclim 'postscript-clim::postscript-stream #+mcclim 'clim-postscript::postscript-stream) (typep stream #-mcclim 'postscript-clim::postscript-stream #+mcclim 'clim-postscript::postscript-stream)) ;; width = inches x 72 ;; height = inches x 72 (values 0 0 #.(* 72 7) #.(* 72 10))) (t (let ((v (and #-mcclim (not (typep stream 'clim-silica:pixmap-stream)) #+mcclim (not (typep (clim:medium-sheet (clim:sheet-medium stream)) 'climi::pixmap)) (clim:window-viewport stream)))) (if v (clim:rectangle-edges* v) (values 0 0 (clim:bounding-rectangle-width stream) (clim:bounding-rectangle-height stream))))))))) (defmethod stream-viewport-size (stream) ;;(declare (values width height)) (multiple-value-bind (left top right bottom) (stream-viewport stream) (values (- right left) (- bottom top)))) (defmacro sheet-inside-size (stream) #FEATURE-CASE ((:CLIM `(stream-viewport-size ,stream)) ((NOT :CLIM) `(values (send ,stream :inside-size)))) ) (defun stream-height (stream) "Height of the viewport." (multiple-value-bind (ignore height) (stream-viewport-size stream) (declare (ignore ignore)) height)) (defmacro sheet-inside-width (stream) #+clim `(values (stream-viewport-size ,stream)) #-clim `(values (send ,stream :inside-size))) (defmacro sheet-inside-height (stream) #+clim `(stream-height ,stream) #-clim `(multiple-value-bind (w h) (send ,stream :inside-size) (declare (ignore w)) h)) (defmacro sheet-left-margin-size (stream) stream #+clim 0 ; KRA: 4/11/90: CLIM Doesn't use margins. #-clim `(tv:sheet-left-margin-size ,stream)) (defmacro sheet-top-margin-size (stream) stream #+clim 0 #-clim `(tv:sheet-top-margin-size ,stream)) (defun beep () #+genera (scl:beep) #-genera (clim:beep)) ;;; ;;; Mouse stuff ;;; (defun interactive-stream-p (stream) #-clim (send stream :interactive) #+clim (clim:extended-input-stream-p stream)) (defmethod stream-set-pointer-position* (stream x y) "Set position of mouse, in stream coordinates." #FEATURE-CASE (((not :clim) (send stream :set-mouse-position x y)) ((or :clim-0.9 :clim-1.0) (clim:stream-set-pointer-position* stream x y)) ((and :clim-2 (not :mcclim)) (clim:stream-set-pointer-position stream x y)) (:mcclim (setf (clim:stream-pointer-position stream) (values x y))))) (defmethod stream-pointer-position* (stream) "Get position of mouse, in stream coordinates." #FEATURE-CASE (((not :clim) (send stream :mouse-position)) ((or :clim-0.9 :clim-1.0) (clim:stream-pointer-position* stream)) (:clim-2 (multiple-value-bind (x y) (clim:stream-pointer-position stream) (values (truncate x) (truncate y)))))) (defun pointer-input-rectangle* (&key (stream *standard-input*) left top right bottom) ;;(declare (values left top right bottom)) #+clim (declare (ignore stream left top right bottom)) #FEATURE-CASE (((not :clim) (multiple-value-bind (xoff yoff) (send stream :visible-cursorpos-limits) (decf left xoff) (decf right xoff) (decf top yoff) (decf bottom yoff) (let ((box (dw::make-box left top right bottom))) (setq box (tv:mouse-reshape-rectangle :initial-box box)) (multiple-value-bind (a b c d) (dw::box-edges box) (values (+ a xoff) (+ b yoff) (+ c xoff) (+ d yoff)))))))) ;;; ;;; Frame stuff ;;; (defvar *default-server-path* #FEATURE-CASE (((and :clim-1.0 :genera) '(:sheet :screen (tv:console-default-superior))) ((and :clim-1.0 :mcl) '(:mcl)) ((and :clim-1.0 :xlib (not :genera)) '(:clx)) (:clim-0.9 '(:clx)) (:clim-2 '(:motif)) ((not :clim) nil))) (defvar *sheet-roots* nil) (defvar *deactivated-frames* nil) (defvar *activated-frames* nil) (defmethod frame-top-level-process ((frame t)) "Access the process associated with this frame." #FEATURE-CASE (((or :clim-1.0 (and :clim-2 (not :mcclim))) (second (car (member frame *activated-frames* :key #'car)))) (:clim-0.9 (slot-value frame 'ws::top-level-process)) ((not :clim) (scl:send frame :process)) (:mcclim (climi::frame-process frame)))) (defun frame-manager (frame) #FEATURE-CASE ((:clim-1.0 (clim:window-parent (clim:frame-top-level-window frame))) (:clim-0.9 (clim:frame-manager frame)) (:clim-2 (clim:frame-manager frame)) ((not :clim) (scl:send frame :superior)))) (defun find-frame-manager (&key (if-exists :reuse)) (declare (ignorable if-exists)) #FEATURE-CASE ((:clim-2 (clim:find-frame-manager)) (:clim-1.0 (or (and *sheet-roots* (ecase if-exists (:reuse (car (last *sheet-roots*))) (:create nil))) (let ((r (apply #'clim:open-root-window (mapcar #'eval *default-server-path*)))) (push r *sheet-roots*) r))) (:clim-0.9 (ws::find-frame-manager)) ((not :clim) (let ((w *terminal-io*)) (or (and w (scl:send w :screen)) (tv:console-default-superior)))))) (defun get-reusable-frame (manager type) (declare (ignorable manager)) #FEATURE-CASE (((not :clim) (let ((choices *deactivated-frames*)) (dolist (item choices) (when (and (eq (frame-manager item) manager) (typep (scl:send item :program) type)) (setq *deactivated-frames* (delete item *deactivated-frames*)) (return item))))) (:clim-2 (let ((choices (clim:frame-manager-frames manager))) (dolist (item choices) (when (and (typep item type) (eq (clim:frame-state item) :disabled)) (return item))))) (:clim-1.0 #-MCL (let ((choices *deactivated-frames*)) (dolist (item choices) (when (typep item type) (setq *deactivated-frames* (delete item *deactivated-frames*)) (return item)))) #+MCL ; reuse doesn't work yet nil) (:clim-0.9 (ws::get-reusable-frame manager type)))) (defun deactivate-frame (frame) (setq *activated-frames* (remove frame *activated-frames* :key #'car)) (push frame *deactivated-frames*)) (defmethod reset-frame (frame &key title) "Prepare a frame for reuse." #FEATURE-CASE (((not :clim) frame) (:clim-2 (setf (clim:frame-pretty-name frame) title) (clim:reset-frame frame)) (:clim-1.0 (progn #-MCL (setf (clim:frame-pretty-name frame) title) ;; might have an Abort left in it: (clim:stream-clear-input (clim:frame-top-level-window frame)) frame)) (:clim-0.9 ;; BUG: title is wrong on reused frames(?). (clim:reset-frame frame :title title)))) ;;; You pay a price for this, so set it to nil if resources are scarce. (defvar *enable-backing-store* :when-mapped "One of :always, :when-mapped, :not-useful, or nil") (defmethod start-frame (frame &key (wait-until-done t) master (backing-store *enable-backing-store*)) #FEATURE-CASE ((:clim-0.9 (progn ;; If these are X windows, enable backing-store. #+xlib (let* ((pane (clim:frame-pane frame)) (port (clim:port pane))) (when (typep* port 'on-x::x-port) (setf (xlib:window-backing-store (w::sheet-mirror! pane)) backing-store))) (cond (master ;; Change the event queue and reinitialize. ;; How should this be undone if this frame is recycled? (setf (slot-value frame 'ws::queue) (ws::frame-queue master)) (ci::initialize-stream-queues frame) (clim:enable-frame frame) (clim:panes-need-redisplay frame) (clim:redisplay-frame-panes frame)) (t (clim:start-frame frame wait-until-done))))) (:clim-1.0 (labels ((set-backing-store (window value) #+xlib (setf (xlib:window-backing-store (slot-value window 'clim::window)) value) (dolist (child (slot-value window 'clim::children)) (set-backing-store child value)))) (cond (master (let ((b (clim:stream-input-buffer (clim:frame-top-level-window master))) (top-level-window (clim:frame-top-level-window frame))) (labels ((set-input-buffer (window buffer) (setf (clim:stream-input-buffer window) buffer) (dolist (w (clim:window-children window)) (set-input-buffer w buffer)))) (set-input-buffer top-level-window b) (set-backing-store (clim:frame-top-level-window frame) backing-store) (clim:window-expose top-level-window) (clim:redisplay-frame-panes frame :force-p t) ;; return the window just created (values top-level-window)))) ((not wait-until-done) (process-run-function "Frame Top Level" 'start-frame frame :wait-until-done t :master nil :backing-store backing-store) frame) (T (push (list frame (current-process)) *activated-frames*) (setq *deactivated-frames* (delete frame *deactivated-frames*)) #+xlib (let ((xwin (slot-value (clim:frame-top-level-window frame) 'clim::window))) (xlib:set-wm-class xwin "clim" "clim")) (set-backing-store (clim:frame-top-level-window frame) backing-store) (unwind-protect (let ((clim::*frame-layout-changing-p* t)) ; forces redisplay (clim:run-frame-top-level frame)) (deactivate-frame frame)))))) (:clim-2 (cond (master (let ((b (clim:stream-input-buffer (clim:frame-top-level-sheet master))) (top-level-window (clim:frame-top-level-sheet frame))) (labels ((set-input-buffer (window buffer) (setf (clim:stream-input-buffer window) buffer) (dolist (w (#-mcclim clim:window-children #+mcclim clim:sheet-children window)) (set-input-buffer w buffer)))) (set-input-buffer top-level-window b) #-mcclim (clim:window-expose top-level-window) #+mcclim (clim:enable-frame frame) (clim:redisplay-frame-panes frame :force-p t) ;; return the window just created (values top-level-window)))) ((not wait-until-done) (process-run-function "Frame Top Level" 'start-frame frame :wait-until-done t :master nil :backing-store backing-store) frame) (T (push (list frame (current-process)) *activated-frames*) (unwind-protect (progn (clim:run-frame-top-level frame)) (deactivate-frame frame))))) ((not :clim) (cond (master (error "MASTER operation not supported.")) ((not wait-until-done) (scl:send frame :mouse-select)) (T (setf (scl:symbol-value-in-instance frame 'tv:process) nil) (let* ((superior (scl:send frame :superior)) (shadow (if (typep* superior 'tv:basic-screen) (first (scl:send superior :exposed-inferiors)))) (dw:*program-frame* frame) (dw:*program* (scl:send frame :program))) (tv:with-window-shadowed-for-selection (shadow frame :reselect t) (tv:window-call (frame :deactivate) (unwind-protect (dw::run-program-top-level dw:*program*) (deactivate-frame frame)))))))))) (defun make-application-frame (type &key parent title (left 10) (top 10) (width 500) (height 500)) #FEATURE-CASE (((not :clim) (tv:make-window 'dw::program-frame ; 'dw::program-frame-resource :superior parent :program type :margin-components '((dw:margin-drop-shadow-borders) (dw:margin-borders)) :program-state-variables `((dw::pretty-name ,title)))) (:clim-0.9 (let ((frame (clim:make-frame type :title title))) (ws::adopt-frame parent frame) (setf (ws::frame-prop frame :reusable) t) frame)) (:clim-1.0 ;; Also, note you can (currently) get into trouble in Lucid if you use a ;; single root window for multiple frames. X events for the root can be ;; snagged by any frame's process without regard which frame should "own" ;; the event. The workaround is to open a new root window for each frame. ;;--David Gadbois (clim:make-application-frame type ;; 9-15-93 When `launch-frame' calls us with a parent we need to ;; use it, otherwise mouse-sensitivity does not work. (Westy) :parent (or parent (find-frame-manager :if-exists :create)) :pretty-name title :left left :top top :right (+ left width) :bottom (+ top height))) (:clim-2 ;; what parent does this get? (let ((frame (clim:make-application-frame type :pretty-name title :left left :top top :width width :height height ;; This is a kludge to solve spr8924 in clim 2.0.beta2: #+allegro :calling-frame #+allegro clim:*application-frame* #+mcclim :frame-manager #+mcclim parent))) frame)))) (defmethod size-frame (frame width height) #FEATURE-CASE (((not :clim) (scl:send frame :set-edges 0 0 width height)) (:clim-0.9 (ws::size-frame frame width height)) (:clim-2 (clim:layout-frame frame width height)) (:clim-1.0 (let ((window (clim:frame-top-level-window frame))) (multiple-value-bind (xmin ymin xmax ymax) (clim:bounding-rectangle* (sheet-parent window)) (declare (ignore xmin ymin)) (multiple-value-bind (left top) (clim:bounding-rectangle* window) (setf (clim:bounding-rectangle-max-x window) (min (+ left width) xmax)) (setf (clim:bounding-rectangle-max-y window) (min (+ top height) ymax)) (clim::layout-frame-panes frame window))))))) (defmethod move-frame (frame left bottom) #FEATURE-CASE (((not :clim) (dw::position-window-near-carefully frame `(:point ,left ,bottom))) (:clim-0.9 (ws::move-frame frame left bottom)) (:clim-1.0 (clim::position-window-near-carefully (clim:frame-top-level-window frame) left bottom)) ((and :clim-2 (not :mcclim)) (clim:position-sheet-carefully (clim:frame-top-level-sheet frame) left bottom)) ;; uhh... (:mcclim nil))) (defmethod get-frame-pane (frame pane-name) #FEATURE-CASE (((not :clim) (scl:send frame :get-pane pane-name)) (:clim-1.0 (clim:get-frame-pane frame pane-name)) (:clim-2 (clim:get-frame-pane frame pane-name)))) (defmethod frame-current-layout (frame) #FEATURE-CASE (((or :clim-1.0 :clim-2) (clim:frame-current-layout frame)) ((not :clim) (scl:send frame :configuration)))) (defmethod set-frame-layout (frame new-layout) #FEATURE-CASE ((:clim-1.0 ;; In clim 1.0 at least, this does a THROW out of the command loop ;; to do certain window management functions, such as rebinding I/O ;; streams that correspond to the new layout. So do this last in ;; a sequence of operations. (unless (eq new-layout (frame-current-layout frame)) (clim:set-frame-layout frame new-layout))) (:clim-2 (unless (eq new-layout (frame-current-layout frame)) (setf (clim:frame-current-layout frame) new-layout))) ((not :clim) (unless (eq new-layout (frame-current-layout frame)) (if (or (not (boundp 'dw::*program-frame*)) (not (eql frame dw::*program-frame*))) (scl:send frame :set-configuration new-layout) (scl:send frame :synchronous-set-configuration new-layout)))))) (defmethod window-set-viewport-position* (stream left top) #FEATURE-CASE ((:clim-0.9 (clim:set-scroll-position stream left top)) (:clim-1.0 (clim:window-set-viewport-position* stream left top) (clim::redisplay-decorations stream)) ((and :clim-2 (not :mcclim)) (clim:window-set-viewport-position stream left top)) (:mcclim (setf (clim:window-viewport-position stream) (values left top))) ((not :clim) (scl:send-if-handles stream :set-viewport-position left top)))) (defmethod window-history-limits (stream) ;;(declare (values left top right bottom)) #+(or (not clim) clim-0.9) (declare (ignore stream)) #FEATURE-CASE ((:clim-1.0 (let ((history (clim:output-recording-stream-output-record stream))) (clim:bounding-rectangle* history))) (:clim-2 (let ((history (clim:stream-output-history stream))) (clim:bounding-rectangle* history))))) (defmethod select-frame (frame) #FEATURE-CASE (((not :clim) (scl:send frame :mouse-select)) (:clim-1.0 (let ((window (clim:frame-top-level-window frame))) #+xlib (xlib:map-window (slot-value window 'clim::window)) ; deiconify (clim:window-stack-on-top window) (force-output window) frame)) (:clim-2 (#+mcclim note-frame-deiconified #-mcclim clim-internals::note-frame-deiconified (clim:frame-manager frame) frame) (clim:raise-sheet (clim:frame-top-level-sheet frame)) frame))) (defun suggest-frame-size (frame-manager width height) #FEATURE-CASE (((not :clim) (multiple-value-bind (w h) (scl:send frame-manager :size) (setq width (min width w) height (min height h)))) (:clim-0.9 (let ((graft (clim-shared:graft frame-manager))) (when graft (setq width (min width (clim-shared::graft-width-pixel graft)) height (min height (clim-shared::graft-height-pixel graft)))))) (:clim-1.0 (multiple-value-bind (w h) (clim:window-inside-size frame-manager) (setq width (min width w) height (min height h)))) (:clim-2 (let ((graft #-mcclim (clim:graft frame-manager) #+mcclim (clim:graft (port frame-manager)))) (when graft #-mcclim (setq width (min width (silica::graft-pixel-width graft)) height (min height (silica::graft-pixel-height graft))) #+mcclim (setq width (min width (clim:graft-width graft :units :device)) height (min height (clim:graft-height graft :units :device)))))) ) (values width height)) (defun launch-frame (type &key (backing-store :when-mapped) ; specific to X windows create ; NIL => try first to reuse an old instance master (title "Window Frame") (left 0) (bottom 0) (width 600) (height 400) (wait-until-done nil) ; T => spawn its own process (initializer nil) ; function of 1 arg &allow-other-keys) "The preferred way to make and expose an application frame." ;; MASTER is either NIL or another frame. ;; If it is a frame, the second frame acts as an extension of the first. (let* ((manager (if master (frame-manager master) (find-frame-manager))) (frame (if (not create) (get-reusable-frame manager type)))) (when frame (reset-frame frame :title title)) (if frame (size-frame frame width height) (setq frame (make-application-frame type ;;:left (max 0 left) :top (max 0 (- height bottom)) :parent manager :width width :height height :title title))) (move-frame frame (max 0 left) (max 0 bottom)) (multiple-value-bind (w h) (suggest-frame-size manager width height) (when (or (not (eql w width)) (not (eql h height))) (size-frame frame w h))) (when initializer (let* ((application #+clim frame #-clim (scl:send frame :program)) #-clim (dw:*program* application) #-clim (dw:*program-frame* frame) #+(and clim (not clim-0.9)) (clim:*application-frame* frame)) (funcall initializer application))) (start-frame frame :wait-until-done wait-until-done :master master :backing-store backing-store))) (defmethod frame-exit (FRAME) #FEATURE-CASE ((:CLIM-0.9 (clim::stop-frame FRAME)) (:CLIM-2 (clim:frame-exit FRAME)) (:CLIM-1.0 ;; buggo makes the frame stay up! (let ((top (clim::frame-top-level-window frame))) (when top (setf (clim::window-visibility top) nil) (clim::force-output top))) (clim::frame-exit FRAME)) )) (defmacro for-each-frame ((symbol) &body body) "Iteratively bind SYMBOL to all enabled frames." #FEATURE-CASE (((not :clim) `(dolist (screen tv:all-the-screens) (dolist (,symbol (scl:send screen :inferiors)) (when (and (typep ,symbol 'dw:program-frame) (scl:send ,symbol :inferiors)) ,@body)))) (:clim-0.9 `(when ws::*ports* ;; If there are no ports open, then there are no enabled frames. (dolist (child (graft-children (ws::frame-manager-sheet (ws::find-frame-manager)))) (when (ci::sheet-enabled-p child) (let ((,symbol (ws::sheet-frame child))) (when (eq (ci::frame-state ,symbol) :enabled) ,@body)))))) (:clim-1.0 `(dolist (root *sheet-roots*) (dolist (child (slot-value root 'clim::children)) (let ((,symbol (clim::window-stream-to-frame child))) (when (and ,symbol (not (member ,symbol *deactivated-frames*))) ; kludge ,@body))))) (:clim-2 `(clim:map-over-ports #'(lambda (port) (unless (eq (clim:port-type port) :postscript) (dolist (,symbol (clim:frame-manager-frames (clim:find-frame-manager :port port))) (when (member (clim:frame-state ,symbol) '(:shrunk :enabled)) ,@body)))))))) (defun find-program-window (name &key (create-p nil) (wait-until-done nil) (width 500) (height 500)) #FEATURE-CASE (((not :clim) (let ((screen (find-frame-manager))) (dw:find-program-window name :create-p create-p :console (scl:send screen :console)))) (:clim (progn (for-each-frame (f) (when (typep f name) (return-from find-program-window f))) (when create-p (launch-frame name :title (string name) :wait-until-done wait-until-done :width width :height height)))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/dwim/export.lisp0000644000175000017500000002106207751664403022631 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: DWIM -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :dwim) ;;;These symbols inherited from other packages. (eval-when (compile load eval) (export '(defpackage present present-to-string presentation-type menu-choose) 'dwim)) ;;;from present.lisp (eval-when (compile load eval) (export '(continuation-output-size with-room-for-output erase-graphics-presentation presentation-under-pointer presentation-p presentation-superior presentation-object presentation-subtypep presentation-type-p present-to-string describe-presentation-type bounding-rectangle* redisplay redisplayable-format accept accepting-values accept-values accept-variable-values menu-choose formatting-table formatting-row formatting-column formatting-column-headings formatting-cell formatting-item-list format-item-list read-char-for-accept peek-char-for-accept unread-char-for-accept compare-char-for-accept read-token input-position insertion-pointer parse-error input-not-of-required-type catching-parser-failures validate-object with-accept-activation-chars accept-activation-p with-accept-blip-chars accept-blip-p with-activation-characters with-blip-characters completing-from-suggestions suggest complete-from-sequence with-presentation-input-context with-input-context sheet accept-values-choose-from-sequence alist-subset invisible-object) 'dwim)) ;;;from draw.lisp (eval-when (compile load eval) (export '(make-color-rgb color-exists-p color-stream-p with-clipping-from-output with-underlining surrounding-output-with-border %flip %draw %erase %alu draw-point draw-line draw-string draw-string-image draw-polygon draw-triangle draw-circle draw-rectangle draw-ellipse) 'dwim)) ;;;from tv.lisp (eval-when (compile load eval) (export '(window-under-mouse window-clear change-size pane-frame redisplay-frame-pane sheet-parent stream-current-text-style stream-merged-text-style stream-line-height stream-character-width interactive-stream-p stream-cursor-position* stream-set-cursor-position* stream-increment-cursor-position* stream-viewport stream-viewport-size sheet-inside-size sheet-inside-width sheet-inside-height sheet-left-margin-size sheet-top-margin-size beep stream-pointer-position* stream-set-pointer-position* pointer-input-rectangle* noting-progress note-progress frame-manager find-frame-manager get-reusable-frame start-frame reset-frame make-application-frame move-frame size-frame get-frame-pane frame-current-layout set-frame-layout window-set-viewport-position* window-history-limits select-frame find-program-window launch-frame) 'dwim)) ;;;from macros.lisp (eval-when (compile load eval) (export '(printing-random-object with-stack-list with-stack-array store-conditional stack-let without-interrupts condition-case handler-case handler-bind ignore-errors with-simple-restart restart-case invoke-restart find-restart make-command-table define-command-table find-command-table define-command install-command define-presentation-to-command-translator define-presentation-translator define-presentation-action define-presentation-type with-output-as-presentation with-output-truncation with-output-recording-enabled with-output-recording-disabled with-redisplayable-output with-character-face with-text-face with-character-style with-character-size with-character-family with-text-style with-frame with-program) 'dwim)) ;;;from extensions.lisp (eval-when (compile load eval) (export '(ignore with-rem-keywords rem-keywords *load-pathname* *source-pathname* working-directory getenv run-shell-command process-wait process-run-function with-process-lock dotimes-unrolled instancep type-specifier-p file-type-for-binaries file-type-for-sources dump-objects-to-file ) 'dwim)) ;;;export the presentation types and declarations. (eval-when (compile load eval) (export '(boolean alist-member command expression) 'dwim) (export '(downward-funarg downward-function array-register dynamic-extent) 'dwim)) ;;;************************************************************ ;;; ;;; DWIM-LISP is what user programs should use as the lisp package. ;;; It's purpose is to handle all the hairy importing and shadowing ;;; constraints so that users don't have to go through this every time ;;; they define a package that uses dwim stuff. DWIM-LISP exports ;;; Common Lisp, CLOS, and the relevant DWIM symbols. As ANSI ;;; Common Lisp comes along, DWIM should go along with it. ;;; User package definitions should look very simple, e.g. ;;; (in-package 'my-package :use '(dwim-lisp)) ;;; (defun export-inherited-symbols (package) (unless (packagep package) (setq package (find-package package))) (do-symbols (symbol package) (multiple-value-bind (sym presence) (find-symbol (symbol-name symbol) package) (declare (ignore presence)) (unless (eq (symbol-package sym) package) (export sym package)))) ;; These next lines are here so that the symbol NIL will get exported. (import '(nil) package) (export '(nil) package)) (eval-when (compile load eval) (defpackage dwim-lisp #+MCL (:shadowing-import-from ccl type-specifier-p) #+genera (:shadowing-import-from clos setf documentation) #+genera (:shadowing-import-from future-common-lisp dynamic-extent) ;; Shadow the things defined in dwim that offer potential name conflicts ;; with common lisp. (:shadowing-import-from "DWIM" :without-interrupts :interactive-stream-p :ignore :loop :ignore-errors :handler-case :with-simple-restart :parse-error :restart-case :find-restart :invoke-restart :handler-bind :process-wait :process-run-function) #+clim-0.9 (:shadowing-import-from "CLIM-LISP" "DESCRIBE-OBJECT" "MAKE-LOAD-FORM-SAVING-SLOTS") (:use #-lucid common-lisp #+(and lucid clim-0.9) clim-lisp #+(and lucid (not clim-0.9)) lisp #+(or lucid allegro genera) clos #+mcl ccl dwim))) (eval-when (load eval) #+clim (do-external-symbols (symbol (find-package :clim)) ;; import everything from clim that offers no name conflicts. (unless (find-symbol (symbol-name symbol) :dwim-lisp) (import symbol :dwim-lisp))) #+genera (import '(scl:send scl::self) 'dwim-lisp) (dwim::export-inherited-symbols (find-package "DWIM-LISP")) #+Genera ;; Bless this package as a "reasonable facsimile of LISP" (pushnew (find-package "DWIM-LISP") si:*reasonable-packages*) (pushnew :dwim *features*)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/dwim/draw.lisp0000644000175000017500000002644407751423107022250 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: DWIM -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :dwim) ;;; ;;; Drawing Operations ;;; ;;; Common alu choices. These ought to be constants, but in CLIM they point to ;;; objects, and that seems to cause some compilers to barf. (defvar %flip #+clim-0.9 :flipping-ink #+clim-1.0 clim:+flipping-ink+ #+clim-2 clim:+flipping-ink+ #-clim :flip) (defvar %draw #+clim-0.9 :foreground #+clim-1.0 clim:+foreground+ #+clim-2 clim:+foreground-ink+ #-clim :draw) (defvar %erase #+clim-0.9 :background #+clim-1.0 clim:+background+ #+clim-2 clim:+background-ink+ #-clim :erase) (defvar %alu %draw) (defun make-color-rgb (red green blue) #-clim (declare (special color:color-screen)) #FEATURE-CASE (((not :clim) (when (color:color-exists-p) (scl:send color:color-screen :compute-rgb-alu tv:alu-seta red green blue))) (:clim-2 (clim:make-rgb-color red green blue)) ((or :clim-1.0 :clim-0.9) (clim:make-color-rgb red green blue)))) (defun color-exists-p () #-clim (color:color-exists-p) #+clim t) (defun color-stream-p (stream) "Is STREAM capable of rendering color?" #FEATURE-CASE (((not :clim) (and (color:color-exists-p) ;; error, for example if stream = cold-load-stream (ignore-errors (color:color-stream-p stream)))) (:clim-2 (and (clim:extended-output-stream-p stream) (or (and (type-specifier-p #-mcclim 'postscript-clim::postscript-stream #+mcclim 'clim-postscript::postscript-stream) (typep stream #-mcclim 'postscript-clim::postscript-stream #+mcclim 'clim-postscript::postscript-stream)) #+ignore ; disallowed (clim:palette-color-p (clim:medium-palette (clim:sheet-medium stream))) #+ignore ; currently broken & undocumented (clim:color-stream-p stream) #-mcclim ; "official" answer. (clim:palette-color-p (let ((frame (clim:pane-frame stream))) (if frame (clim:frame-palette frame) (clim:port-default-palette (clim:port (clim:sheet-medium stream)))))) #+mcclim t))) (:clim-0.9 (if (typep stream 'ci::encapsulating-stream-mixin) (color-stream-p (slot-value stream 'ci::stream)) (let ((port (clim:port stream))) (cond #+Genera ((typep port 'on-genera::genera-port) (dolist (inf (tv:sheet-inferiors (on-genera::genera-screen port))) (ignore-errors (return (color:color-stream-p inf))))) #+XLIB ((typep port 'on-x::x-port) (> (slot-value port 'on-x::depth) 1)) (t nil))))) ((and :clim-1.0 :clx) (if (typep stream 'clim::clx-window) (slot-value stream 'clim::color-p) t)) ((and :clim-1.0 (not mcl)) (if (typep stream 'clim::sheet-window-stream) (slot-value stream 'clim::color-p) t)) ((and :clim-1.0 mcl) (ccl::screen-color-p ccl::*screen-gdevice*)))) (defmacro with-underlining ((stream &key underline-whitespace) &body body) #FEATURE-CASE (((not :clim) `(dw:with-underlining (,stream :underline-whitespace ,underline-whitespace) ,@body)) (:clim `(multiple-value-bind (x y) (stream-cursor-position* ,stream) ;; This doesn't work right if output involves multiple lines. ,underline-whitespace (unwind-protect (progn ,@body) (multiple-value-bind (x2 y2) (stream-cursor-position* ,stream) (draw-line x y x2 y :stream ,stream))))))) (defmacro surrounding-output-with-border ((&optional (stream '*standard-output*) &key (alu %draw) (margin 1) (thickness 1) (vsp #-clim 4 #+clim 2) ) &body body) ;; This one is better done in terms of other DWIM operations. (let ((continuation (gensym)) (x (gensym)) (y (gensym)) (x1 (gensym)) (y1 (gensym)) (width (gensym)) (height (gensym))) `(let ((,continuation #'(lambda (,stream) ,@body))) (multiple-value-bind (,x ,y) (stream-cursor-position* ,stream) (stream-set-cursor-position* ,stream (+ ,x ,margin) (+ ,y ,margin)) (multiple-value-bind (,width ,height) (continuation-output-size ,continuation ,stream) (funcall ,continuation ,stream) (let ((,x1 (+ ,x ,width ,margin ,margin)) (,y1 (+ ,y ,height ,margin ,margin (- ,vsp)))) (stream-set-cursor-position* ,stream ,x1 ,y1) (draw-rectangle ,x ,x1 ,y ,y1 :thickness ,thickness :stream ,stream :filled nil :alu ,alu))))))) ;;; Declaring the drawing functions to be inline gets rid of a funcall, ;;; and does the keyword processing at compile time (if possible). #-(and MCL (not openmcl)) (eval-when (compile load eval) (proclaim '(inline draw-point draw-line draw-string draw-string-image draw-polygon draw-triangle draw-rectangle draw-circle draw-ellipse))) (defun DRAW-POINT (x y &key (stream *standard-output*) (alu %alu) &allow-other-keys) #+clim (clim:draw-point* stream x y :ink alu) #-clim (graphics:draw-point x y :stream stream :alu alu)) (defun DRAW-LINE (u1 v1 u2 v2 &key (stream *standard-output*) (thickness #+clim 1 #-clim nil) (alu %alu) (line-end-shape :butt) (pattern nil) #+clim (line-dashes nil) ;; add parameter, res 3/2/93 &allow-other-keys) #+clim (declare (ignore pattern)) #+clim (clim:draw-line* stream u1 v1 u2 v2 :ink alu :line-thickness thickness :line-cap-shape line-end-shape :line-dashes line-dashes) #-clim (graphics:draw-line u1 v1 u2 v2 :stream stream :alu alu :thickness thickness :line-end-shape line-end-shape :pattern pattern)) (defun draw-string (string u v &key (stream *standard-output*) (alu %alu) (attachment-x :left) (attachment-y :baseline) character-style &allow-other-keys) #+clim (clim:draw-text* stream string u v :ink alu :align-x attachment-x :align-y attachment-y :text-style character-style) #-clim (graphics:draw-string string u v :stream stream :attachment-x attachment-x :attachment-y attachment-y :character-style character-style :alu alu)) (defun draw-vertical-text (text stream u v &key (rotation (/ pi 2)) style (alu %draw)) "Draw ordinary characters on a rotated baseline." ;; U,V defined to be vertex of rotation. Positive rotation ;; is considered to be CLOCKWISE, rather than the usual ;; counterclockwise, so that 90 degree rotation leaves the ;; first character at the TOP. 90 degree rotation is the ;; most common case, so it should look correct. ;; ;; OMIT vertical spacing (VSP) between letters for aesthetic ;; reasons. Looks a little squashed in some cases, but otherwise ;; lettering looks too sparse. (let* ((vsp 2) (height (- (stream-line-height stream) vsp))) (dotimes (i (length text)) (let ((char (elt text i))) (incf u (round (* height (cos rotation)))) (incf v (round (* height (sin rotation)))) (stream-set-cursor-position* stream u v) (draw-string (string char) u v :stream stream :character-style style :alu alu))))) (defun draw-string-image (string u v &key (rotation 0) (stream *standard-output*) (alu %alu) character-style (attachment-y :baseline) &allow-other-keys) (cond ((zerop rotation) (draw-string string u v :alu alu :stream stream :attachment-y attachment-y :character-style character-style)) (t ;; Try to handle rotation. ;; Ideally, we would want to draw on a bitmap here and rotate the bitmap. ;; In CLIM, however, you can't do that. And in Dynamic Windows, that is ;; an extremely expensive operation. So forget it. (draw-vertical-text string stream u v :rotation rotation :alu alu :style character-style)))) (defun draw-polygon (points &key (stream *standard-output*) (alu %alu) (filled nil) &allow-other-keys) #-clim (graphics:draw-polygon points :stream stream :alu alu :filled filled) #+clim (clim:draw-polygon* stream points :ink alu :filled filled)) (defun draw-triangle (u1 v1 u2 v2 u3 v3 &key (stream *standard-output*) (alu %alu) (filled nil) &allow-other-keys) #-clim (graphics:draw-triangle u1 v1 u2 v2 u3 v3 :stream stream :filled filled :alu alu) #+clim (let ((points (list u1 v1 u2 v2 u3 v3))) ;; No stack allocation, please, redisplay needs the list around ;; permanently. (clim:draw-polygon* stream points :ink alu :filled filled))) (defconstant 2pi (* 2 pi)) (defun DRAW-CIRCLE (u v radius &key (filled nil) (stream *standard-output*) (alu %alu) (start-angle 0 start-p) (end-angle 2pi end-p) (thickness 0) &allow-other-keys) ;; 30 Sep 91. CLIM 1.0 bug was detected for start-angle and end-angle. ;; Hence won't pass those keywords along unless supplied. #+clim (if (or start-p end-p) (clim:draw-circle* stream u v radius :ink alu :filled filled :start-angle start-angle :end-angle end-angle :line-thickness thickness ) (clim:draw-circle* stream u v radius :ink alu :filled filled :line-thickness thickness)) #-clim (graphics:draw-circle u v radius :stream stream :alu alu :filled filled :thickness thickness :start-angle start-angle :end-angle end-angle)) (defun DRAW-RECTANGLE (left right bottom top &key (stream *standard-output*) (alu %alu) (filled nil) (thickness nil) &allow-other-keys) #+clim (clim:draw-rectangle* stream left top (1+ right) (1+ bottom) :ink alu :filled filled :line-thickness thickness) #-clim (graphics:draw-rectangle left top right bottom :stream stream :alu alu :filled filled :thickness thickness)) (defun draw-ellipse (x-center y-center x-radius y-radius &key (stream *standard-output*) (filled nil) (alu %alu) (start-angle 0) (end-angle 2pi) thickness) #-clim (graphics:draw-ellipse x-center y-center x-radius y-radius :start-angle start-angle :end-angle end-angle :alu alu :filled filled :stream stream) #+clim (clim:draw-ellipse* stream x-center y-center x-radius 0 0 y-radius :start-angle start-angle :end-angle end-angle :ink alu :line-thickness thickness :filled filled)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/0000755000175000017500000000000011347763412021252 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/annotated-graph.lisp0000644000175000017500000005617707750444411025235 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: GRAPH -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :graph) ;;;ANNOTATED-GRAPH-MIXIN provides a graph with the ability to be annotated. ;;; 1) annotation (put some arbitrary text on the graph) ;;; 2) point annotation (draw a line from the text to some point on the graph) ;;; 3) region annotation (draw a line from the text to some region of the graph) ;;; ;;;ANNOTATED-BORDERS-MIXIN turns the axis labels and the title of a graph into ;;; "border" annotations. A border annotation is like an ordinary annotation except ;;; that it does the right thing when you zoom or rescale. (define-presentation-type annotation () ;; This has to be in a file separate from (defclass annotation ...) because ;; otherwise clim 1.0 complains. jpm. :description "an annotation" :printer ((object stream) (flet ((shorten-string (string &optional (longest 15)) (let ((str (substitute #\space *return* string))) (if (> (length str) longest) (format nil "~A..." (subseq str 0 (1- longest))) str)))) (write-string (shorten-string (annotation-text object)) stream))) :parser ((stream) (read-char stream) (error "You must select an annotation with the mouse."))) (define-presentation-to-command-translator com-move-annotation (annotation :command-name com-move-object :command-table :graph :gesture :select :menu t :documentation "Move") (object &key WINDOW) `(,object ,WINDOW)) (define-graph-command com-delete-annotation ((object 'annotation) (window 'sheet)) "Removes an annotation from a graph." (kill object window)) (define-presentation-to-command-translator com-delete-annotation (annotation :command-name com-delete-annotation :command-table :graph :gesture nil :documentation "Delete") (object &key window) (list object window)) (define-graph-command com-change-annotation-style ((object 'annotation) (window 'sheet)) "Set the text style (or font) of a given annotation." (let ((style (choose-character-style))) (when style (erase object window) (setf (style object) style) (display object window)))) (define-presentation-to-command-translator com-change-annotation-style (annotation :command-name com-change-annotation-style :command-table :graph :gesture nil :documentation "Change Text Style") (object &key window) (list object window)) (define-graph-command com-edit-annotation ((object 'annotation) (window 'sheet)) "Edit the text of the annotation." (edit object window)) (define-presentation-to-command-translator com-edit-annotation (annotation :command-name com-edit-annotation :gesture nil :command-table :graph :tester ((object) (editable object)) :documentation "Edit Annotation Text") (object &key WINDOW) (list object window)) (defclass ANNOTATED-GRAPH-MIXIN (essential-graph-margin-mixin) ((annotations :initform () :initarg :annotations :accessor annotations))) (defmethod annotated-graph-p ((object t)) nil) (defmethod annotated-graph-p ((object annotated-graph-mixin)) t) (defun annotate-something (graph STREAM) (let ((choice (menu-choose `(("Plain Text" :value annotation :documentation "Add your own text to this graph") ("Plain Text + Pointer" :value point-annotation :documentation "Text with a pointer to a point")) :prompt "Choose Type of Annotation"))) (when choice (annotate graph STREAM choice)))) (define-graph-command com-annotations-menu ((object 'graph) (WINDOW 'sheet)) "Create an annotation and prompt the user for the annotation text." (annotate-something object WINDOW)) (define-presentation-to-command-translator com-annotations-menu (graph :command-name com-annotations-menu :command-table :graph :documentation "Add Free Text..." :gesture nil :tester ((object) (annotated-graph-p object))) (object &key WINDOW) (list object window)) (define-graph-command com-graph-identify-point ((graph 'graph) (window 'sheet)) "Prompt the user to select a data point, and annotate it." (let* ((datasets (datasets graph)) (dataset (if (cdr datasets) (menu-choose (mapcar #'(lambda (d) `(,(name d) :value ,d)) datasets) :prompt "Choose a Dataset") (car datasets)))) (when dataset (annotate-data-point dataset window graph)))) (define-presentation-to-command-translator com-graph-identify-point (graph :command-name com-graph-identify-point :command-table :graph :documentation "Identify Data Point..." :gesture nil :tester ((object) (annotated-graph-p object))) (object &key WINDOW) (list object window)) (define-graph-command com-graph-identify-region ((graph 'graph) (window 'sheet)) "Prompt the user to select a data region, and annotate the points contained in the region with descriptive statistics." (let* ((datasets (datasets graph)) (dataset (if (cdr datasets) (menu-choose (mapcar #'(lambda (d) `(,(name d) :value ,d)) datasets) :prompt "Choose a Dataset:") (car datasets)))) (when dataset (annotate-data-region dataset graph window)))) (define-presentation-to-command-translator com-graph-identify-region (graph :command-name com-graph-identify-region :command-table :graph :documentation "Identify Data Region..." :gesture nil :tester ((object) (annotated-graph-p object))) (object &key WINDOW) (list object window)) (defmethod rescale-annotation progn ((self annotated-graph-mixin)) (dolist (a (annotations self)) (rescale-annotation a))) (defmethod rescale :after ((self annotated-graph-mixin)) (rescale-annotation self)) (defmethod display-annotations ((self annotated-graph-mixin) stream) (dolist (annotation (annotations self)) (display annotation stream))) (defmethod display :after ((self annotated-graph-mixin) stream) (display-annotations self stream)) (defmethod erase :before ((self annotated-graph-mixin) stream) ;; After an annotation has been moved, it is no longer a part of the graph ;; presentation tree, it becomes a separate presentation. ;; So we have to take care of the annotations explicitly. (dolist (a (annotations self)) (erase a stream))) (defmethod annotate ((self annotated-graph-mixin) GRAPH-WINDOW type) "Create an annotation and prompt the user for the text." ;; User interface provided by annotated-graph-mixin (let ((annotation (make-instance type :graph self))) (when (create annotation GRAPH-WINDOW) ; User can abort create with mouse-middle. (pushnew annotation (annotations self))))) ;;; BORDER-ANNOTATION ;;; ;;; These have their own "border" coordinate system, so that graph titles and the like ;;; don't go flying off into infinity when you zoom or otherwise rescale. (defclass BORDER-ANNOTATION-MIXIN () ((border :initform nil :initarg :border :accessor border) ;; :left, :top, :right, or :bottom (border-u :initform nil :initarg :border-u :accessor border-u) ;; "border" coordinates (border-v :initform nil :initarg :border-v :accessor border-v))) (defmethod border-to-uv ((self border-annotation-mixin) u v) ;; Coordinate system transformation. (with-slots (graph border) self (multiple-value-bind (ull uur vll vur) (uv-inside graph) (case border (:bottom (values (+ u (values (truncate (+ ull uur) 2))) (+ v vll))) (:top (values (+ u (values (truncate (+ ull uur) 2))) (+ v vur))) (:left (values (+ u ull) (+ v (values (truncate (+ vll vur) 2))))) (:right (values (+ u uur) (+ v (values (truncate (+ vll vur) 2))))))))) (defmethod uv-to-border ((self border-annotation-mixin) u v) ;; Coordinate system transformation. (with-slots (graph border) self (multiple-value-bind (ull uur vll vur) (uv-inside graph) (case border (:bottom (values (- u (values (truncate (+ ull uur) 2))) (- v vll))) (:top (values (- u (values (truncate (+ ull uur) 2))) (- v vur))) (:left (values (- u ull) (- v (values (truncate (+ vll vur) 2))))) (:right (values (- u uur) (- v (values (truncate (+ vll vur) 2))))))))) (defmethod set-xy-position :after ((self border-annotation-mixin) new-x new-y &optional (constrain-p t)) "Set the UV position of the annotation (but constrain it within the window)" (when constrain-p (multiple-value-bind (x y) (xy-to-uv (graph self) new-x new-y) (multiple-value-setq (x y) (uv-to-border SELF x y)) (set-border-position self x y nil)))) (defmethod set-border-position ((self border-annotation-mixin) u v &optional (constrain-p t)) (with-slots (border-u border-v) self (setq border-u u border-v v) (when constrain-p (multiple-value-bind (bu bv) (border-to-uv self u v) (set-uv-position self bu bv nil))))) ;;; Border annotations never get clipped. (defmethod display-p ((self border-annotation-mixin)) t) (defmethod annotation-single-box ((self border-annotation-mixin)) t) (defmethod rescale-annotation progn ((self border-annotation-mixin)) ;; border-to-xy transformation depends on scaling, so recache current ;; position. (with-slots (border-u border-v) self (when (and border-u border-v) (set-border-position self border-u border-v)))) (defclass BORDER-ANNOTATION (border-annotation-mixin annotation) ()) (defun MAKE-BORDER-ANNOTATION (graph STREAM text border u v &optional (type 'border-annotation) (angle 0) (display t)) "Noninteractively add an annotation." (let ((annotation (make-instance type :angle angle :border border :graph graph))) (set-text annotation STREAM text) (setf (style annotation) (default-text-style graph stream)) (set-uv-position annotation u v) (setf (annotations graph) (cons annotation (annotations graph))) (if display (display annotation stream)) annotation)) ;;; The classes X-LABEL, Y-LABEL, and TITLE are all types of border annotations that ;;; are coupled to the corresponding strings stored on the graph. These methods ;;; solve the problem that the string is stored in two places. (defclass x-label (border-annotation) () (:default-initargs :border :bottom)) (defmethod display :before ((self x-label) (stream t)) (setf (annotation-text self) (x-label (graph self)))) (defmethod set-text :after ((self x-label) stream string) (declare (ignore stream)) (let ((graph (graph self))) (when graph (setf (x-label graph) string)))) (defclass y-label (border-annotation) () (:default-initargs :border :left)) (defmethod display :before ((self y-label) (stream t)) (setf (annotation-text self) (y-label (graph self)))) (defmethod set-text :after ((self y-label) stream string) (declare (ignore stream)) (let ((graph (graph self))) (when graph (setf (y-label graph) string)))) (defclass title (border-annotation) () (:default-initargs :border :top)) (defmethod display :before ((self title) (stream t)) (setf (annotation-text self) (title (graph self)))) (defmethod set-text :after ((self title) stream string) (declare (ignore stream)) (let ((graph (graph self))) (when graph (setf (title graph) string)))) (defclass ANNOTATED-BORDERS-MIXIN (annotated-graph-mixin graph-border-mixin basic-graph) ((x-annotation :initform nil :initarg :x-annotation :accessor x-annotation) (y-annotation :initform nil :initarg :y-annotation :accessor y-annotation) (title-annotation :initform nil :initarg :title-annotation :accessor title-annotation)) (:documentation "A mixin for graphs that turns titles and labels into annotations.")) (defmethod x-label-text-style ((graph ANNOTATED-BORDERS-MIXIN) stream) (default-text-style graph stream)) (defmethod y-label-text-style ((graph ANNOTATED-BORDERS-MIXIN) stream) (default-text-style graph stream)) (defmethod title-text-style ((graph ANNOTATED-BORDERS-MIXIN) stream) (default-text-style graph stream)) (defmethod compute-x-annotation ((self annotated-borders-mixin) STREAM) (with-slots (x-annotation ull uur vll x-label) self (when x-label (when (not x-annotation) (LET* ((umid (values (truncate (+ ull uur) 2))) (annotation (make-border-annotation self STREAM x-label :bottom umid ull 'x-label 0 nil)) (width nil)) (setf (style annotation) (x-label-text-style self stream)) (setq width (width annotation)) (set-uv-position annotation (- (values (truncate (+ ull uur) 2)) (values (truncate width 2))) (- vll (* (stream-line-height stream) 1))) (setq x-annotation annotation)))))) (defmethod display-x-label ((self annotated-borders-mixin) STREAM) (compute-x-annotation self STREAM)) ;;; ;;; KRA 27JUL93: ANNOTATED-HORIZONTAL-Y-BORDER-MIXIN-KLUDGE ;;; #|| Here's what's going on. The definition of the class GRAPH is dependent on if characters can be rotated or not, with the following conditionalization in direct superclasses: #-clim vertical-y-border-mixin #+clim horizontal-y-border-mixin Unfortunately, annotated-borders-mixin is simply slapped on top of graph. However, compute-y-annotation has to know which mixing it got. We simply conditionalize the method the same way. This is indicative of the original version of graph being simple minded about fonts and pointer sensitivity. It would be better to either drop the older classes in favor of cleaned up newer ones. Someday, ... ||# #-clim (defmethod compute-y-annotation ((self annotated-borders-mixin) STREAM) (with-slots (y-annotation ull vll vur y-label) self (when y-label (when (not y-annotation) (let* ((annotation (make-border-annotation self STREAM y-label :left ull vll 'y-label (/ pi 2) nil)) (height nil)) (setf (style annotation) (y-label-text-style self stream)) (setq height (* (length y-label) (stream-line-height stream))) (set-uv-position annotation (- ull (* (stream-character-width stream) 3)) (+ (values (truncate (+ vll vur) 2)) (values (truncate height 2)))) (setq y-annotation annotation)))))) #+clim (defmethod compute-y-annotation ((self annotated-borders-mixin) STREAM) (with-slots (y-annotation ull vll vur y-label y-digits) self (when y-label (when (not y-annotation) (let* ((annotation (make-border-annotation self STREAM y-label :left ull vll 'y-label (/ pi 2) nil)) (height nil)) (setf (style annotation) (y-label-text-style self stream)) (setq height (* (length y-label) (stream-line-height stream))) (set-uv-position annotation (- ull (* (stream-character-width stream) (+ y-digits 2))) (+ (values (truncate (+ vll vur) 2)) (values (truncate height 2)))) (setq y-annotation annotation)))))) (defmethod display-y-label ((self annotated-borders-mixin) STREAM) (compute-y-annotation self STREAM)) (defmethod compute-title-annotation ((self annotated-borders-mixin) STREAM) (with-slots (title-annotation ull uur vur) self (when (title self) (when (not title-annotation) (multiple-value-bind (ignore1 ignore2 ignore3 top) (margins self) (declare (ignore ignore1 ignore2 ignore3)) (let* ((umid (values (truncate (+ ull uur) 2))) (annotation (make-border-annotation self STREAM (title self) :top umid vur 'title 0 nil)) (width nil)) (setf (style annotation) (title-text-style self stream)) (setq width (width annotation)) (set-uv-position annotation (- (values (truncate (+ ull uur) 2)) (values (truncate width 2))) (+ vur top (- 5))) (setq title-annotation annotation))))))) (defmethod display-title ((self annotated-borders-mixin) STREAM) (compute-title-annotation self STREAM)) (defclass legend-annotation (border-annotation-mixin basic-annotation) ((margin :initform 10 :initarg :margin :accessor margin) (width :initform 0 :initarg :width :accessor width) (height :initform 0 :initarg :height :accessor height)) (:documentation "An annotation displaying an iconic description of each dataset.")) (defmethod annotation-text ((self legend-annotation)) ;; Called by PRESENT method for annotations. ;; This text may appear in click-right menus. "Dataset Legend") (defmethod draw-outline ((self legend-annotation) stream alu) "Draw a rectangle marking the edges of the annotation." (let ((fudge (margin self))) (multiple-value-bind (width height) (legend-size (graph self) stream (style self)) (setq width (truncate width)) (setq height (truncate height)) (setf (width self) width) (setf (height self) height) (multiple-value-bind (left top) (uv-for-display self) (let ((right (+ left width)) (bottom (- top height))) (multiple-value-setq (left top) (uv-to-screen stream left top)) (multiple-value-setq (right bottom) (uv-to-screen stream right bottom)) (decf left fudge) (incf right fudge) (decf top fudge) (incf bottom fudge) (draw-rectangle left right bottom top :alu alu :stream stream :opaque nil :filled nil)))))) (defmethod display ((self legend-annotation) stream) (let* ((line-height (truncate (stream-line-height stream))) (alu (alu self)) (graph (graph self)) (datasets (datasets graph)) (hidden (hidden-datasets graph))) (when (show-graph-legend graph) (multiple-value-bind (width height) (legend-size graph stream (style self)) (setq width (truncate width)) (setq height (truncate height)) (setf (width self) width) (setf (height self) height) (setq height (values (truncate height (max 1 (- (length datasets) (length hidden)))))) (multiple-value-bind (left top) (uv-for-display self) (draw-outline self stream alu) (dolist (dataset datasets) (unless (or (member dataset hidden) (not (show-legend dataset))) (decf top line-height) (display-legend-dataset dataset STREAM graph left top width height)))))))) (defmethod mark ((self legend-annotation) stream) "Draw a rectangle marking the edges of the annotation." (draw-outline self stream %flip)) (defmethod kill :before ((self legend-annotation) stream) (declare (ignore stream)) ;; make sure the legend doesnt come back if you kill it. (setf (show-legend (graph self)) nil)) (defclass annotated-legend-mixin () () (:documentation "Convert the legend of the graph into a movable annotation. Place the legend inside the graph, but take care to place it where it won't obscure any data.")) (defvar *legend-positions* ; relative coordinates '((0.0 0.25) ; lower left (0.75 1.0) ; upper right (0.0 1.0) ; upper left (0.75 0.25) ; lower right (0.25 1.0) (0.5 1.0) (0.25 0.25) (0.5 0.25) (0.0 0.5) (0.0 0.75) (0.75 0.5) (0.75 0.75) (0.25 0.5) (0.25 0.75) (0.5 0.5) (0.5 0.75))) (defun legend-positions (width height left top right bottom) "Make a list of xy positions where we might consider putting the legend." (let ((relative *legend-positions*) (dx (- right left)) (dy (- top bottom)) (xy nil)) (dolist (p relative) (let ((x (+ left (* (first p) dx))) (y (+ bottom (* (second p) dy)))) (setq x (min x (- right width))) (setq y (max y (+ bottom height))) (push (list x y) xy))) (nreverse xy))) (defun count-points-in-xy-rectangle (graph left top right bottom) (let ((count 0)) (dolist (dataset (datasets graph)) (map-data-xy dataset #'(lambda (x y) (declare (downward-function)) (when (and (<= left x right) (<= bottom y top)) (incf count))) (data dataset))) count)) (defmethod default-annotation-position (graph &optional (width 20) (height 20)) "Find a place (UV) on the graph where the annotation won't obscure any data." (multiple-value-setq (width height) (uv-to-xy-distance graph width height)) (multiple-value-bind (left right bottom top) (xy-inside graph) (let* ((positions (legend-positions width height left top right bottom)) smallest choice) (dolist (position positions) (let* ((left (car position)) (top (second position)) (right (+ left width)) (bottom (- top height)) (count (count-points-in-xy-rectangle graph left top right bottom))) (if (or (not smallest) (< count smallest)) (setq smallest count choice position)))) (apply #'xy-to-uv graph choice)))) (defmethod legend-text-style ((self annotated-legend-mixin) (stream t)) (merge-text-styles (parse-text-style '(nil :roman :very-small)) (stream-current-text-style stream))) (defmethod create-legend ((self annotated-legend-mixin) stream) "Make a legend annotation and position it." (let* ((legend (make-instance 'legend-annotation :graph self :border :right)) (fudge nil)) (setf (style legend) (legend-text-style self stream)) (setq fudge (margin legend)) (push legend (annotations self)) (multiple-value-bind (width height) (legend-size self stream (style legend)) (multiple-value-bind (le te) (default-annotation-position self (+ width (* 4 fudge)) (+ height (* 4 fudge))) (set-uv-position legend (+ le (* 2 fudge)) (- te (* 2 fudge))))) legend)) (defmethod legend-exists-p ((self annotated-legend-mixin)) (dolist (ann (annotations self)) (if (dwim::typep* ann 'legend-annotation) (return-from legend-exists-p t))) ;;;NLC nil) (defmethod display-annotations :before ((self annotated-legend-mixin) stream) (when (and (show-graph-legend self) (not (legend-exists-p self))) (create-legend self stream))) (defmethod display-legend ((self annotated-legend-mixin) stream) ;; Cancel the usual way of displaying a legend. Now the legend is an annotation, ;; therefore display is taken care of separately. (declare (ignore stream)) nil) (defmethod legend-compute-margins ((self annotated-legend-mixin) STREAM left right bottom top) ;; Don't use up valuable real-estate. Stay out of the margins. (declare (ignore stream)) (values left right bottom top)) (defclass ANNOTATED-GRAPH (annotated-legend-mixin annotated-borders-mixin annotated-graph-mixin graph) ()) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/axis.lisp0000600000175000017500000002357410423413302023072 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: GRAPH -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :graph) ;;; AXIS LABELING (defun down (x d) "Round x down modulo d." (- x (mod x d))) (defun hypot (x y) "Computes the hypotenuse of a right triangle with sides of length X and Y. Ie. (sqrt (+ (expt x 2) (expt y 2))) done carefully." (when (< x 0.0) (setq x (- x))) (when (< y 0.0) (setq y (- y))) (when (< x y) (psetq x y y x)) (cond ((zerop x) 0) ((zerop y) x) (t (* x (sqrt (+ 1.0 (* (setq y (/ y x)) y))))))) (defun AUTOTICK-internal (xmin xmax div max-ticks &rest choices) (let ((range (/ (abs (- xmax xmin)) div)) (ifac 1.0) (tick 1.0)) ;; Beat range so that 1.0 <= range <= 10.0 and compute ifac ;; so that original-range = ifac * range (loop while (> range 10.0) do (setq ifac (* ifac 10.0)) (setq range (/ range 10.0))) (loop while (<= range 1.0) do (setq ifac (/ ifac 10.0)) (setq range (* range 10.0))) (setq tick (loop for c in choices when (<= (* range c) max-ticks) do (return (/ 1.0 c)) finally (return 1.0))) (* tick ifac div))) (defun TIME-AUTOTICK (xmin xmax) (let* ((range (abs (- xmax xmin))) (interval (do ((intervals '#.(list (* 365 86400) (* 7 86400) 86400 3600 60 1) (cdr intervals))) ((null intervals) 1) (when (> range (first intervals)) (return (if (> range (* 2 (first intervals))) (first intervals) (or (second intervals) 1)))))) (tick (values (round (autotick-internal xmin xmax interval 12 4 2))))) (if (> interval 3600) tick (* (values (ceiling tick interval)) interval)))) #+old (defun auto-tick (xmin xmax) "Choose a tick interval based on some simple esthetics. The tick interval is a multiple of 2 5 or 10, and there are <= 10 tick marks along the axis." (autotick-internal xmin xmax 1 10 10 5 2)) (defun auto-tick (min max) (let* ((range (- max min)) (tick (expt 10 (truncate (log range 10)))) (count (/ range tick))) (coerce (cond ((<= count 2) (/ tick 5)) ((<= count 5) (/ tick 2)) (t tick)) 'single-float))) (defun make-adjustable-string (&optional (size 7)) ;; (internal to float-to-string) ;; Cons a new string every time; if you reuse an old string, you get graphics ;; turds. (make-array size :element-type #+lucid 'string-char #-lucid 'character :adjustable t :fill-pointer 0)) (defun float-to-string (number &optional (max-digits *max-digits*) (string nil)) "Converts a FLOAT into as short a string as possible while providing max-digits of accuracy. The string may take (+ MAX-DIGITS 6) characters to print. If OUTPUT-STRING, a string with a fill pointer is provided, it will be filled. Otherwise a new string will be created." ;; Sliders call this within mouse-tracking, so it needs to be fast. (or max-digits (setq max-digits *max-digits*)) ; user provided nil? ;; String is assumed to have a fill pointer. (if string (setf (fill-pointer string) 0) (setq string (make-adjustable-string (+ max-digits (if (minusp number) 2 1))))) (if (zerop number) ;; Handle zero as a special case. float-to-string-internal can't deal with it? (progn (vector-push-extend #\0 string) string) (float-to-string-internal number max-digits string))) #| (defun make-test-string () ;; In genera on a 3600, this can be done 800 times per second. (without-interrupts (time (float-to-string 48.65432 3))) ;; About 25% of the time spent consing the string. (without-interrupts (time (make-adjustable-string 4))) ;; 360 times per second. (without-interrupts (time (format nil "~4,1F" 48.65432)))) |# (defun float-to-string-internal (number max-digits string &aux (exponent 0) ilength flength elength exponent-p (extension 5)) (when (< number 0) ; Sign. (vector-push-extend #\- string extension) (setq number (abs number))) (loop while (>= number 10.0) do (setq number (/ number 10.0)) (incf exponent)) (loop while (< number 1.0) do (setq number (* number 10.0)) (decf exponent)) ;; now original (abs number) = number * 10^exponent, 1.0 <= number < 10.0 (incf number (/ 5.0 (expt 10 max-digits))) ; Round up (when (>= number 10.0) ; But not too much. (setq number (/ number 10.0)) (incf exponent)) (cond ((or (> exponent (1- max-digits)) ; E format. (< exponent -3)) (setq ilength 1 exponent-p t)) (t (setq ilength ; F format. (if (>= exponent 0) (1+ exponent) 0) exponent-p nil))) (macrolet ((push-digits (number length string) `(dotimes (.i. ,length) (declare (ignore .i.)) (vector-push-extend (digit-char (values (floor ,number))) ,string extension) (setf ,number (mod (* 10.0 ,number) 10.0))))) (push-digits number ilength string) ; Integer part. (setq flength (- max-digits ilength)) ; Fractional part. (when (or (> flength 0) exponent-p (< exponent 0)) (vector-push-extend #\. string extension) (when (not exponent-p) (loop while (< exponent -1) do (vector-push-extend #\0 string extension) (incf exponent))) (when (not (= number 0.0)) (push-digits number flength string)) (loop while (char= (char string (decf (fill-pointer string))) #\0) finally (incf (fill-pointer string))) (if (char= (char string (1- (fill-pointer string))) #\.) (decf (fill-pointer string)))) (when exponent-p ; Exponent (vector-push-extend #\e string extension) (when (< exponent 0) (vector-push-extend #\- string extension) (setq exponent (abs exponent))) (setq elength 1) (loop while (>= exponent 10.0) do (setq exponent (/ exponent 10.0)) (incf elength)) (push-digits exponent elength string)) string)) (defun LINEAR-AXIS ; Draw a linear axis (xmin ymin ; Axis is drawn between (xmin ymin) and (xmax ymax) xmax ymax ; on the x-y window. (in pixels) umin umax ; Axis units corresponding to min and max points dtick ; Tick spacing in axis units. tick-size ; Length of tick in pixels. Ticks are draw on the ; left side of axis if tick-size > 0, else right side. tick-numbering ; Should axis numbers be added? They are placed ; on the side of the axis opposite the ticks. ; Values are NIL, :MINIMAL, or :EACH. draw-line axis-number label) (declare (downward-funarg draw-line axis-number label)) (if (< umax umin) (rotatef umax umin)) (if (minusp dtick) (setq dtick (- dtick))) (let* ((cos (- xmax xmin)) (sin (- ymax ymin)) (l (hypot cos sin)) (u-scale (/ l (float (- umax umin)))) (ufirst (+ (down umin dtick) dtick)); U value of first tick mark in from left. (smallnum (* dtick .1)) (-smallnum (- smallnum)) u-tick v-tick) (declare (short-float u-scale)) (setq cos (/ cos l)) ; line of axis is x*sin - y*cos + b = 0 (setq sin (/ sin l)) (when (and (not (zerop ufirst)) (< (/ (abs ufirst) dtick) 0.001)) ;; UFIRST wants to be 0 but isn't due to roundoff. (setq ufirst 0.0)) ; Make it 0. (cond ((< (abs (- ufirst umin)) (* 0.1 dtick)) (setq ufirst (+ ufirst dtick)))) (setq u-tick (values (truncate (* tick-size (- sin))))) (setq v-tick (values (truncate (* tick-size cos)))) (funcall draw-line xmin ymin xmax ymax) ; Axis line. ;; Float these so our declarations are correct. (or (floatp ufirst) (setq ufirst (float ufirst))) (or (floatp dtick) (setq dtick (float ufirst))) (or (floatp umin) (setq umin (float umin))) (macrolet ((x-along (u) ;; x and y point u along line x*sin - y*cos + b = 0 `(+ xmin (* cos (values (round (* u-scale (- (the short-float ,u) (the short-float umin)))))))) (y-along (u) `(+ ymin (* sin (values (round (* u-scale (- (the short-float ,u) (the short-float umin)))))))) (~= (a b) `(<= -smallnum (- ,a ,b) smallnum))) (do* ((u ufirst (+ u dtick)) ; Place tick marks (ulast (let ((ulast (down umax dtick))) ;; Tick inside right edge of axis. (if (< (abs (- ulast umax)) (* 0.1 dtick)) (- ulast dtick) ulast)))) ((> u umax)) (when (or (and (eq tick-numbering :minimal) (or (~= u ufirst) (~= u ulast))) (and (eq tick-numbering :each) (<= ufirst u ulast))) (funcall axis-number (x-along u) (y-along u) (if (< (/ (abs u) dtick) 0.001) ; u wants to be 0 0 u))) (let ((x (x-along u)) (y (y-along u))) (funcall draw-line x y (+ x u-tick) (+ y v-tick))))) (if label (funcall label (values (round (+ xmin xmax) 2)) (values (round (+ ymin ymax) 2)))) )) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/symbol.lisp0000644000175000017500000001401407750444412023447 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: GRAPH -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :graph) ;;; CENTERED SYMBOLS ;;; DRAW-SYMBOL is the vanilla way of doing the output. However, for the ;;; case where every call uses the same arguments (which is the most common ;;; case), SYMBOL-DISPLAYER is provided. The latter returns a closure that ;;; can be called as many times as necessary. The benefit is that method ;;; dispatch is done only once. ;;; KRA 27APR93: DRAW-SYMBOL is no longer used in Scigraph, although it may ;;; be useful to users. Perhaps it should be removed. (defgeneric symbol-displayer (type alu thickness filled)) (defmethod symbol-displayer ((type (eql :x)) alu thickness filled) (declare (ignore filled)) #'(lambda (stream u v size) (draw-line (+ u size) (+ v size) (- u size) (- v size) :stream stream :alu alu :thickness thickness) (draw-line (- u size) (+ v size) (+ u size) (- v size) :stream stream :alu alu :thickness thickness))) (defmethod symbol-displayer ((type (eql :box)) alu thickness filled) #'(lambda (stream u v size) (draw-rectangle (- u (1- size)) (+ u (1- size)) ;; JPM: why is this 2 pixels off? (- v size) (+ v size) :stream stream :alu alu :thickness thickness :filled filled))) (defmethod symbol-displayer ((type (eql :+)) alu thickness filled) (declare (ignore filled)) #'(lambda (stream u v size) (draw-line u (+ v size) u (- v size) :stream stream :alu alu :thickness thickness) (draw-line (- u size) v (+ u size) v :stream stream :alu alu :thickness thickness))) (defmethod symbol-displayer ((type (eql :*)) alu thickness filled) (let ((a (symbol-displayer :+ alu thickness filled)) (b (symbol-displayer :x alu thickness filled))) #'(lambda (stream u v size) (funcall a stream u v size) (funcall b stream u v size)))) (defmethod symbol-displayer ((type (eql :triangle)) alu thickness filled) #'(lambda (stream u v size) (device-draw-equilateral-triangle stream u v (* size 2) :alu alu :thickness thickness :filled filled))) (defmethod symbol-displayer ((type (eql :diamond)) alu thickness filled) #'(lambda (stream u v size) (device-draw-diamond stream u v (* size 2) :alu alu :thickness thickness :filled filled))) (defmethod symbol-displayer ((type (eql :point)) alu thickness filled) ;; Try to make this one of the fast ones. ;; Assume the alu is already cached on the stream as the foreground color. (declare (ignore thickness filled)) #'(lambda (stream u v size) (declare (ignore size)) #-clim (graphics:draw-point u v :stream stream) #+clim-0.9 (w::draw-point*-internal stream u v) #+(or clim-1.0 clim-2) (draw-point* stream u v))) (defmethod symbol-displayer ((type (eql :CIRCLE)) alu thickness filled) (if filled #'(lambda (stream u v size) (draw-circle u v size :stream stream :alu alu :filled filled)) #'(lambda (stream u v size) (draw-circle u v size :stream stream :alu alu :thickness thickness)))) ;;; ;;; Symbol presentation type. ;;; (defun draw-avv-symbol (symbol size stream selected-p) (multiple-value-bind (x y) (stream-cursor-position* stream) (let ((displayer (symbol-displayer symbol %draw 0 nil)) (h (max (+ size 2) (stream-line-height stream)))) (if (not selected-p) ;; Draw something, even if not selected, so that really ;; tiny symbols are still easy to choose with the mouse. (draw-rectangle x (+ x h) y (+ y h) :stream stream :alu %erase :filled t)) (funcall displayer stream (+ x (values (truncate h 2))) (+ y (values (truncate h 2))) (values (truncate size 2))) (if selected-p (draw-rectangle x (+ x h) y (+ y h) :stream stream :alu %flip :filled t))))) #-clim-2 (define-presentation-type graph-symbol (&key (symbols '(:+ :x :* :point :triangle :box :diamond :circle)) (size 10)) :description "a graph symbol" :parser ((stream) (completing-from-suggestions (stream) (dolist (symbol symbols) (suggest (string symbol) symbol)))) :printer ((object stream) (write-string (string object) stream)) :accept-values-displayer ((stream object query-identifier) (accept-values-choose-from-sequence stream symbols object query-identifier :drawer #'(lambda (stream object pretty-name selected-p) (declare (ignore pretty-name)) (draw-avv-symbol object size stream selected-p))))) #+clim-2 (define-presentation-type-abbreviation graph-symbol (&key (symbols '(:+ :x :* :point :triangle :box :diamond :circle)) (size 10) graph) ;; Can't simply call this 'color' because that already names a class. `((member ,@symbols) :name-key string-capitalize)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/contour.lisp0000644000175000017500000002335707750444411023644 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: GRAPH -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :graph) ;;; ;;; CONTOUR ;;; #|| ;;; Examples: (defun surface (x y) (* (sqrt (abs (* (- x 15) (abs (- y 35)) (- x 25) (- y 20)))) 1e-1)) (defun try-contour (&optional (stream *standard-output*)) (flet ((plotter (x1 y1 x2 y2 level stream) (let ((scale 10)) ; Pixels per cell (draw-line (* x1 scale) (* y1 scale) (* x2 scale) (* y2 scale) :stream stream :thickness (if (zerop (mod level 10)) 2 0) ))) (map-levels (min max function) (declare (downward-funarg function)) (let ((dlevel 2)) (do ((level (* dlevel (values (round min dlevel))) (+ level dlevel))) ((> level max)) (funcall function level))))) (with-output-recording-disabled (stream) #+genera (graphics:with-room-for-graphics (stream 500) (basic-contour #'surface #'plotter #'map-levels stream :x-max 50 :y-max 50 :dx 1.0 :dy 1.0)) #-genera (basic-contour #'surface #'plotter #'map-levels stream :x-max 50 :y-max 50 :dx 1.0 :dy 1.0)))) (defun make-contour-demo-frame () (let* ((cd (make-instance 'contour-data :contour-surface #'surface)) (cg (make-instance 'contour-graph :datasets (list cd) :auto-scale nil))) (add-dataset cg cd) (set-xy-inside cg nil 0.0 50.0 0.0 50.0) (view-graphs (list cg) :title "Contour" :left 0 :bottom 0 :width 600 :height 400 :create t :wait-until-done nil))) ||# (defun CONTOUR-RANGE (surface x-min dx x-max y-min dy y-max) ;; Returns the minimum and maximum values of (SURFACE x y), ;; x-min <= x <= xmax, y-min <= y, y-min. (do* ((min (funcall surface x-min y-min)) (max min) (x x-min (+ x dx))) ((> x x-max) (values min max)) (do ((y y-min (+ y dy))) ((> y y-max)) (let ((f (funcall surface x y))) (when f (if (< f min) (setq min f) (if (> f max) (setq max f)))))))) (defun MAJOR-MINOR-INTERVALS (min max) ;; Choose a nice major and minor contour interval (let* ((major-interval (auto-tick min max)) (minor-interval (auto-tick 0.0 major-interval))) (values major-interval minor-interval))) (defun BASIC-CONTOUR (surface plotter map-levels stream &key (x-min 0) x-max (y-min 0) y-max (dx 1.0) (dy 1.0)) ;; Contour display of a surface. ;; SURFACE is a function of (X Y) that returns the surface value at (X Y). ;; PLOTTER is a function of (X1 Y1 X2 Y2 LEVEL STREAM) that should draw a line. ;; MAP-LEVELS is a function of (MIN MAX FUNCTION) that should apply FUNCTION to all ;; contour levels between MIN and MAX. ;; See Example TRY-CONTOUR. (declare (downward-funarg surface plotter map-levels)) (let ((x x-min) (y y-min) x2 y2 ll lr ul ur) (flet ((contour-one-cell (level) ;; Plot the contour segments for a cell at x y. ;; UL---UR Consider all four bits, (level < ul,ur,lr,lr) = num ;; | | Then num and (not num) have same contours. Therefore, ;; LL---LR colapse num and (not num) into the 1<= 7. (declare (downward-function)) (macrolet ((plot (dx1 dy1 dx2 dy2) `(funcall plotter (+ x (* dx ,dx1)) (+ y (* dy ,dy1)) (+ x (* dx ,dx2)) (+ y (* dy ,dy2)) level stream))) (let ((num (logior (if (< ul level) 8 0) (if (< ur level) 4 0) (if (< lr level) 2 0) (if (< ll level) 1 0))) xb yb xr yr xt yt xl yl) (if (> num 7) (setq num (- 15 num))) (when (not (= num 0)) (case num (1 (setq xb (/ (- level ll) (- lr ll)) yb 0.0) (setq xl 0.0 yl (/ (- level ll) (- ul ll))) (plot xb yb xl yl)) (2 (setq xb (/ (- level ll) (- lr ll)) yb 0.0) (setq xr 1.0 yr (/ (- level lr) (- ur lr))) (plot xb yb xr yr)) (3 (setq xr 1.0 yr (/ (- level lr) (- ur lr))) (setq xl 0.0 yl (/ (- level ll) (- ul ll))) (plot xl yl xr yr)) (4 (setq xr 1.0 yr (/ (- level lr) (- ur lr))) (setq xt (/ (- level ul) (- ur ul)) yt 1.0) (plot xr yr xt yt)) (5 (setq xb (/ (- level ll) (- lr ll)) yb 0.0) (setq xr 1.0 yr (/ (- level lr) (- ur lr))) (setq xt (/ (- level ul) (- ur ul)) yt 1.0) (setq xl 0.0 yl (/ (- level ll) (- ul ll))) (plot xb yb xt yt) (plot xl yl xr yr)) (6 (setq xb (/ (- level ll) (- lr ll)) yb 0.0) (setq xt (/ (- level ul) (- ur ul)) yt 1.0) (plot xb yb xt yt)) (7 (setq xt (/ (- level ul) (- ur ul)) yt 1.0) (setq xl 0.0 yl (/ (- level ll) (- ul ll))) (plot xl yl xt yt)))))) )) (do () ((> y y-max)) (setq x x-min y2 (+ y dy) ll (funcall surface x y) ul (funcall surface x y2)) (do () ((> x x-max)) (setq x2 (+ x dx) lr (funcall surface x2 y) ur (funcall surface x2 y2)) (when (and ll ul lr ur) (funcall map-levels (min ul ur ll lr) (max ul ur ll lr) #'contour-one-cell)) (setq x x2 ll lr ul ur)) (setq y y2))))) (defclass CONTOUR-DATA (graph-data) (;; Surface value function. (contour-surface :initform nil :initarg :contour-surface :accessor contour-surface) ;; Spacing of grid points... default is 20 pixels apart. (contour-dx :initform nil :initarg :contour-dx :accessor contour-dx) (contour-dy :initform nil :initarg :contour-dy :accessor contour-dy)) ;; Contour-data does not provide scale limits by default, because it gets its limits ;; from the graph. We don't have a good legend yet. (:default-initargs :auto-scale? nil :show-legend nil :present-self-p nil) (:documentation "Contour map of a 2-D surface.")) (defmethod surface-value ((self contour-data) x y) (with-slots (contour-surface) self (funcall contour-surface x y))) #+obsolete (defmethod pop-edit-items ((self contour-data)) (with-slots (contour-dx contour-dy) self `((,(ivar-locf contour-dx) "Contour dx" :number-or-nil) (,(ivar-locf contour-dy) "Contour dy" :number-or-nil)))) (defmethod contour-setup ((self contour-data) graph) (with-slots (contour-surface contour-dx contour-dy) self (multiple-value-bind (left right bottom top) (xy-inside graph) (let ((x-u-scale (x-u-scale graph)) (y-v-scale (y-v-scale graph))) (values contour-surface left (or contour-dx (/ 20 x-u-scale)) right bottom (or contour-dy (/ 20 y-v-scale)) top))))) (defmethod draw-contours ((self contour-data) stream graph) (multiple-value-bind (surface x-min dx x-max y-min dy y-max) (contour-setup self graph) (setq x-min (float x-min 0.0) dx (float dx 0.0) x-max (float x-max 0.0) y-min (float y-min 0.0) dy (float dy 0.0) y-max (float y-max 0.0)) (multiple-value-bind (level-min level-max) (contour-range surface x-min dx x-max y-min dy y-max) #+ig (format *terminal-io* "~% ~A ~A" level-min level-max) (multiple-value-bind (major-interval minor-interval) (major-minor-intervals level-min level-max) (with-slots (alu) self (flet ((plotter (x1 y1 x2 y2 level the-graph) (xy-draw-line the-graph stream x1 y1 x2 y2 :alu alu :thickness (if (< (abs (mod level major-interval)) (* .01 major-interval)) 3 0))) (map-levels (min max function) (declare (downward-funarg function)) (let ((dlevel minor-interval)) (do ((level (* dlevel (values (round min dlevel))) (+ level dlevel))) ((> level max)) (funcall function level))))) (basic-contour surface #'plotter #'map-levels graph :x-min x-min :dx dx :x-max x-max :y-min y-min :dy dy :y-max y-max))))))) (defmethod DISPLAY-DATA ((self CONTOUR-DATA) stream graph) (draw-contours self stream graph)) (defclass CONTOUR-GRAPH-MIXIN (basic-graph) () (:documentation "Let the slider of a graph with contour data on it, display the Z value.")) (defmethod surface-value ((self contour-graph-mixin) x y) (surface-value (first (datasets self)) x y)) (defmethod slider-z-label-string ((self contour-graph-mixin) x-value y-value) "Assume the first dataset is the contour-data." (float-to-string (surface-value self x-value y-value))) (defmethod draw-slider-x-label :after ((self crosshairs) (graph CONTOUR-GRAPH-MIXIN) stream alu value text) (declare (ignore text)) (let ((string (slider-z-label-string graph (slider-x self) (slider-y self)))) (multiple-value-bind (u v) (xy-to-uv graph value (yll graph)) (multiple-value-setq (u v) (uv-to-screen stream u v)) (incf v (* 3 (stream-line-height stream))) (draw-string string u v :stream stream :alu alu)))) (defclass contour-graph (contour-graph-mixin graph) ()) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/duplicate.lisp0000644000175000017500000001023407750444412024114 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: TOOL -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :tool) ;;; ;;; KRA: This needs more documentation ;;; (eval-when (compile load eval) (export '(duplicate-set duplicate-slots duplicator-methods ) 'tool )) (defun duplicate-class-forms-copy (SYMBOL CLASS-NAME SLOT-FORMS) (let ((WITH-SLOTS-SLOTS nil)) (let ((SLOTS-FORMS (loop for (FORM-KIND FIRST-FORM . RST) in SLOT-FORMS collecting (case FORM-KIND (duplicate-set (push FIRST-FORM WITH-SLOTS-SLOTS) `(copy-set-slot ,FIRST-FORM ,@RST)) (duplicate-slots `(copy-slots ,FIRST-FORM ,@RST)) (otherwise (error "Unknown DUPLICATE Form-kind: ~S" FORM-KIND)))))) `(defmethod copy-inner-class progn ((,SYMBOL ,CLASS-NAME) ..COPY-OBJECT.. ..COPY-HTABLE..) (,@(if WITH-SLOTS-SLOTS `(with-slots ,WITH-SLOTS-SLOTS ,symbol) '(progn)) (with-slot-copying (..COPY-OBJECT.. ..COPY-HTABLE..) ,@SLOTS-FORMS)))))) (defun duplicate-class-forms-dump (SYMBOL CLASS-NAME SLOT-FORMS) (let ((WITH-SLOTS-SLOTS nil)) (let ((SLOTS-FORMS (loop for (FORM-KIND FIRST-FORM . RST) in SLOT-FORMS collecting (case FORM-KIND (duplicate-set (push FIRST-FORM WITH-SLOTS-SLOTS) `(dump-set-slot ,FIRST-FORM ,@RST)) (duplicate-slots `(dump-slots ,FIRST-FORM ,@RST)) (otherwise (error "Unknown DUPLICATE Form-kind: ~S" FORM-KIND)))))) `(defmethod dump-forms append ((,SYMBOL ,CLASS-NAME)) (,@(if WITH-SLOTS-SLOTS `(with-slots ,WITH-SLOTS-SLOTS ,SYMBOL) '(progn)) (with-slot-dumping () ,@SLOTS-FORMS)))))) (defun duplicate-class-forms-final-duplicate (SYMBOL CLASS-NAME FINAL-DUPLICATE-FORMS COPY-FORMS? DUMP-FORMS?) (when FINAL-DUPLICATE-FORMS (list `(defmethod final-duplicate-class progn ((,SYMBOL ,CLASS-NAME)) ,@FINAL-DUPLICATE-FORMS) (and COPY-FORMS? `(defmethod copy-final-class progn ((,SYMBOL ,CLASS-NAME)) (final-duplicate-class ,SYMBOL))) (and DUMP-FORMS? `(defmethod final-dump progn ((,SYMBOL ,CLASS-NAME)) (final-duplicate-class ,SYMBOL)))))) ;;; ;;; ;;; (defvar *DUPLICATE-CLASS-FORMS-COPY-FORMS?* t) (defvar *DUPLICATE-CLASS-FORMS-DUMP-FORMS?* t) (defmacro duplicator-methods ((CLASS-NAME &key (symbol 'self) (COPY-FORMS? *DUPLICATE-CLASS-FORMS-COPY-FORMS?*) (DUMP-FORMS? *DUPLICATE-CLASS-FORMS-DUMP-FORMS?*)) SLOT-FORMS &optional FINAL-DUPLICATE-FORMS) #+lispm (declare (zwei:indentation 2 1)) `(progn ,(and COPY-FORMS? (duplicate-class-forms-copy symbol CLASS-NAME SLOT-FORMS)) ,(and DUMP-FORMS? (duplicate-class-forms-dump symbol CLASS-NAME SLOT-FORMS)) ,@(duplicate-class-forms-final-duplicate symbol CLASS-NAME FINAL-DUPLICATE-FORMS COPY-FORMS? DUMP-FORMS?))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/demo-frame.lisp0000640000175000017500000001436210561555366024165 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: GRAPH -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :graph) (defvar graph-number 0 "Keep count of the number of graphs that have been made.") ;;; Making these into formal parameters helps for debugging new graph classes. (defvar *dataset-class* 'graph-data) (defvar *graph-class* 'annotated-graph) (defvar *sampling-rate* .1) ; about 100 samples. (defun make-sample-data () (let* (;; Raw data is simply a list or array whose elements are each a list of ;; length 2, where X = (FIRST LIST), Y = (SECOND LIST). (raw-data (pseudo-random-sequence (random 3.0) (+ (random 3.0) 10.0) *sampling-rate* #'sin .2))) ;; A dataset encapsulates the raw data in a CLOS instance and provides ;; services such as mapping over the raw data and displaying it as a ;; line graph, scatter graph, or whatever. (make-instance *dataset-class* :data raw-data :present-self-p t :symbologies (list :line)))) (defun strange-attractor-array () (let* ((X .1) y (a 3.9) (size 2000) (array (make-array size))) (dotimes (i size) (setq y (* a x (- 1 x))) (setq x (* a y (- 1 y))) (setf (aref array i) (list x y))) array)) (defun make-strange-attractor () (let* ((raw-data (strange-attractor-array))) ;; A dataset encapsulates the raw data in a CLOS instance and provides ;; services such as mapping over the raw data and displaying it as a ;; line graph, scatter graph, or whatever. (make-instance *dataset-class* :data raw-data :symbologies (list :line)))) (defun make-strange-graph () (let* ((dataset (make-strange-attractor)) ;; Make an annotated graph (graph (make-instance *graph-class* :title (format nil "Graph Number ~D" (incf graph-number)) :x-label "Fortnights" :y-label "Furlongs"))) ;; For each dataset, add it to the graph. (add-dataset graph dataset) graph)) (defun make-sample-graph () (let* ((dataset (make-sample-data)) ;; Make an annotated graph (graph (make-instance *graph-class* :title (format nil "Graph Number ~D" (incf graph-number)) :x-label "Fortnights" :y-label "Furlongs" :present-self-p nil))) ;; For each dataset, add it to the graph. (add-dataset graph dataset) graph)) (defun pseudo-random-sequence (from to increment function noise) "Generate some sample data." ;; Result is an array, where each element is a list of length 2 (x,y pair). (let* ((length (+ 2 (values (truncate (- to from) increment)))) (array (make-array length))) (do ((x from (+ x increment)) (i 0 (1+ i))) ((>= i length) array) (setf (aref array i) (list x (+ (funcall function x) (random noise))))))) (defun make-demo-frame (&key create (left 0) (bottom 0) (width 600) (height 400) (wait-until-done #+genera t #-genera nil)) ; Start a new process? "Start a demo scigraph frame." (let ((graph (make-sample-graph))) (add-dataset graph (make-instance 'equation-data :color :salmon :symbologies (list :line-symbol) :data-symbol :circle :pattern nil :equation '(* (sin (* a x)) (sin (* b x))) :variable 'x :min 0 :max 10 :increment .1 :parameters '((a 2) (b 3)))) (view-graphs (list graph) :title "Scigraph Demo" :left left :bottom bottom :width width :height height :create create :wait-until-done wait-until-done))) (defun make-bar-demo () (let* ((graph (make-instance 'annotated-graph :name "Three Categories" :auto-scale nil :xll -1 :yll 0.0 :xur 3.0 :yur 5.0 )) (data '((0.0 3.0) (1.0 4.0) (2.0 3.5))) (dataset (make-instance 'graph-data :name "Categorical Data" :data data :color :red :pattern t :bar-width 0.9 :symbologies '(:bar)))) (add-dataset graph dataset) (view-graphs (list graph) :title "Bar Graph" :wait-until-done nil))) (defun save-sample-graph (&optional (filename "~/sample-graph.ps")) (save-postscript-graph (make-sample-graph) filename)) #|| This shows the minimal number of methods a dataset must provide to get itself drawn on a graph. PLAIN-DATA simply draws a line of slope 1 from 0 to 100. ||# (defclass plain-data () ()) (defmethod name ((data plain-data)) (format nil "~A" data)) (defmethod auto-scale-limits ((data plain-data) type xll xur yll yur) (declare (ignore xll xur yll yur)) (list (min 0 xll) (max 100 xur) (min 0 yll) (max 100 yur))) (defmethod display-data ((data plain-data) STREAM graph) (multiple-value-bind (x1 y1) (xy-to-stream graph stream 0 0) (multiple-value-bind (x2 y2) (xy-to-stream graph stream 100 100) (draw-line* stream x1 y1 x2 y2)))) (defun make-plain-demo () (let ((d (make-instance 'plain-data)) (g (make-instance 'annotated-graph))) (add-dataset g d) (view-graphs (list g) :title "Plain" :left 0 :bottom 0 :width 600 :height 400 :create t :wait-until-done nil))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/load-scigraph.lisp0000644000175000017500000000407007751457764024677 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: User -*- (in-package #-ansi-cl :user #+ansi-cl :common-lisp-user) #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (eval-when (load eval) (unless (fboundp 'compile-and-load-file) (error "You must load dwim before loading scigraph.")) (map nil #'compile-and-load-file '("package" "copy" "dump" "duplicate" "random" "menu-tools" "basic-classes" "draw" "mouse" "color" "basic-graph" "graph-mixins" "axis" "moving-object" "symbol" "graph-data" "legend" "graph-classes" "present" "annotations" "annotated-graph" "contour" "equation" "popup-accept" "popup-accept-methods" "duplicate-methods" "frame" "export" "demo-frame"))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/popup-accept-methods.lisp0000640000175000017500000004300410705412614026171 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: GRAPH -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :graph) ;;; Make popup-accept work for graphs and graph data. (defmethod popup-accept ((SELF basic-graph-data) STREAM) (popup-accept-standard-loop self stream)) (defmethod popup-accept ((SELF basic-graph) STREAM) (popup-accept-standard-loop self stream)) (defmethod popup-accept-from-presentation :around ((self basic-graph-data) stream presentation) "Refresh the graph if there is one under this presentation." (multiple-value-bind (ignore aborted-p) (call-next-method self stream presentation) (declare (ignore ignore)) (when (not aborted-p) (let ((graph (or (graph-under-presentation presentation) (graph-under-annotation-under-presentation presentation)))) (when graph (setf (auto-scale-needed graph) t) ; just in case (refresh graph stream)))) (values self aborted-p))) (defmethod popup-accept-from-presentation :around ((self basic-graph) stream presentation) "Refresh the graph if there is one under this presentation." (multiple-value-bind (ignore aborted-p) (call-next-method self stream presentation) (declare (ignore ignore)) (when (not aborted-p) (let ((graph (graph-under-presentation presentation))) (when (eq graph self) (setf (auto-scale-needed graph) t) ; just in case (refresh graph stream)))) (values self aborted-p))) (defmethod pop-accept-label ((self basic-graph-data)) (name-string self)) (defmethod pop-accept-label ((self basic-graph)) (name-string self)) (define-graph-command com-pop-edit-graph ((graph 'graph) (window 'sheet) (presentation 'invisible-object)) "Edit the attributes of a graph in a dialog box." (popup-accept-from-presentation graph WINDOW PRESENTATION)) (define-presentation-to-command-translator com-pop-edit-graph (graph :command-name com-pop-edit-graph :command-table :graph :documentation "Edit Graph Borders & Labels..." :menu t :gesture :select) (object &key presentation window) (list object window presentation)) (define-graph-command com-pop-edit-dataset ((dataset 'graph-data) (window 'sheet) (presentation 'invisible-object)) "Edit the attributes of some graph data in a dialog box." (popup-accept-from-presentation dataset WINDOW PRESENTATION)) (define-presentation-to-command-translator com-pop-edit-dataset (graph-data :command-name com-pop-edit-dataset :command-table :graph :documentation "Change Data Symbols..." :menu t ;; Genera screws up on mouse sensitivity ;; unless some translator has a :left gesture. :gesture :select) (object &key presentation window) (list object window presentation)) (install-command #+(or clim-0.9 (not clim)) 'accept-values #+(or clim-1.0 clim-2 mcclim) 'clim::accept-values 'com-pop-edit-dataset) #+(or clim-1.0 clim-2) (define-presentation-to-command-translator com-pop-edit-dataset (graph-data :command-name com-pop-edit-dataset :command-table clim::accept-values :documentation "Change Data Symbols..." :menu t :gesture :select) (object &key presentation window) (list object window presentation)) (defmethod pop-accept-items progn ((self named-mixin) MENU-STREAM GRAPH-WINDOW) (declare (ignore GRAPH-WINDOW)) ;; Names are symbols. For the sake of user-friendliness, this method accepts a ;; string, which is more obvious to the user, and coerces it to a symbol. (let* ((name (name self)) (name-string (string name))) (setq name-string (accept 'string :prompt "Name" :view '(text-field-view :width 400) :stream menu-stream :default name-string)) (terpri menu-stream) (setf (name self) name))) (defmethod pop-accept-items progn ((self graph-data-x-offset-mixin) MENU-STREAM GRAPH-WINDOW) (declare (ignore GRAPH-WINDOW)) (popup-accept-forms (MENU-STREAM) (pa-slot x-offset " X Offset" 'number-or-none))) (defmethod pop-accept-items progn ((self graph-data-y-offset-mixin) MENU-STREAM GRAPH-WINDOW) (declare (ignore GRAPH-WINDOW)) (popup-accept-forms (MENU-STREAM) (pa-slot y-offset " Y Offset" 'number-or-none))) (defmethod pop-accept-items progn ((self graph-data-xy-offset-mixin) MENU-STREAM GRAPH-WINDOW) (declare (ignore GRAPH-WINDOW)) (popup-accept-forms (MENU-STREAM) (pa-slot x-offset " X Offset" 'number-or-none) (pa-slot y-offset " Y Offset" 'number-or-none))) (defmethod pop-accept-items progn ((self graph-data-dither-mixin) MENU-STREAM GRAPH-WINDOW) (declare (ignore GRAPH-WINDOW)) (popup-accept-forms (MENU-STREAM) (pa-slot x-dither " X Dither" 'number-or-none) (pa-slot y-dither " Y Dither" 'number-or-none)) (with-slots (x-dither y-dither) self (if x-dither (setq x-dither (max 0.0 x-dither))) ; make it positive. (if y-dither (setq y-dither (max 0.0 y-dither))) )) (defmethod pop-accept-items progn ((SELF graphics-style-mixin) MENU-STREAM GRAPH-WINDOW) (declare (ignore GRAPH-WINDOW)) (popup-accept-forms (MENU-STREAM) (pa-string "Drawing style") (pa-slot pattern " Pattern" `(alist-member :alist ,*SCI-GRAPH-AVAILABLE-STIPPLES*)) (pa-slot THICKNESS " Line Thickness" 'number) )) (defmethod pop-accept-items progn ((self basic-graph-datum-symbology-mixin) MENU-STREAM GRAPH-WINDOW) (declare (ignore GRAPH-WINDOW)) (let ((symbology-choices (symbology-choices self))) (when (cdr symbology-choices) (popup-accept-forms (MENU-STREAM) (pa-slot symbologies "Plotting styles" `(alist-subset :alist ,symbology-choices)))))) (defmethod pop-accept-items progn ((self graph-datum-line-symbology-mixin) MENU-STREAM GRAPH-WINDOW) (declare (ignore GRAPH-WINDOW)) (with-slots (line-style symbologies) self (when (contains-symbology-class symbologies :line) (setf line-style (accept 'dash-pattern :view '(radio-box-view :orientation :horizontal) :stream menu-stream :default line-style :prompt "Line Style")) (terpri menu-stream)) (popup-accept-forms (MENU-STREAM) (when (contains-symbology-class symbologies :line-symbol) (pa-slot min-symbol-spacing "Minimum Symbol Spacing" 'integer))))) (defmethod pop-accept-items progn ((self graph-datum-bar-symbology-mixin) MENU-STREAM GRAPH-WINDOW) (declare (ignore GRAPH-WINDOW)) (with-slots (bar-width symbologies) self (when (contains-symbology-class symbologies :bar) (popup-accept-forms (MENU-STREAM) (pa-slot bar-width "Bar Width" 'number-or-none))))) (defmethod pop-accept-items progn ((self graph-datum-scatter-symbology-mixin) MENU-STREAM GRAPH-WINDOW) (declare (ignore GRAPH-WINDOW)) (with-slots (data-symbol symbol-height symbologies) self ;;;NLC19NOV90 - Do side-effect before SO "DISPLAY WON'T CHANGE BETWEEN REDISPLAYS" (unless symbologies (setq symbologies (list :scatter))) ; DEFAULT (when (contains-symbology-class symbologies :scatter) (popup-accept-forms (MENU-STREAM) (pa-slot symbol-height "Symbol Height" 'number) #-clim-2 (pa-slot data-symbol "Symbol" `(graph-symbol :symbols (:+ :x :* :point :triangle :box :diamond :circle) :size ,(symbol-height self))) #+clim-2 (progn (setq data-symbol (accept `(graph-symbol :symbols (:+ :x :* :point :triangle :box :diamond :circle)) :view +list-pane-view+ :stream menu-stream :default data-symbol :prompt "Symbol")) (terpri menu-stream)) )) (unless symbologies (setq symbologies (list :scatter))) ; DEFAULT )) (defmethod pop-accept-items progn ((self graph-data-color-mixin) MENU-STREAM GRAPH-WINDOW) (when (color-stream-p graph-window) #-clim-2 (popup-accept-forms (menu-stream) (pa-slot color "Color" 'color-presentation)) #+clim-2 (multiple-value-bind (x y) (stream-cursor-position* menu-stream) (setf (slot-value self 'color) (accept 'color-presentation :view +list-pane-view+ :stream menu-stream :default (slot-value self 'color) :prompt "Color")) (terpri menu-stream) (multiple-value-bind (x1 y1) (stream-cursor-position* menu-stream) (stream-set-cursor-position* menu-stream (+ x 250) (+ y 50)) (with-room-for-graphics (menu-stream) (draw-color-swatch menu-stream (slot-value self 'color) nil nil 35)) (stream-set-cursor-position* menu-stream x1 y1))))) (defmethod pop-accept-items progn ((self graph-data-auto-scale-mixin) MENU-STREAM GRAPH-WINDOW) (declare (ignore GRAPH-WINDOW)) (popup-accept-forms (MENU-STREAM) (pa-slot auto-scale? "Contribute to Auto Scaling?" 'boolean))) (defmethod pop-accept-items progn ((self presentable-mixin) MENU-STREAM GRAPH-WINDOW) (declare (ignore GRAPH-WINDOW)) (popup-accept-forms (MENU-STREAM) (pa-slot present-self-p "Mouse sensitive data points?" 'boolean)) (setf (graph-present-inferiors-p self) (present-self-p self))) (defmethod pop-accept-items progn ((self basic-graph) MENU-STREAM GRAPH-WINDOW) (declare (ignore GRAPH-WINDOW)) (let ((type (auto-scale self))) (when (not (eq type :both)) (popup-accept-forms (MENU-STREAM) (pa-string "Axis Limits") (when (member type '(:y nil)) (pa-slot xll " X Left" 'number) (pa-slot xur " X Right" 'number)) (when (member type '(:x nil)) (pa-slot yll " Y Bottom" 'number) (pa-slot yur " Y Top" 'number)))))) (defmethod pop-accept-items progn ((self GRAPH-BORDER-OB-MIXIN) MENU-STREAM GRAPH-WINDOW) (declare (ignore GRAPH-WINDOW)) (with-slots (show-border x-auto-tick x-dtick y-auto-tick y-dtick visible-borders) SELF (popup-accept-forms (MENU-STREAM) (pa-string "Labels and Borders") (pa-slot title " Title" 'string-or-none) (pa-slot x-label " X axis label" 'string-or-none) (pa-slot x-digits " X digits" 'number-or-none) (pa-slot x-tick-numbering " X Tick numbering" '(alist-member :alist (("None" :value nil) ("First & Last" :value :minimal) ("Each" :value :each)))) (pa-slot x-auto-tick " X Auto tick" 'boolean) (unless x-auto-tick (pa-slot x-dtick " X Tick spacing" 'number)) (unless (or x-auto-tick x-dtick) (pa-warn "For X axis: Choose Auto tick or provide a tick spacing")) (pa-slot y-label " Y axis label" 'string-or-none) (pa-slot y-digits " Y digits" 'number-or-none) (pa-slot y-tick-numbering " Y Tick numbering" '(alist-member :alist (("None" :value nil) ("First & Last" :value :minimal) ("Each" :value :each)))) (pa-slot y-auto-tick " Y Auto tick" 'boolean) (unless y-auto-tick (pa-slot y-dtick " Y Tick spacing" 'number)) (unless (or y-auto-tick y-dtick) (pa-warn "For Y axis: Choose Auto tick or provide a tick spacing")) (pa-slot visible-borders " Visible Borders" '(alist-subset :alist (:left :right :bottom :top :zero-abcissa :zero-ordinate))) ))) (defmethod pop-accept-unsatisfied-warnings or ((self GRAPH-BORDER-OB-MIXIN)) (with-slots (x-auto-tick x-dtick y-auto-tick y-dtick) SELF (popup-accept-forms (STREAM) (or (not (or x-auto-tick x-dtick)) (not (or y-auto-tick y-dtick)))))) (defmethod pop-accept-items progn ((self graph-grid-ob-mixin) MENU-STREAM GRAPH-WINDOW) (declare (ignore GRAPH-WINDOW)) (with-slots (show-grid x-auto-grid x-dgrid y-auto-grid y-dgrid) self (popup-accept-forms (MENU-STREAM) (pa-slot show-grid "Display Grid?" 'boolean) (when show-grid (unless (or x-auto-grid x-dgrid) (pa-warn "For X axis: Choose Auto Grid or provide a grid spacing")) (pa-slot x-auto-grid " X Default Grid" 'boolean) (unless x-auto-grid (pa-slot x-dgrid " Grid spacing" 'number)) (unless (or y-auto-grid y-dgrid) (pa-warn "For Y axis: Choose Auto Grid or provide a grid spacing")) (pa-slot y-auto-grid " Y Default Grid" 'boolean) (unless y-auto-grid (pa-slot y-dgrid " Grid spacing" 'number)))))) (defmethod pop-accept-unsatisfied-warnings or ((SELF graph-grid-ob-mixin)) (with-slots (x-auto-grid x-dgrid y-auto-grid y-dgrid) SELF (popup-accept-forms (STREAM) (or (not (or x-auto-grid x-dgrid)) (not (or y-auto-grid y-dgrid)))))) (defmethod pop-accept-items progn ((self graph-datasets-ob-mixin) MENU-STREAM GRAPH-WINDOW) (declare (ignore GRAPH-WINDOW)) (with-slots (datasets) self (when datasets (popup-accept-forms (MENU-STREAM) (pa-string1 "Datasets:") (loop for DS in DATASETS do (write-char #\space MENU-STREAM) (present DS 'graph-data :stream MENU-STREAM)) (terpri MENU-STREAM) )))) (defmethod pop-accept-items progn ((self graph-auto-scale-mixin) MENU-STREAM GRAPH-WINDOW) (declare (ignore GRAPH-WINDOW)) (popup-accept-forms (MENU-STREAM) (pa-slot auto-scale "Auto Scaling?" '(alist-member :alist (("X" :value :x) ("Y" :value :y) ("Both" :value :both) ("None" :value nil)))))) #+ignore (defmethod pop-accept-items progn ((self graph-auto-scale-extensions-mixin) MENU-STREAM GRAPH-WINDOW) (declare (ignore GRAPH-WINDOW)) (with-slots (auto-scale auto-scale-extensions) self (when auto-scale (popup-accept-forms (MENU-STREAM) (pa-string " % Extension:") (when (member auto-scale '(:x :both)) (pa-var (first auto-scale-extensions) " Left " 'number) (pa-var (second auto-scale-extensions) " Right " 'number)) (when (member auto-scale '(:y :both)) (pa-var (third auto-scale-extensions) " Bottom" 'number) (pa-var (fourth auto-scale-extensions) " Top " 'number) )))) ) (defmethod popup-accept :after ((self equation-data) stream) (declare (ignore stream)) (with-slots (equation) self (setf (equation self) equation))) (defmethod pop-accept-items progn ((self equation-data) MENU-STREAM GRAPH-WINDOW) (declare (ignore GRAPH-WINDOW)) (with-slots (parameters) self (popup-accept-forms (MENU-STREAM) (pa-slot equation "Equation" 'expression) (pa-slot variable "Variable" 'expression) (pa-slot min "Mininum variable value" 'number) (pa-slot max "Maximum variable value" 'number) (pa-slot increment "Increment" 'number) ) (format menu-stream "Parameters:") (terpri menu-stream) (loop for INDEX from 0 below (length PARAMETERS) for QUERY-ID = (nth INDEX PARAMETERS) do (setf (second (nth INDEX PARAMETERS)) (popup-accept-forms-accept MENU-STREAM (concatenate 'string " " (string (first (nth INDEX parameters)))) 'number (second (nth INDEX PARAMETERS)) QUERY-ID)) (terpri menu-stream)))) (defmethod popup-accept :after ((self graph-sample-data-mixin) STREAM) (declare (ignore STREAM)) (when (sample-data self) (compute self))) (defmethod pop-accept-items progn ((self histogram-data) MENU-STREAM GRAPH-WINDOW) (declare (ignore GRAPH-WINDOW)) (popup-accept-forms (MENU-STREAM) (pa-slot min "Minimum Value" 'number-or-none) (pa-slot max "Maximum Value" 'number-or-none) (pa-slot bin-count "Number of Bins" 'number-or-none) (pa-slot bin-size "Bin Size" 'number-or-none)) (with-slots (bin-count bin-size min max) self (when (and (numberp min) (numberp max)) (when (numberp bin-count) (setq bin-size (or bin-size (float (/ (- max min) bin-count))))) (when (numberp bin-size) (setq bin-count (or bin-count (values (truncate (- max min) bin-size)))))))) (defmethod pop-accept-items progn ((self line-mixin) MENU-STREAM GRAPH-WINDOW) (declare (ignore GRAPH-WINDOW)) (multiple-value-bind (slope intercept) (slope-intercept self) (popup-accept-forms (MENU-STREAM) (pa-string "Slope: ~a" slope) (pa-string "Intercept: ~a" intercept)))) (defmethod pop-accept-items progn ((self GRAPH-DATA-LEGEND-MIXIN) MENU-STREAM GRAPH-WINDOW) (declare (ignore GRAPH-WINDOW)) (popup-accept-forms (MENU-STREAM) (pa-slot show-legend "Display on legend?" 'boolean))) #+old (defmethod pop-accept-items progn ((self graph-data-legend-slot-mixin) MENU-STREAM GRAPH-WINDOW) (declare (ignore GRAPH-WINDOW)) (popup-accept-forms (MENU-STREAM) (pa-slot legend " Description for legend" 'string-or-none))) (defmethod pop-accept-items progn ((self graph-legend-mixin) MENU-STREAM GRAPH-WINDOW) (declare (ignore GRAPH-WINDOW)) (popup-accept-forms (MENU-STREAM) (pa-slot show-legend "Display legend?" 'boolean))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/dump.lisp0000644000175000017500000001140507751457764023127 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: TOOL -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :tool) (eval-when (compile load eval) (export `(dump-forms with-slot-dumping dump-set-slot dump-slot dump-slots final-dump #+lispm make-load-form dumpable-mixin) 'tool)) (defclass dumpable-mixin () () (:documentation "Provides method for doing DUMP of an object. Each mixin should provide an DUMP-FORMS and FINAL-DUMP-CLASS method to copy its slots appropriately.")) (defgeneric final-dump (SELF) (:method-combination progn)) (defmethod final-dump progn ((SELF dumpable-mixin)) self) (defgeneric dump-forms (SELF) (:method-combination append) (:documentation "Defined for each component class of an object with mixin DUPLABLE-MIXIN. It should setup its slots as appropriate.")) (defmethod dump-forms append ((SELF dumpable-mixin)) nil) (defmethod make-load-form #-ansi-cl ((SELF dumpable-mixin)) #+ansi-cl ((SELF dumpable-mixin) &optional env) #+ansi-cl (declare (ignore env)) (values `(make-instance ',(class-name (class-of SELF))) `(progn ,@(dump-forms SELF) (final-dump ,SELF)))) ;;; KRA: These could go into the macrolet below. ;;; KRA: It would be better if the form prouced by dump-forms was very compact ;;; KRA: for example, it wouldn't mention the object for each slot or ;;; KRA: the slot names each time an object is dumped. ;;; KRA: There are 2 reasons to be compact, consing while dumping, and ;;; KRA: size of binary file. ;;; KRA: So, dump-forms could produce something like: ;;; KRA: (dump-load object (list slot-value-1 slot-value-2 ...)) ;;; Things to make using DUMP-FORMS easier. (defmacro dump-set-slot-1 (DUMP-OBJECT SLOT-NAME VALUE) ``(setf (slot-value ,,DUMP-OBJECT ',',SLOT-NAME) ',,VALUE)) (defmacro dump-slot-1 (DUMP-OBJECT SLOT-NAME) `(dump-set-slot-1 ,DUMP-OBJECT ,SLOT-NAME (slot-value ,DUMP-OBJECT ',SLOT-NAME))) (defmacro with-slot-dumping ((&optional (DUMP-OBJECT 'SELF)) &body BODY) `(let ((..FORMS-LIST.. nil)) (macrolet ((dump-set-slot (SLOT-NAME VALUE) `(push (dump-set-slot-1 ,',DUMP-OBJECT ,SLOT-NAME ,`,VALUE) ..FORMS-LIST..)) (dump-slot (SLOT-NAME) `(push (dump-slot-1 ,',DUMP-OBJECT ,SLOT-NAME) ..FORMS-LIST..))) (macrolet ((dump-slots (&rest SLOT-NAMES) `(progn ,@(loop for SLOT-NAME in SLOT-NAMES collecting `(dump-slot ,SLOT-NAME))))) ,@BODY)) (reverse ..FORMS-LIST..))) ;;; JPM. Until the vendors catch up with the spec, implement here ;;; some of the dumpers we need for common lisp things. #-ansi-cl (defmethod make-load-form ((any t)) (cond ((hash-table-p any) (let ((entries nil)) (maphash #'(lambda (key val) (push (list key val) entries)) any) `(let ((h (make-hash-table))) ,@(mapcar #'(lambda (entry) `(setf (gethash ',(car entry) h) ',(second entry))) entries) h))) ((stringp any) any) ((arrayp any) (let* ((a any) (dimensions (array-dimensions a)) (adjustable (adjustable-array-p a)) (type (array-element-type a)) (fp (array-has-fill-pointer-p a)) (contents (if (cdr dimensions) (error "don't know how to dump a multidimensional array") (map 'list #'identity a)))) `(make-array ',(if fp (fill-pointer a) dimensions) :initial-contents ',contents ,@(if (not (eq type 't)) `(:element-type ',type)) ,@(if adjustable `(:adjustable t)) ,@(if fp `(:fill-pointer ,(fill-pointer a)))))) (t any))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/popup-accept.lisp0000640000175000017500000002720710705412614024537 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: GRAPH -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :graph) ;;; This file contains functionality for editing instances in a popup-style window. ;;; You do not need to "mix" anything in to get the functionality, you just need to ;;; provide some methods to customize the behavior. ;;; ;;; (POPUP-ACCEPT instance stream), top level function call ;;; ;;; (POPUP-ACCEPTABLE instance), returns T if you can pop-edit the instance. The ;;; default is NIL. ;;; ;;; (POP-ACCEPT-ITEMS instance), a PROGN-combined method that formats each of the ;;; items in the display. ;;; ;;; (POP-ACCEPT-LABEL instance), the title for the editor pane. ;;; ;;; (POP-ACCEPT-UNSATISFIED-WARNINGS instance), an OR-combined method that provides ;;; constraints that encourage the user to make sense. Constraints are not rigidly ;;; enforced until the user tries to quit, because users are willing to tolerate ;;; temporary inconsistencies. ;;; ;;; ABORT is not handled by editing a copy of the object. Rather, a snapshot of the ;;; object is taken beforehand, and an abort handler is provided to restore the ;;; object's state afterward if necessary, based on the saved snapshot. ;;;******************************************************************************** ;;; ;;;******************************************************************************** ;;; Here we provide the default behavior, which is extremely simple and which works ;;; on any instance. (defmethod pop-accept-label ((self t)) (present-to-string self)) (defmethod popup-acceptable ((self t)) nil) (defmethod popup-accept-variables ((self standard-object)) "Get list of instance variables." (let ((slots ;; Blech. What's wrong with my package? #FEATURE-CASE ((:mcclim (mapcar #'clim-mop:slot-definition-name (clim-mop:class-slots (class-of self)))) ((and (not :mcclim) (not :mcl)) (mapcar #'slot-definition-name (class-slots (class-of self)))) ((and (not :mcclim) :mcl) (mapcar #'ccl:slot-definition-name (ccl:class-class-slots (class-of self))))) )) (sort slots #'string-lessp))) (defconstant *unbound* '%%unbound%%) (defmethod restore-object-state ((self standard-object) snapshot) "Abort handler to restore original variable values." (loop for variable in (popup-accept-variables self) for value in snapshot do (if (eq value *unbound*) (slot-makunbound self variable) (setf (slot-value self variable) value)))) (defmethod snapshot-object-state ((self standard-object)) "Record original variable values in case of abort." (loop for variable in (popup-accept-variables self) for VALUE = (if (slot-boundp self variable) (slot-value self variable) *unbound*) ;;;NLC19NOV90 - SOME OF THE LISTS ARE EXPLICITLY BASHED DURING THE POPUP collect (if (consp VALUE) (copy-list VALUE) VALUE))) (defmethod abort-protect ((self t) (continuation t)) ;;(declare (values instance aborted-p)) (let ((snapshot (snapshot-object-state self))) #-clim (si:condition-case (ERR) (funcall continuation) (si:abort (restore-object-state self snapshot) :abort)) #+clim (let ((value (funcall continuation))) (when (eq value :abort) (restore-object-state self snapshot)) value))) (defmethod popup-accept ((SELF standard-object) STREAM) ;; Default way to edit an instance, works on any instance. ;; Collect up the instance variables and accept new values for them. (let ((TITLE (pop-accept-label SELF))) (accepting-values (stream :own-window t :label title) (dolist (var (popup-accept-variables self)) (if (slot-boundp self var) (setf (slot-value self var) (accept 'expression :stream stream :default (slot-value self var) :prompt (string var))) (format stream "~A: unbound" var)) (terpri stream))))) (defmethod popup-accept :around ((SELF t) STREAM) (let ((*print-level* 5) ; Avoid printing deeply nested (*print-circle* t) ; and circular (*print-length* 25)) ; and long structures. (abort-protect self #'(lambda () (call-next-method self stream))))) (defmethod popup-accept-from-presentation ((self t) (stream t) (presentation t)) "Like popup-accept except you get a hook onto the presentation." ;;(declare (values self aborted-p)) (values self (eq (popup-accept self stream) :abort))) (define-command (com-pop-edit :command-table :global) ((object 'invisible-object) (window 'sheet) (presentation 'invisible-object)) (popup-accept-from-presentation object WINDOW PRESENTATION)) ;;; Scigraph no longer uses this translator to edit graphs and graph-data. ;;; The documentation string is too generic and tends to confuse naive users. ;;; Elsewhere there are better translators specific to those ptypes. This ;;; translator remains as a tool that others might want to use. (define-presentation-to-command-translator com-pop-edit (t :command-name com-pop-edit :command-table :graph :tester ((object) (popup-acceptable object)) :documentation "Edit (Pop Up Window)" :menu t :gesture :edit) (object &key presentation window) (list object window presentation)) (install-command #+(or clim-0.9 (not clim)) :accept-values #+(or clim-1.0 clim-2 mcclim) 'clim::accept-values 'com-pop-edit) ;;; ;;; Syntactic sugar and constraint checking. ;;; (defgeneric pop-accept-items (self MENU-STREAM GRAPH-WINDOW) (:method-combination progn #-lucid :most-specific-last)) ;;; +++ Until lucid gets :most-specific-last, pop-accept-items isn't going to work ;;; quite right for the case where display is conditioned on the values of other ;;; items. Accepting-values doesn't make a full pass over all the items, which is a ;;; problem without :most-specific-last. jpm 1 Mar 91. +++ (defgeneric pop-accept-unsatisfied-warnings (self) (:method-combination or)) (defmethod pop-accept-unsatisfied-warnings or ((self t)) nil) (defmacro popup-accept-forms-accept (STREAM PROMPT-STRING ATYPE DEFAULT QUERY-ID &rest ACCEPT-ARGS) `(accept ,ATYPE :stream ,STREAM :prompt ,PROMPT-STRING :default ,DEFAULT :query-identifier ,QUERY-ID ,@ACCEPT-ARGS)) ;;; Added code to return a values list of the accepted value and ;;; a flag indicating that the value changed (Test EQL). Clim 1.0 ;;; does something like this AGB (defmacro popup-accept-forms-var (STREAM VAR-NAME PROMPT-STRING ATYPE &rest ACCEPT-ARGS) `(let ((%%old-value%% ,var-name)) (setf ,VAR-NAME (popup-accept-forms-accept ,STREAM ,PROMPT-STRING ,ATYPE %%old-value%% ,VAR-NAME;;here was ', ,@ACCEPT-ARGS)) (terpri ,stream) (values ,var-name (not (eql ,var-name %%old-value%%))))) (defmacro popup-accept-forms-slot (OBJECT STREAM SLOT-NAME PROMPT-STRING ATYPE &rest ACCEPT-ARGS) `(let ((%%old-value%% (slot-value ,OBJECT ,SLOT-NAME))) (setf (slot-value ,OBJECT ,SLOT-NAME) (popup-accept-forms-accept ,STREAM ,PROMPT-STRING ,ATYPE %%old-value%% ,SLOT-NAME;;here was ', ,@ACCEPT-ARGS)) (terpri ,stream) (values (slot-value ,OBJECT ,SLOT-NAME) (not (eql (slot-value ,OBJECT ,SLOT-NAME) %%old-value%%))))) (defmacro popup-accept-forms-string ((STREAM &optional (TERPRI? t)) STRING &rest ARGS) `(progn (redisplayable-format ,STREAM ,STRING ,@ARGS) ,(and TERPRI? `(terpri ,STREAM)))) (defmacro popup-accept-forms-warn ((STREAM &optional (TERPRI? t)) STRING &rest ARGS) `(with-character-face (:bold ,stream) (redisplayable-format ,STREAM "WARNING:<<~?>>" ,STRING ,ARGS) ,(and TERPRI? `(terpri ,STREAM)))) ;;; Acceptable FORMS ;;; (PA-SLOT . ) ;;; (PA-VAR . ) ;;; (PA-STRING &rest ARGS) Followed by (Terpri) ;;; (PA-STRING1 &rest ARGS) NOT Followed by (Terpri) (defmacro popup-accept-forms ((STREAM &optional (OBJECT 'SELF)) &body BODY) `(macrolet ((pa-accept (PROMPT-STRING ATYPE DEFAULT QUERY-ID &rest ACCEPT-ARGS) `(popup-accept-forms-accept ,',STREAM ,PROMPT-STRING ,ATYPE ,DEFAULT ,QUERY-ID ,@ACCEPT-ARGS)) (pa-slot (SLOT-NAME PROMPT-STRING ATYPE &rest ACCEPT-ARGS) `(popup-accept-forms-slot ,',OBJECT ,',STREAM ',SLOT-NAME ,PROMPT-STRING ,ATYPE ,@ACCEPT-ARGS)) (pa-var (VAR-NAME PROMPT-STRING ATYPE &rest ACCEPT-ARGS) `(popup-accept-forms-var ,',STREAM ,VAR-NAME,PROMPT-STRING ,ATYPE ,@ACCEPT-ARGS)) (pa-warn (STRING &rest ARGS) `(popup-accept-forms-warn (,',STREAM) ,STRING ,@ARGS)) (pa-string (STRING &rest ARGS) `(popup-accept-forms-string (,',STREAM) ,STRING ,@ARGS)) (pa-string1 (STRING &rest ARGS) `(popup-accept-forms-string (,',STREAM nil) ,STRING ,@ARGS)) ) (progn ,@BODY))) (defvar *avv-extra-redisplay* nil) (defun popup-accept-standard-loop (self stream) "Used by most POPUP-ACCEPT methods." (let ((GRAPH-WINDOW STREAM) (MENU-MENU-STREAM STREAM) (TITLE (pop-accept-label SELF)) (result self) (*avv-extra-redisplay* t) (own-window #-clim t ;; Clim/Lucid may lose if you pass a list that the compiler ;; may have assumed was a constant, so copy it at run ;; time. ("Segmentation Violation") #+clim (copy-list '(:left 150 :bottom 150 :right-margin 50 :bottom-margin 200)))) (loop for FIRST-TIME? = t then nil do (setq result (accepting-values (menu-menu-stream :own-window own-window :label title) (unless FIRST-TIME? (popup-accept-forms-string (menu-menu-stream nil) "To proceed, correct all condition marked with ") (popup-accept-forms-warn (menu-menu-stream) ".") (popup-accept-forms-string (menu-menu-stream) "Or click on \"Abort\" to cancel all changes.~%")) (pop-accept-items SELF MENU-MENU-STREAM GRAPH-WINDOW) )) while (pop-accept-unsatisfied-warnings SELF) do (progn (beep) (beep))) result)) #+clim-0.9 (defmethod ci::execute-frame-command :after ((frame ci::accept-values) command &optional x) (declare (ignore command x)) ;; Force an extra redisplay so things look right (clim extension). (when *avv-extra-redisplay* (let ((avv (ci::output-record-parent ci::*current-avv-record*))) (when avv (ci::redisplay avv (slot-value frame 'ci::stream)))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/graph-mixins.lisp0000644000175000017500000007336007750444412024561 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: GRAPH -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :graph) ;;; SOME GRAPH MIXINS (defclass GRAPH-MOUSE-RESOLUTION-MIXIN (basic-graph) ((dx-mouse :initform nil :initarg :dx-mouse) ; Resolution (in units) (dy-mouse :initform nil :initarg :dy-mouse)) ; used to convert from ; mouse -> xy coordinates ) (defmethod rescale :after ((self graph-mouse-resolution-mixin)) (compute-mouse-resolution self)) (defmethod compute-mouse-resolution ((self graph-mouse-resolution-mixin)) ;;This method provides at least 1 pixel accuracy. (with-slots (dx-mouse dy-mouse x-u-scale y-v-scale) self (setq dx-mouse (expt 10.0 (values (floor (log (/ x-u-scale) 10)))) dy-mouse (expt 10.0 (values (floor (log (/ y-v-scale) 10))))))) (defmethod uv-to-xy :around ((self graph-mouse-resolution-mixin) u v) (with-slots (dx-mouse dy-mouse) self (multiple-value-bind (x y) (call-next-method self u v) (values (* (values (round x dx-mouse)) dx-mouse) (* (values (round y dy-mouse)) dy-mouse))))) ;;; This should probably be several mixins, its gaining a lot of baggage... (defclass GRAPH-BORDER-MIXIN (basic-graph named-mixin) ((show-border :initform t :initarg :show-border :accessor show-border) (tick-size :initform 7. :initarg :tick-size) ;In pixels. (title :initform nil :initarg :title :reader title) ;Title centered (x-label :initform nil :initarg :x-label ;Label for left x axis. :accessor x-label) (x-digits :initform 6 :initarg :x-digits :accessor x-digits) (x-auto-tick :initform t :initarg :x-auto-tick) ;Auto-tick? (x-dtick :initform nil :initarg :x-dtick) ;Tk Spacing if not auto. (x-tick-numbering :initform :minimal ; :minimal, :each, or nil. :initarg :x-tick-numbering) (y-label :initform nil :initarg :y-label :accessor y-label) (y-digits :initform 6 :initarg :y-digits :accessor y-digits) (y-auto-tick :initform t :initarg :y-auto-tick) (y-dtick :initform nil :initarg :y-dtick) (y-tick-numbering :initform :minimal :initarg :y-tick-numbering) (visible-borders :initform (copy-list '(:left :bottom :right :top)) :initarg :visible-borders :accessor visible-borders)) (:documentation "Simple Border and axis labeling.")) (defmethod initialize-instance :after ((self graph-border-mixin) &key &allow-other-keys) (with-slots (title) self (when title (setf (title self) title)))) (defmethod (setf title) (new-title (self graph-border-mixin)) (with-slots (title) self (setq title (when title (cond ((stringp new-title) new-title) ((symbolp new-title) (string new-title)) (t (format nil "~a" new-title))))))) (defmethod (setf x-dtick) (arg (self graph-border-mixin)) (declare (ignore arg)) (with-slots (x-auto-tick) self (setq x-auto-tick nil))) (defmethod (setf y-dtick) (arg (self graph-border-mixin)) (declare (ignore arg)) (with-slots (y-auto-tick) self (setq y-auto-tick nil))) (defmethod COMPUTE-MARGINS :around ((self GRAPH-BORDER-MIXIN) STREAM) (multiple-value-bind (left right bottom top) (call-next-method) (with-slots (x-tick-numbering) self (values left (+ (stream-character-width stream) right) ; 1 character right (+ (* (if x-tick-numbering 3 2) ; X numbers and label (stream-line-height stream)) bottom) (+ (* 2 (stream-line-height stream)) top))))) ; title + 1 (defmethod axis-number-horizontal ((self GRAPH-BORDER-MIXIN) STREAM x y number-string the-tick-size) "Put a centered number string at current u v position on a horizontal axis." (multiple-value-bind (cu cv) (char-position-relative-to-uv self STREAM x y (- (* (length number-string) 0.5)) (if (> the-tick-size 0) -1.0 0.5) 0) (text self STREAM cu cv number-string :alu %draw))) (defmethod axis-number-vertical ((self GRAPH-BORDER-MIXIN) STREAM x y number-string the-tick-size) "Put a centered number string at current u v position on a vertical axis." (multiple-value-bind (cu cv) ; Y axis. (char-position-relative-to-uv self STREAM x y (if (> the-tick-size 0) 0.5 (- (+ (length number-string) 0.5))) -.5 0) (setq cu (max 10 cu)) ; Make sure it fits on window!? (text self STREAM cu cv number-string :alu %draw))) (defmethod AXIS-LABEL-HORIZONTAL ((self GRAPH-BORDER-MIXIN) STREAM x y label the-tick-size) ;; Put label centered below numbers (with-slots (x-tick-numbering) self (multiple-value-bind (cu cv) (char-position-relative-to-uv self STREAM x y (- (* (length label) 0.5)) (if (< the-tick-size 0) 1.5 (if (null x-tick-numbering) -1.0 -2.0)) 0) (text self STREAM cu cv label :alu %draw)))) (defmethod AXIS-LABEL-VERTICAL ((self GRAPH-BORDER-MIXIN) STREAM x y label the-tick-size) (declare (ignore the-tick-size)) (with-slots (y-tick-numbering) self (do ((x-char (if (null y-tick-numbering) -2.0 (+ 3 (- (/ (left-margin-size self) (stream-character-width STREAM)))))) (y-char (- (* (length label) 0.5) 1.0) (- y-char 1.0)) (ichar 0 (1+ ichar))) ((>= ichar (length label)) nil) (multiple-value-bind (cu cv) (char-position-relative-to-uv self STREAM x y x-char y-char 0) (text self STREAM cu cv (aref label ichar) :alu %draw))))) ;;; These methods determine what the tick spacing should be. (defmethod x-tick-spacing ((self GRAPH-BORDER-MIXIN)) (with-slots (x-auto-tick xll xur x-dtick) self (if x-auto-tick (auto-tick xll xur) x-dtick))) (defmethod y-tick-spacing ((self GRAPH-BORDER-MIXIN)) (with-slots (y-auto-tick yll yur y-dtick) self (if y-auto-tick (auto-tick yll yur) y-dtick))) (defmethod display-x-label ((self graph-border-mixin) stream) (with-slots (ull uur vll tick-size) self (let ((label (x-label self)) (x (values (round (+ ull uur) 2))) (y vll)) (when label (axis-label-horizontal self STREAM x y label tick-size))))) (defmethod display-y-label ((self graph-border-mixin) stream) (with-slots (ull vll vur tick-size) self (let ((label (y-label self)) (x ull) (y (values (round (+ vll vur) 2)))) (when label (axis-label-vertical self STREAM x y label tick-size))))) (defmethod display-title ((self graph-border-mixin) STREAM) (with-slots (uur ull vur) self (let (the-title) (when (setq the-title (title self)) (multiple-value-bind (cu cv) (char-position-relative-to-uv self STREAM (values (truncate (+ uur ull) 2)) vur (- (/ (length the-title) 2.0)) 0.5 0) (text self STREAM cu cv the-title :alu %draw)))))) (defmethod display-labels ((self graph-border-mixin) stream) (display-x-label self stream) (display-y-label self stream) (display-title self stream) (force-output stream)) (defmethod display-border ((self graph-border-mixin) STREAM) (when (show-border self) (with-clipping-to-graph (self STREAM nil) (let* ((visible (visible-borders self)) (drawer (make-optimized-line-displayer %draw 1 t)) (line-drawer #'(lambda (x1 y1 x2 y2) (declare (downward-function)) (multiple-value-setq (x1 y1) (uv-to-screen stream x1 y1)) (multiple-value-setq (x2 y2) (uv-to-screen stream x2 y2)) (funcall drawer stream x1 y1 x2 y2)))) (when (member :right visible) (display-right-border self STREAM line-drawer)) (when (member :top visible) (display-top-border self STREAM line-drawer)) (when (member :left visible) (display-left-border self STREAM line-drawer)) (when (member :bottom visible) (display-bottom-border self STREAM line-drawer)) (when (member :zero-abcissa visible) (display-zero-abcissa self stream line-drawer)) (when (member :zero-ordinate visible) (display-zero-ordinate self stream line-drawer)) (force-output stream) )))) (defmethod DISPLAY-ZERO-ABCISSA ((self GRAPH-BORDER-MIXIN) STREAM line-drawer) (with-slots (tick-size ull vll uur xll xur x-tick-numbering) self (let ((dtick (x-tick-spacing self)) (dtick-size tick-size)) (multiple-value-bind (u0 v0) (xy-to-uv self 0 0) (declare (ignore u0)) (linear-axis ull v0 uur v0 xll xur dtick tick-size x-tick-numbering line-drawer #'(lambda (x y number) (declare (downward-function)) (axis-number-horizontal self STREAM (if (zerop number) (+ x (stream-character-width stream)) x) y (float-to-string number (x-digits self)) dtick-size)) nil))))) (defmethod DISPLAY-BOTTOM-BORDER ((self GRAPH-BORDER-MIXIN) STREAM line-drawer) (with-slots (tick-size ull vll uur xll xur x-tick-numbering) self (let ((dtick (x-tick-spacing self)) (dtick-size tick-size)) (linear-axis ull vll uur vll xll xur dtick tick-size x-tick-numbering line-drawer #'(lambda (x y number) (declare (downward-function)) (axis-number-horizontal self STREAM x y (float-to-string number (x-digits self)) dtick-size)) nil)))) (defmethod display-top-border ((self graph-border-mixin) STREAM line-drawer) (declare (ignore stream)) (with-slots (tick-size ull vll uur xll xur x-tick-numbering vur) self (let ((dtick (x-tick-spacing self))) (linear-axis ull vur uur vur xll xur dtick (- tick-size) nil line-drawer nil nil)))) (defmethod DISPLAY-ZERO-ORDINATE ((self GRAPH-BORDER-MIXIN) STREAM line-drawer) (with-slots (tick-size ull vll vur yll yur y-tick-numbering) self (let ((dtick (y-tick-spacing self)) (dtick-size (- tick-size))) (multiple-value-bind (u0 v0) (xy-to-uv self 0 0) (declare (ignore v0)) (linear-axis u0 vll u0 vur yll yur dtick dtick-size y-tick-numbering line-drawer #'(lambda (x y number) (declare (downward-function)) (axis-number-vertical self STREAM x (if (zerop number) (+ y (stream-line-height stream)) y) (float-to-string number (y-digits self)) dtick-size)) nil))))) (defmethod DISPLAY-LEFT-BORDER ((self GRAPH-BORDER-MIXIN) STREAM line-drawer) (with-slots (tick-size ull vll vur yll yur y-tick-numbering) self (let ((dtick (y-tick-spacing self)) (dtick-size (- tick-size))) (linear-axis ull vll ull vur yll yur dtick dtick-size y-tick-numbering line-drawer #'(lambda (x y number) (declare (downward-function)) (axis-number-vertical self STREAM x y (float-to-string number (y-digits self)) dtick-size)) nil)))) (defmethod DISPLAY-RIGHT-BORDER ((self GRAPH-BORDER-MIXIN) STREAM line-drawer) (declare (ignore stream)) (with-slots (tick-size ull vll vur yll yur y-tick-numbering uur) self (let ((dtick (y-tick-spacing self))) (linear-axis uur vll uur vur yll yur dtick tick-size nil line-drawer nil nil)))) (defmethod display :after ((self graph-border-mixin) STREAM) (display-border self STREAM) (display-labels self stream)) (defclass GRAPH-BORDER-OB-MIXIN (graph-border-mixin) ()) (defclass HORIZONTAL-Y-BORDER-MIXIN (graph-border-mixin) () (:documentation "Y axis labeling without rotation.")) ;;; KRA: This assumes the potential of having y-digits + 6 more charaters. ;;; this should really called something else so 6 isn't hard coded. ;;; KRA 27JUL93: The 6 is now a 4 (defmethod compute-margins :around ((self horizontal-y-border-mixin) STREAM) (multiple-value-bind (left right bottom top) (call-next-method) (with-slots (y-tick-numbering y-digits) self (let ((extra (* (if (and y-tick-numbering y-digits) (+ y-digits 4) 3) (stream-character-width stream)))) (values (+ extra left) right bottom top))))) (defclass VERTICAL-Y-BORDER-MIXIN (graph-border-mixin) () (:documentation "Y axis labels with rotated characters.")) (defmethod COMPUTE-MARGINS :around ((self VERTICAL-Y-BORDER-MIXIN) STREAM) (multiple-value-bind (left right bottom top) (call-next-method) (with-slots (y-tick-numbering) self (values (+ (* (if y-tick-numbering 3 2) (stream-line-height stream)) left) right bottom top)))) (defmethod AXIS-NUMBER-VERTICAL ((self VERTICAL-Y-BORDER-MIXIN) STREAM x y number-string the-tick-size) "Put centered number string at current u v position on a vertical axis." (declare (ignore the-tick-size)) (decf x (string-size stream nil number-string)) (decf y (values (truncate (- (stream-line-height stream) 2) 2))) (setq x (max 10 x)) (text self STREAM x y number-string :alu %draw)) (defmethod AXIS-LABEL-VERTICAL ((self VERTICAL-Y-BORDER-MIXIN) STREAM x y label the-tick-size) (with-slots (x-tick-numbering) self (multiple-value-bind (cu cv) (char-position-relative-to-uv self STREAM x y (- (* (length label) 0.5)) (if (< the-tick-size 0) 1.5 (if (null x-tick-numbering) -1.0 -2.0)) #.(/ pi 2)) (text self STREAM cu cv label :alu %draw :rotation #.(/ pi 2))))) (defclass GRAPH-GRID-MIXIN (basic-graph) ((show-grid :initform nil :initarg :show-grid) ; Show grid? (x-auto-grid :initform t :initarg :x-auto-grid) ; Auto-space grid? (x-dgrid :initform nil :initarg :x-dgrid :accessor x-dgrid) ; Spacing if not (y-auto-grid :initform t :initarg :y-auto-grid) (y-dgrid :initform nil :initarg :y-dgrid :accessor y-dgrid)) (:documentation "Simple Grid overlay.")) (defmethod (SETF X-DGRID) :after (ignore (self graph-grid-mixin)) (declare (ignore ignore)) (setf (slot-value self 'x-auto-grid) nil)) (defmethod (setf Y-DGRID) :after (ignore (self graph-grid-mixin)) (declare (ignore ignore)) (setf (slot-value self 'y-auto-grid) nil)) (defmethod alu-for-grid ((self graph-grid-mixin) stream) (declare (ignore stream)) ;; a dark gray. (make-color-rgb .4 .4 .4)) ;;; find U value of first grid line from left (or bottom) (defun FIND-UFIRST (usmall interval) (let ((ufirst (+ (down usmall interval) interval))) ;; "ufirst" wants to be 0 but isn't due to roundoff. So make it 0. (when (< (/ (abs ufirst) interval) 0.001) (setq ufirst 0.0)) (when (< (abs (- ufirst usmall)) (* 0.1 interval)) (setq ufirst (+ ufirst interval))) ufirst)) (defun LINEAR-GRAPH-GRID (the-graph ; Graph flavor to draw grid on. STREAM xmin ymin ; Coordinates of axis on x-y window xmax ymax ; from which to draw grid lines ; (dont confuse with graph outline) umin umax ; Axis units corres. to min and max points dgrid ; Grid spacing in axis units. grid-size ; length of grid-line (in pixels!!) ) ;; plot grid lines from a given axis ;; modified from linear-axis - without the axis, the numbers and the labels ;; grid lines instead of ticks. Assume grids are drawn at 0 or 90 degrees. (let ((cos (if (eq xmax xmin) 0 1)) (sin (if (eq ymax ymin) 0 1)) (usmall (min umin umax)) ; Minimum u value (ularge (max umin umax)) ; Maximum u value (alu (alu-for-grid the-graph stream))) (setq dgrid (abs dgrid)) ;; just like ticks, except tick size is the size of the other axis (loop for u from (find-ufirst usmall dgrid) below ularge by dgrid with u-grid = (values (round (* grid-size sin))) with v-grid = (values (round (* grid-size cos))) as xnew = (+ xmin (* (- u umin) cos)) ;(x-along u) as ynew = (+ ymin (* (- u umin) sin)) ;(y-along u) doing (multiple-value-bind (u1 v1) (xy-to-uv the-graph xnew ynew) (device-draw-line STREAM u1 v1 (+ u1 u-grid) (+ v1 v-grid) :alu alu))))) (defun auto-grid (xmin xmax) ;; use default values for ticks as defaults for grids (auto-tick xmin xmax)) (defmethod DISPLAY-HORIZONTAL-GRID ((self graph-grid-mixin) STREAM) (with-slots (yll yur y-dgrid uur ull xll y-auto-grid) self (let ((dgrid (cond (y-auto-grid (auto-grid yll yur)) (t y-dgrid))) (grid-size (- uur ull))) (linear-graph-grid self STREAM xll yll xll yur yll yur dgrid grid-size)))) (defmethod DISPLAY-VERTICAL-GRID ((self graph-grid-mixin) STREAM) (with-slots (xll xur x-dgrid vll vur yll x-auto-grid) self (let ((dgrid (cond (x-auto-grid (auto-grid xll xur)) (t x-dgrid))) (grid-size (- vur vll))) ; pixels (linear-graph-grid self STREAM xll yll xur yll xll xur dgrid grid-size)))) (defmethod DISPLAY-GRID ((self graph-grid-mixin) STREAM) (with-slots (show-grid) self (when show-grid (display-vertical-grid self STREAM) (display-horizontal-grid self STREAM)))) (defmethod DISPLAY :before ((self graph-grid-mixin) STREAM) (display-grid self STREAM)) (defclass GRAPH-GRID-OB-MIXIN (graph-grid-mixin) ()) (defclass GRAPH-DATASETS-MIXIN (graph-border-mixin basic-graph) ((datasets :initform nil :initarg :datasets :reader datasets) (hidden-datasets :initform nil :initarg :datasets :accessor hidden-datasets)) (:documentation "Allows several sets of data to be displayed on the graph, each in its own way.")) (defmethod (setf hidden-datasets) :after ((new t) (graph GRAPH-DATASETS-MIXIN)) (setf (auto-scale-needed graph) t)) (defmethod after-fasd-forms ((self graph-datasets-mixin)) (with-slots (datasets) self `((setf (datasets ',self) ',datasets)))) (defmethod (setf datasets) (new-datasets (self graph-datasets-mixin)) (with-slots (datasets) self (setq datasets nil) (dolist (dataset new-datasets) (add-dataset self dataset)))) (defmethod initialize-instance :after ((self graph-datasets-mixin) &key &allow-other-keys) (with-slots (datasets) self (when datasets (setf (datasets self) datasets)))) (defmethod display :after ((self graph-datasets-mixin) STREAM) (graph-display-data self STREAM)) (defmethod rescale :after ((self graph-datasets-mixin)) (dolist (d (datasets self)) (rescale d))) (defmethod add-dataset ((self graph-datasets-mixin) dataset) (with-slots (datasets) self (when (not (member dataset datasets :test #'eq)) (if datasets (setf (cdr (last datasets)) (cons dataset nil)) (setq datasets (cons dataset nil)))))) ;;; KRA: This used to take name-or-dataset, now it just takes dataset. (defmethod remove-dataset ((self graph-datasets-mixin) dataset) (with-slots (hidden-datasets datasets) self (setq datasets (delete dataset datasets :test #'eq)) (setq hidden-datasets (delete dataset hidden-datasets :test #'eq)))) (defmethod graph-display-data :around ((self graph-datasets-mixin) STREAM) (with-clipping-to-graph (self STREAM t) (call-next-method self STREAM))) (defmethod graph-display-data ((self graph-datasets-mixin) STREAM) (let ((hidden (hidden-datasets self))) (dolist (set (datasets self)) (or (member set hidden) (display-data set STREAM self))) (Force-output stream))) (defmethod x-label :around ((self graph-datasets-mixin)) (or (call-next-method) (some #'x-label (datasets self)))) (defmethod y-label :around ((self graph-datasets-mixin)) (or (call-next-method) (some #'y-label (datasets self)))) ;;;NLC08NOV90 - The g8>graph> version returns a string or nil. Whereas this ;;; returns a string or " ". (defmethod title :around ((self graph-datasets-mixin)) (let ((the-title nil)) (setq the-title (or (call-next-method) (some #'title (datasets self)) (name-string self))) (when the-title (unless (stringp the-title) (setq the-title (format nil "~a" the-title)))) (or the-title " "))) (defclass GRAPH-DATASETS-OB-MIXIN (graph-datasets-mixin) ()) (defclass GRAPH-AUTO-SCALE-MIXIN (graph-datasets-mixin basic-graph) ((auto-scale-needed :initform nil ; Data changed since last auto-scale? :initarg :auto-scale-needed :accessor auto-scale-needed) (auto-scale :initform :both ; Auto scale: (choose :x :y :both nil) :initarg :auto-scale :accessor auto-scale)) (:documentation "Allows the axes of a graph to be automatically scaled from its datasets.")) (defmethod add-dataset :after ((self graph-auto-scale-mixin) ignore) (declare (ignore ignore)) (with-slots (auto-scale-needed) self (setq auto-scale-needed t))) (defmethod remove-dataset :after ((self graph-auto-scale-mixin) ignore) (declare (ignore ignore)) (with-slots (auto-scale-needed) self (setq auto-scale-needed t))) ;;; Never auto-scale if user changes axis definitions. (defmethod (setf xur) :after ((new t) (self graph-auto-scale-mixin)) (setf (auto-scale self) (case (auto-scale self) (:both :y) (:x nil) (otherwise (auto-scale self))))) (defmethod (setf xll) :after ((new t) (self graph-auto-scale-mixin)) (setf (auto-scale self) (case (auto-scale self) (:both :y) (:x nil) (otherwise (auto-scale self))))) (defmethod (setf yll) :after ((new t) (self graph-auto-scale-mixin)) (setf (auto-scale self) (case (auto-scale self) (:both :x) (:y nil) (otherwise (auto-scale self))))) (defmethod (setf yur) :after ((new t) (self graph-auto-scale-mixin)) (setf (auto-scale self) (case (auto-scale self) (:both :x) (:y nil) (otherwise (auto-scale self))))) (defmethod display :before ((self graph-auto-scale-mixin) STREAM) (declare (ignore stream)) (with-slots (auto-scale auto-scale-needed) self (and auto-scale auto-scale-needed (do-auto-scale self)))) (defmethod (setf auto-scale) ((self graph-auto-scale-mixin) type) ;; Tells graph to do auto-scaling before graph is redisplayed. Type may be: ;; :x Auto scale the X axis. ;; :y Auto scale the Y axis. ;; :both Auto scale both axes ;; nil No auto scaling. (if (not (member type '(:x :y :both nil))) (error "~&(auto-scale graph-datasets-mixin): ~a is invalid option" type)) (with-slots (auto-scale auto-scale-needed) self (setq auto-scale-needed t) (setq auto-scale type) ;;;NLC08NOV90 - This should return the value of AUTO-SCALE. )) (defmethod graph-auto-scale-limits ((self graph-auto-scale-mixin)) "Returns limits needed to show all datasets." (with-slots (datasets hidden-datasets xll xur yll yur auto-scale) self (loop with xmin and xmax and ymin and ymax for dataset in datasets as limits = (unless (member dataset hidden-datasets) (auto-scale-limits dataset auto-scale xll xur yll yur)) when limits do (multiple-value-bind (left right bottom top) (apply #'values limits) (if (or (null xmin) (and left (< left xmin))) (setq xmin left)) (if (or (null xmax) (and right (> right xmax))) (setq xmax right)) (if (or (null ymin) (and bottom (< bottom ymin))) (setq ymin bottom)) (if (or (null ymax) (and top (> top ymax))) (setq ymax top))) finally (return (values (or xmin 0) (or xmax 1) (or ymin 0) (or ymax 1)))))) (defmethod do-auto-scale :around ((self graph-auto-scale-mixin)) ;; Only actually do auto scaling if you need to and can. (with-slots (auto-scale-needed datasets auto-scale) self (when (and auto-scale-needed datasets auto-scale) (call-next-method self) (rescale self) (setq auto-scale-needed nil)))) (defmethod do-auto-scale ((self graph-auto-scale-mixin)) "Actually do the auto scaling." (with-slots (auto-scale xll xur yll yur) self (multiple-value-bind (xmin xmax ymin ymax) (graph-auto-scale-limits self) (when (member auto-scale '(:x :both) :test #'eq) (if xmin (setq xll xmin)) (if xmax (setq xur xmax))) (when (member auto-scale '(:y :both) :test #'eq) (if ymin (setq yll ymin)) (if ymax (setq yur ymax)))) (when (= xll xur) ; Degenerate limits. set limits (decf xll 1.0) ; so data will be plotted. (incf xur 1.0)) (when (= yll yur) (decf yll 1.0) (incf yur 1.0)))) (defclass graph-limits-mixin (graph-auto-scale-mixin) () (:documentation "Allows a graph or a dataset to restrict the limits of the graph after auto scaling.")) (defmethod limit-specs ((self graph-limits-mixin)) "Returns a list of limits-specs that specify how the auto scaled limit of the LEFT, RIGHT, BOTTOM, and TOP (respectively) of the graph are restricted. A limit-spec can have the form: (min max) - (<= min limit max) (nil max) - (<= limit max) (min nil) - (<= min limit) number - (= limit number) nil - limit is unconstrained. If the list is (), the graph limits are unrestricted." ()) (defun limit-value (value limit) (cond ((null limit) value) ((listp limit) (when (first limit) (setq value (max (first limit) value))) (when (second limit) (setq value (min (second limit) value))) value) (t limit))) (defmethod graph-auto-scale-limits :around ((self graph-limits-mixin)) "Constrain graph edges to be within limits." (let ((the-limits (limit-specs self))) (multiple-value-bind (xmin xmax ymin ymax) (call-next-method) (when the-limits (multiple-value-bind (left right bottom top) (apply #'values the-limits) (when xmin (setq xmin (limit-value xmin left))) (when xmax (setq xmax (limit-value xmax right))) (when ymin (setq ymin (limit-value ymin bottom))) (when ymax (setq ymax (limit-value ymax top))))) (values xmin xmax ymin ymax)))) (defclass GRAPH-AUTO-SCALE-EXTENSIONS-MIXIN (graph-auto-scale-mixin) ((auto-scale-extensions ; list of (left right bottom top) % :initform (list 5.0 5.0 5.0 5.0) ;of X or Y axis to extend when auto :initarg :auto-scale-extensions) ;scaling. )) (defmethod graph-auto-scale-limits :around ((self graph-auto-scale-extensions-mixin)) "Extend limits needed by the data." (multiple-value-bind (xmin xmax ymin ymax) (call-next-method) (with-slots (auto-scale-extensions) self (when auto-scale-extensions (multiple-value-bind (left right bottom top) (apply #'values auto-scale-extensions) (when (and xmin xmax) (let ((range (abs (- xmax xmin)))) (when xmin (setq xmin (- xmin (* 0.01 left range)))) (when xmax (setq xmax (+ xmax (* 0.01 right range)))))) (when (and ymin ymax) (let ((range (abs (- ymax ymin)))) (when ymin (setq ymin (- ymin (* 0.01 bottom range)))) (when ymax (setq ymax (+ ymax (* 0.01 top range)))))))) (values xmin xmax ymin ymax)))) ;;; Clim 1.0 requires this be defined before any presentation type ;;; that depends on it. Hence moved here from present.lisp. (defclass presentable-graph-mixin () ((presentation :initform nil :accessor presentation) (tick :initform 0 :accessor redisplay-tick))) (defmacro with-temporary-cursor-position ((stream x y) &body body) `(with-output-truncation (,stream) (multiple-value-bind (.x. .y.) (stream-cursor-position* ,stream) (unwind-protect (progn (stream-set-cursor-position* ,stream ,x ,y) ,@body) (stream-set-cursor-position* ,stream .x. .y.))))) (defmethod display :around ((self presentable-graph-mixin) STREAM) "Display the graph as a presentation." ;; Lessons learned. ;; 1. Don't do ERASE type operations inside of with-output-as-presentation. ;; DISPLAY generates output; removing it should be done elsewhere. ;; 2. Enable output truncation to prevent unwanted viewport scrolling. ;; 3. Move the cursor to within the bounds of the graph, since cursor position ;; affects mouse-sensitive area (clim 0.9 bug). (with-output-truncation (stream) (setf (presentation self) (with-redisplayable-output (:stream stream :unique-id self :cache-value (redisplay-tick self) :cache-test #'=) (multiple-value-bind (x1 x2 y1 y2) (screen-outside self stream) (declare (ignore x2 y1)) (with-temporary-cursor-position (stream x1 y2) (with-output-as-presentation (:stream STREAM :single-box t :object self :type (graph-presentation-type self) :allow-sensitive-inferiors (graph-present-inferiors-p self)) (call-next-method self STREAM))))))) (force-output stream)) (defun incrementally-redisplayable-presentation (presentation) "Determine if a presentation is a part of an incremental redisplay." (if (not presentation) nil (or #-clim (typep (presentation-object presentation) 'dw::redisplay-piece) #+clim-2 (typep presentation 'standard-updating-output-record) (incrementally-redisplayable-presentation (presentation-superior presentation))))) (defmethod erase ((self presentable-graph-mixin) stream) (with-output-truncation (stream) (let ((presentation (presentation self))) (when presentation (erase-graphics-presentation presentation :stream stream) (setq presentation nil))))) (defmethod refresh :around ((self presentable-graph-mixin) stream) "By default, graphs refresh by erasing and then drawing. This breaks incremental redisplay, so watch out!" (let ((p (presentation self))) (cond ((and p (incrementally-redisplayable-presentation (presentation-superior p))) (incf (redisplay-tick self)) ;; Do nothing. Expect redisplay-frame-panes to do the rest. nil) (t (call-next-method self stream))))) (defmethod graph-presentation-type ((self presentable-graph-mixin)) 'graph) (defmethod graph-present-inferiors-p ((self presentable-graph-mixin)) 't) (defmethod present-self-p ((any t)) nil) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/present.lisp0000600000175000017500000003540710423413302023604 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: GRAPH -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :graph) (define-presentation-type graph () :description "a graph" :printer ((object stream) (format #+broken redisplayable-format stream "~A" (name object))) :parser ((stream) (read-char stream) (error "You must select a graph with the mouse."))) (define-presentation-type graph-data () :description "a graph dataset" :printer ((object stream) (format #+broken redisplayable-format stream "~A" (name object))) :parser ((stream) (read-char stream) (error "You must select a graph dataset with the mouse."))) (defun display-graph (graph &key (stream *standard-output*) (scroll-if-necessary nil) (width 500) (height 300)) "Displays graph with upper-left corner starting at current cursor position." #+clim (declare (ignore scroll-if-necessary)) #-clim (setq stream (si:follow-syn-stream stream)) (let ((*standard-output* stream)) (multiple-value-bind (x1 y1) (stream-cursor-position* stream) (setq width (truncate width)) (setq height (truncate height)) #-clim ; dw bug? (when scroll-if-necessary (multiple-value-bind (left top ignore bottom) (stream-viewport stream) (if (> (+ y1 height) bottom) (scl:send-if-handles stream :set-viewport-position left (+ top height))))) (stream-increment-cursor-position* stream 0 height) (multiple-value-bind (u v) (screen-to-uv stream x1 y1) (set-uv-outside graph STREAM u (+ u width) (- v height) v) (display graph stream))))) (defun save-postscript-graph (graph filename &key (width 400) (height 400)) (with-open-file (s filename :direction :output) #+(or clim-1 clim-2) (clim:with-output-to-postscript-stream (stream s) (display-graph graph :stream stream :width width :height height)))) (defun display-graphs (graphs &key (stream *standard-output*) (width 500) (height 500)) "Display a column of graphs" (let ((h (ROUND height (length graphs)))) (dolist (graph graphs) (display-graph graph :stream stream :height h :width width)))) (defun window-reverse-video (window &optional (fore :white) (back :black)) "Change the foreground/background colors of the window." #FEATURE-CASE (((not :clim) (progn ;; In Dynamic Windows, fore and back could be *real* colors rather than just ;; black/white, but in practice that seems to cause some problems. Try for ;; example drawing on a color background using :flip alu. (if (eq back :black) (setq fore tv:alu-andca back tv:alu-ior) (setq fore tv:alu-ior back tv:alu-andca)) (scl:send window :set-char-aluf fore) (scl:send window :set-erase-aluf back))) (:clim-0.9 (let ((medium (sheet-medium window)) (viewport (pane-viewport window))) (setq fore (alu-for-stream window fore) back (alu-for-stream window back)) (setf (medium-background medium) back (medium-foreground medium) fore) ;; This last part shouldn't be required, but it is because ;; of the wierd way that CLIM repaints a window. (setf (slot-value viewport 'windshield::background) back))) ((or :clim-1.0 :clim-2) (setf (medium-foreground window) (alu-for-stream window fore) (medium-background window) (alu-for-stream window back))))) (defun autoscale-graphs (graphs autoscale-type) "Let the graphs mutually decide what scaling limits to use. Use this when many different graphs should have the same scale." (when (> (length graphs) 1) (let* ((minx 1.0e+30) (maxx -1.0e+30) (miny minx) (maxy maxx)) (dolist (graph graphs) (setf (auto-scale graph) :both) ;; I can't tell if i have to do this, so i will: (do-auto-scale graph) (multiple-value-bind (x0 x1 y0 y1) (graph-auto-scale-limits graph) (when (member autoscale-type '(:x :both)) (setq minx (min minx x0)) (setq maxx (max maxx x1))) (when (member autoscale-type '(:y :both)) (setq miny (min miny y0)) (setq maxy (max maxy y1))))) (dolist (graph graphs) (when (member autoscale-type '(:x :both)) (setf (xll graph) minx) (setf (xur graph) maxx)) (when (member autoscale-type '(:y :both)) (setf (yll graph) miny) (setf (yur graph) maxy)) (setf (auto-scale graph) (case autoscale-type (:x :y) (:y :x) (:both nil) (otherwise :both))))) t)) (defun fill-window-with-graphs (graphs &key autoscale ; :X, :Y, :BOTH, or NIL (right-margin 0) (columns 1) (stream *standard-output*) (reverse-video (color-stream-p stream))) "Fill the window with columns graphs." ;; Ignore reverse-video in clim 2. Use X resources for that. #-clim-2 (when (and (color-stream-p stream) (not (eq reverse-video :own-color))) ;; CLX gets very unhappy if you try to reverse video on a screen that ;; doesn't support color (e.g. Sun 3/50). (if reverse-video (window-reverse-video stream :white :black) (window-reverse-video stream :black :white))) reverse-video ; quiet the compiler (if autoscale (autoscale-graphs graphs autoscale)) (window-clear stream) (when graphs (multiple-value-bind (w h) (stream-viewport-size stream) (decf w right-margin) (with-output-truncation (stream) ; don't wrap or scroll (if (= columns 1) (display-graphs graphs :stream stream :height h :width w) (let ((rows (values (ceiling (length graphs) columns)))) (dotimes (column columns) (let ((g nil)) (dotimes (row rows) (declare (ignore row)) (let ((temp (pop graphs))) (and temp (push temp g)))) (stream-set-cursor-position* stream (* (values (truncate w columns)) column) 0) (display-graphs (nreverse g) :stream stream :height h :width (values (truncate w columns))))))))))) ;;; ;;; Manipulating presentations ;;; (defun graph-under-presentation (presentation) (when (presentation-p presentation) (let ((object (presentation-object presentation))) (if (graph-p object) object (let ((superior (presentation-superior presentation))) (when superior (graph-under-presentation superior))))))) (defun dataset-under-presentation (presentation) (when (presentation-p presentation) (let ((object (presentation-object presentation))) (if (graph-data-p object) object (let ((superior (presentation-superior presentation))) (when superior (dataset-under-presentation superior))))))) (defun graph-under-annotation-under-presentation (presentation) (when (presentation-p presentation) (let ((object (presentation-object presentation))) (if (annotation-p object) (graph object) (let ((superior (presentation-superior presentation))) (when superior (graph-under-annotation-under-presentation superior))))))) (defun graph-under-mouse () (let ((stream (window-under-mouse))) (let ((p (presentation-under-pointer stream))) (when p (graph-under-presentation p))))) #+debug (defun object-under-mouse () (let ((stream (window-under-mouse))) (let ((p (presentation-under-pointer stream))) (when p (presentation-object p))))) ;;; ;;; CP commands for graphs and graph-data. ;;; (define-graph-command com-zoom-in ((graph 'graph) (WINDOW 'sheet)) "Zoom in on a selected rectangle of the graph." (zoom-in graph window)) (define-presentation-to-command-translator zoom-in (graph :command-name com-zoom-in :command-table :graph :gesture nil :documentation "Zoom In...") (object &key window) (list object window)) (define-graph-command com-zoom-out ((graph 'graph) (WINDOW 'sheet)) "Undo the results of the most recent zoom-in command." (zoom-out graph WINDOW)) (define-presentation-to-command-translator zoom-out (graph :command-name com-zoom-out :command-table :graph :tester ((object) (and (graph-p object) (zoom-stack object))) :gesture nil :documentation "Zoom Out") (object &key window) (list object window)) (define-graph-command com-slider-crosshairs ((graph 'graph) (WINDOW 'sheet)) "Display crosshairs on the graph at the current pointer position." (multiple-value-bind (x y) (uv-under-mouse window) (multiple-value-setq (x y) (uv-to-xy graph x y)) (multiple-value-setq (x y) (slider-interact graph WINDOW x y t)) (and x y (describe-point graph x y)))) (define-presentation-to-command-translator slider-crosshairs (graph :command-name com-slider-crosshairs :command-table :graph :gesture nil :documentation "Crosshairs") (object &key window) (list object window)) (define-graph-command com-redraw-graph ((graph 'graph) (window 'sheet)) "Erase and then redraw a graph." (refresh graph window)) (define-presentation-to-command-translator com-redraw-graph (graph :command-name com-redraw-graph :command-table :graph :gesture nil :documentation "Redraw Graph") (object &key window) (list object window)) (define-graph-command com-reveal-datasets ((graph 'graph) (WINDOW 'sheet)) "Reveals any data previously hidden by 'Remove Dataset'." (setf (hidden-datasets graph) nil) (refresh graph window)) (define-presentation-to-command-translator com-reveal-datasets (graph :command-name com-reveal-datasets :command-table :graph :gesture nil :documentation "Reveal Hidden Data" :tester ((object) (and (graph-p object) (not (null (hidden-datasets object)))))) (object &key window) (list object window)) (define-graph-command com-remove-dataset ((dataset 'graph-data) (window 'sheet) (presentation 't)) "Hides some graph data. Unhide it using 'Reveal Datasets.'" (let ((g (graph-under-presentation presentation))) (when g (push dataset (hidden-datasets g)) (refresh g window)))) (define-presentation-to-command-translator com-remove-dataset (graph-data :command-name com-remove-dataset :command-table :graph :gesture nil :documentation "Hide Data" :Tester ((object &key presentation) (declare (ignore object)) (or (graph-under-presentation presentation) (graph-under-annotation-under-presentation presentation)))) (object &key window presentation) (list object window presentation)) (defun draw-dash-sample (stream dash-pattern pretty-name selected-p) "Show what this dash pattern looks like." (declare (ignore pretty-name)) (multiple-value-bind (x y) (stream-cursor-position* stream) ;; (format stream "(~A ~A)" x y) (let ((width (* 3 (stream-character-width stream))) (height (* 6 (stream-line-height stream))) (thick (+ 2 %thickness)) (thin %thickness) (fudge 2)) (device-draw-line stream (+ x fudge) (+ y fudge) (- (+ x width) fudge) (- (+ y height) fudge) :thickness (if selected-p thick thin) :dash-pattern dash-pattern :transform nil :alu %draw) (draw-rectangle x (+ x width) (+ y height) y :stream stream :filled nil :alu (if selected-p %draw %erase)) (force-output stream)))) #-clim-2 (define-presentation-type dash-pattern () :description "a line dash pattern" :parser ((stream) (completing-from-suggestions (stream) (dotimes (i 7) (suggest (princ-to-string i) i)))) :printer ((object stream) (draw-dash-sample stream object nil nil)) :accept-values-displayer ((stream object query-identifier) (accept-values-choose-from-sequence stream *dash-pattern-alist* object query-identifier :drawer #'draw-dash-sample))) #+clim-2 (define-presentation-type-abbreviation dash-pattern () `((member ,@(let ((numbers nil)) (dotimes (i 7) (push i numbers)) (nreverse numbers))) :name-key princ-to-string :printer present-line-style :highlighter highlight-line-style)) #+clim-2 (defun present-line-style (object stream &key acceptably) (declare (ignore acceptably)) (if (stringp object) (setq object (read-from-string object))) (with-room-for-graphics (stream) (draw-dash-sample stream object (princ-to-string object) nil))) #+clim-2 (defun highlight-line-style (continuation object stream) (clim:surrounding-output-with-border (stream) (funcall continuation object stream))) ;;; Clim 0.9 seems to be missing a bunch of presentation types, ;;; probably because AND and OR are missing. Here we kludge up ;;; a solution until CLIM gets better. ;;; CLIM IS BETTER NOW (CLIM 2.0.BETA). LETS GET RID OF THIS. JPM. #+clim (define-presentation-type string-or-none () :description "a string or None" :printer ((object stream) (if (or (not object) (equal object "")) (write-string "None" stream) (present object 'string :stream stream))) :parser ((stream) (let ((string (accept 'string :stream stream :prompt nil :default nil))) (setq string (string-trim '(#\space) string)) (if (or (string= string "") (string-equal string "None")) (values nil 'string-or-none) (values string 'string-or-none))))) #-clim (define-presentation-type string-or-none () :abbreviation-for '(dw:null-or-type string)) #+clim (define-presentation-type number-or-none () :description "a number or None" :printer ((object stream) (if object (present object 'number :stream stream) (write-string "None" stream))) :parser ((stream) (let ((string (read-token stream))) (if (string-equal (string-trim '(#\space) string) "None") (values nil 'number-or-none) (let ((number (read-from-string string))) (if (numberp number) (values number 'number-or-none) (input-not-of-required-type stream string 'number-or-none))))))) #-clim (define-presentation-type number-or-none () :abbreviation-for '(dw:null-or-type number)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/package.lisp0000600000175000017500000000371610423413302023515 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: User -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package #-ansi-cl :user #+ansi-cl :common-lisp-user) (defpackage TOOL #+MCL (:shadow copy) (:use dwim-lisp)) (defpackage STATISTICS (:nicknames stat st) (:use dwim-lisp)) (defpackage GRAPH #-allegro (:nicknames gr) ; "GR" names something already. (:shadow variable) ; shouldn't be inherited but is #+MCL (:shadow copy) (:use dwim-lisp tool statistics)) (in-package :graph) (declaim (declaration downward-funarg downward-function array-register)) (dwim:make-command-table :graph) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/graph-classes.lisp0000644000175000017500000001645707750444412024713 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: GRAPH -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :graph) #|| ;;; Finally you have enough mixins loaded to build a useful graph, and graph-data. This is a useful graph data flavor to build on. However, for some applications it may be too powerful, and you may want to remove some of the mixins. ||# ;;; KRA: DONT DUMP DATA! If you want this, create your own graph-data flavor that does ;;; it. (defclass GRAPH-DATA ( raw-graph-data simple-data-statistics-mixin presentable-data-mixin graph-data-limits-mixin graph-data-auto-scale-mixin graph-data-color-mixin graph-data-symbology-mixin graph-data-add-datum-mixin graph-data-legend-mixin essential-graph-data-map-mixin basic-graph-data ) () (:default-initargs :auto-scale? t :symbologies '(:scatter)) (:documentation "This is a useful graph data flavor to build on. However, for some applications it may be too powerful, and you may want to remove some of the mixins.")) (defmethod graph-data-p ((object t)) nil) (defmethod graph-data-p ((object basic-graph-data)) t) (defclass timeseries-data (graph-data) () (:default-initargs :symbologies '(:line) :present-self-p nil :graph-present-inferiors-p nil) ;; By default, presentations are turned off. This reduces ;; drawing time because individual points are not mouse-sensitive. (:documentation "Base class for a common type of data.")) (defmethod missing-data-threshold ((self timeseries-data)) ;; Return a positive number when big gaps represent missing data. ;; This method determines how big such gaps have to be. ;; Display-data inhibits the line connecting the two adjacent datums. nil) (defmethod display-data ((self timeseries-data) STREAM graph) "Add optimization because you know the data is sorted (along time axis)." (with-alu (stream (alu self)) ;; Fixup the alu just once, since its the same for every datum. (let* ((displayer (datum-displayer self graph)) (thresh (let ((n (missing-data-threshold self))) (if n (float (abs n))))) (-thresh (and thresh (- thresh))) (H (sheet-inside-height stream)) (Trans (xy-to-uv-transform graph)) (start (float (xll graph))) (end (float (xur graph))) (last-datum nil) (last-x nil) (last-y nil) (last-in nil)) (declare (short-float start end) (fixnum H) (compiled-function trans displayer)) ;; Map over each datum between START and END plus the two bounding points ;; whose lines will get partially clipped. (flet ((draw-random-datum (d) (multiple-value-bind (x0 y0) (datum-position self d) (multiple-value-setq (x0 y0) (funcall trans x0 y0)) (funcall displayer stream x0 (- H y0) d))) (handle-missing-data-gap (x y) ;; Reset the displayer because we dont connect datums ;; that are this far apart. (funcall displayer stream nil nil nil) ;; Draw them as points so they aren't invisible. (let ((size 2)) (multiple-value-bind (frog dog) (xy-to-uv-distance graph (- last-x x) (- last-y y)) (when (or (> (abs frog) size) (> (abs dog) size)) (multiple-value-bind (u v) (xy-to-uv graph last-x last-y) (multiple-value-bind (sx sy) (uv-to-screen stream u v) (device-draw-circle stream (1- sx) (1+ sy) size :filled t :alu (alu self)))) (multiple-value-bind (u v) (xy-to-uv graph x y) (multiple-value-bind (sx sy) (uv-to-screen stream u v) (device-draw-circle stream (1- sx) (1+ sy) size :filled t :alu (alu self))))))))) (map-data self #'(lambda (datum) (declare (downward-function)) (multiple-value-bind (x y) (datum-position self datum) (or (floatp x) (setq x (float x))) (or (floatp y) (setq y (float y))) (when (and thresh last-x (>= (the short-float -thresh) (- (the short-float x) (the short-float last-x)) (the short-float thresh))) (handle-missing-data-gap x y)) (setq last-x x last-y y) (cond ((<= start (the short-float x) end) (multiple-value-setq (x y) (funcall trans x y)) (if (and last-datum (not last-in)) (draw-random-datum last-datum)) (funcall displayer stream x (- H y) datum) (setq last-in t)) (t (if (and last-datum last-in) (draw-random-datum datum)) (setq last-in nil))) (setq last-datum datum))) (data self)))))) (defmethod nearest-datum :around ((graph t) (dataset timeseries-data) u v) "If the data is really huge, it's better to be fast than to be exactly correct." (let ((raw-data (data dataset))) (if (and (arrayp raw-data) (> (length raw-data) 1000)) (let ((last-datum nil)) (map-data dataset #'(lambda (datum) (declare (downward-function)) (multiple-value-bind (x y) (datum-position dataset datum) (multiple-value-setq (x y) (xy-to-uv graph x y)) (when (>= x u) (return-from nearest-datum (or last-datum datum)))) (setq last-datum datum)) (data dataset)) last-datum) (call-next-method graph dataset u v)))) (defclass GRAPH ( presentable-graph-mixin graph-datasets-ob-mixin graph-legend-mixin graph-zoom-mixin graph-slider-interaction-mixin graph-slider-mixin graph-mouse-resolution-mixin graph-auto-scale-extensions-mixin graph-limits-mixin graph-auto-scale-mixin graph-grid-ob-mixin graph-grid-mixin ;; KRA 27JUL93: We don't know how to rotate charaters yet. ;; However see CLASS ANNOTATED-GRAPH and ;; ANNOTATED-HORIZONTAL-Y-BORDER-MIXIN-KLUDGE #-clim vertical-y-border-mixin #+clim horizontal-y-border-mixin graph-datasets-mixin graph-border-ob-mixin graph-border-mixin basic-graph named-object ) () (:documentation "A bordered graph with datasets, and sliders.")) (defmethod graph-p ((object t)) nil) (defmethod graph-p ((object basic-graph)) t) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/legend.lisp0000644000175000017500000002415107750444412023403 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: GRAPH -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :graph) ;;; GRAPH-DATA-LEGEND-MIXIN PROTOCOL: ;;; ;;; Allows a dataset to provide a legend item for graphs. [Legends can grow quite ;;; large when many datasets are involved, so a major goal is keeping them ;;; individually small.] ;;; ;;; DISPLAY-LEGEND-DATASET ;;; Display a legend item for this dataset. This has 2 parts: legend data and a ;;; legend-string. ;;; DISPLAY-LEGEND-STRING ;;; Displays the string part of the legend ;;; DISPLAY-LEGEND-DATUMS ;;; Displays the data part of the legend. To display legend datums, there is a ;;; subprotocol. A second dataset (called the legend dataset) is used to provide ;;; some data points (3) for display. If the data structure of the points in the ;;; legend dataset does not match the data structure of the "real" dataset, ;;; applications may need to specialize one of the following methods. ;;; LEGEND-DATASET ;;; Returns a (small) dataset containing the actual points to display. By ;;; default, a single dataset is instantiated, cached, and reused for every ;;; legend. The datums are lists of the form (X Y). ;;; LEGEND-DATUM-DISPLAYER ;;; Returns a function (like DATUM-DISPLAYER) that takes arguments X Y and ;;; DATUM and draws the datum in the proper symbologies. (defclass SHOW-LEGEND-MIXIN () ((show-legend :initform t :initarg :show-legend :accessor show-legend)) ; Show the legend? (:documentation "Provide a flag to show legend.")) (defmethod show-legend ((any t)) nil) ;;; KRA 27APR93: I removed this because it requires datasets to know what graph ;;; they are being drawn on, which seems unfair. Also, the hidden-dataset check ;;; is make explicitly in (method display (legend-annotation t)) #+OLD (defmethod show-legend :around ((dataset basic-graph-data)) (and (call-next-method) (not (member dataset (hidden-datasets (graph dataset)))))) ;;; needs some sort of symbology to work. (defclass GRAPH-DATA-LEGEND-MIXIN (basic-graph-datum-symbology-mixin show-legend-mixin) () (:documentation "Allows a dataset to provide a legend item for graphs.")) (defmethod legend-string ((self graph-data-legend-mixin)) (let ((name (name self))) (if name (string name)))) ; You may want to override this. (defvar *legend-symbology-width* 40 "Width of legend symbology, in pixels.") (defvar *legend-gap* 10 "Gap between legend symbology and string, in pixels.") (defvar *legend-style* '(:fix :roman :very-small)) ; the smallest clim font. (defmethod legend-size ((self graph-data-legend-mixin) stream &optional (style (parse-text-style *legend-style*))) "WIDTH and HEIGHT in pixels of area needed to display legend." (let ((legend (legend-string self))) (if legend (multiple-value-bind (width height) (string-size stream style "~A" legend) (values (+ *legend-symbology-width* *legend-gap* width) height)) (values 0 0)))) (defmethod make-legend-datum ((self graph-data-legend-mixin) x y &rest args) `(,x ,y ,@args)) (let ((legend-dataset-cache nil)) (defmethod LEGEND-DATA ((self graph-data-legend-mixin)) "Return a dataset to use to draw the points in the legend." (or legend-dataset-cache (let* ((x .5) (y .5) (dataset (make-instance 'graph-data :data (list (make-legend-datum self (- x) y) (make-legend-datum self 0 (- y)) (make-legend-datum self x y)) :bar-width x))) (setq legend-dataset-cache dataset) dataset)))) (defmethod legend-datum-displayer ((self graph-data-legend-mixin) graph) "Returns a function of arguments STREAM U V and DATUM that get applied to data from the legend dataset to display the data part of the legend." (datum-displayer self graph)) (defmethod dont-record-output-history ((self graph-data-legend-mixin)) nil) (defmethod legend-scale-limits ((self graph-data-legend-mixin) legend-data) "A sort of poor man's auto scaling for legend data." (let ((fudge .1)) (multiple-value-bind (left right bottom top) (apply #'values (auto-scale-limits legend-data :both nil nil nil nil)) (values (- left fudge) (+ right fudge) (- bottom fudge) (+ top fudge))))) (defmacro with-bar-width ((dataset width) &body body) `(let ((.old-width. (bar-width ,dataset))) (unwind-protect (progn (setf (bar-width ,dataset) ,width) ,@body) (setf (bar-width ,dataset) .old-width.)))) (defmethod display-legend-datums ((self graph-data-legend-mixin) STREAM graph left bottom width height) "Display some points in the legend area to show the current symbology settings." (let ((legend-data (legend-data self))) ;; The contract here is that the legend data knows about the data structure of ;; its datums, and the "real" data knows how to display them. This works OK as ;; long as the displayer doesn't assume too much about the datums coming from the ;; legend data. (with-bar-width (self (bar-width legend-data)) (multiple-value-bind (xll xur yll yur) (legend-scale-limits self legend-data) ;; Warp the graph to think its edges are the edges of the legend. (with-graph-coordinates (graph STREAM left (+ left width) bottom (+ bottom height) xll xur yll yur) (with-clipping-to-graph (graph STREAM t) (with-alu (stream (alu self)) ;; SELF provides the displayer, but LEGEND-DATA provides the mapper. (let ((displayer (legend-datum-displayer self graph))) (map-data legend-data #'(lambda (datum) (declare (downward-function)) (multiple-value-bind (x y) (datum-position legend-data datum) (multiple-value-setq (x y) (xy-to-uv graph x y)) (multiple-value-setq (x y) (uv-to-screen stream x y)) (funcall displayer stream x y datum))) (data legend-data)))))))))) (defmethod display-legend-string ((self graph-data-legend-mixin) STREAM graph u v) "Display the string part of the legend." (text graph STREAM u v (legend-string self))) (defmethod display-legend-dataset ((self t) STREAM graph left bottom width height) (declare (ignore stream graph left bottom width height)) ;; Default is a noop, so that graphs can assume everybody handles this method. nil) (defmethod display-legend-dataset ((self graph-data-legend-mixin) STREAM graph left bottom width height) "Display legend data and string in given UV region of graph." (declare (ignore width)) (when (show-legend self) (display-legend-datums self STREAM graph left bottom *legend-symbology-width* height) (display-legend-string self STREAM graph (+ left *legend-symbology-width* *legend-gap*) bottom))) ;;; GRAPH LEGENDS (defclass GRAPH-LEGEND-MIXIN (graph-datasets-mixin show-legend-mixin) (;; Distance from bottom of graph (px) (legend-offset :initform 0 :initarg :legend-offset :accessor legend-offset)) (:documentation "Provide graph with a Legend describing each dataset.")) (defmethod show-graph-legend ((any t)) nil) (defmethod show-graph-legend ((self graph-legend-mixin)) (and (show-legend self) (some #'show-legend (datasets self)))) (defmethod legend-size ((self graph-legend-mixin) the-stream &optional (style (parse-text-style *legend-style*))) "Width and height of graph legend area." (if (show-graph-legend self) (let ((x 0) (y 0)) (with-character-style (style the-stream) ; bind line height (dolist (d (datasets self)) (when (show-legend d) (multiple-value-bind (dx dy) ; assumes vertical orientation of legends (legend-size d the-stream style) (incf y dy) (setf x (max x dx)))))) (values x y)) (values 0 0))) (defmethod legend-compute-margins ((self graph-legend-mixin) STREAM left right bottom top) ;; Give the legend a chance to modify the margin area of the graph. (setf (legend-offset self) bottom) (multiple-value-bind (foo legh) (legend-size self stream) (declare (ignore foo)) (values left right (+ legh bottom) top))) (defmethod compute-margins :around ((self graph-legend-mixin) STREAM) (multiple-value-bind (left right bottom top) (call-next-method) (legend-compute-margins self stream left right bottom top))) (defmethod display-labels :after ((self graph-legend-mixin) STREAM) (when (show-graph-legend self) (display-legend self STREAM))) (defmethod display-legend ((self graph-legend-mixin) STREAM) "Display each legend dataset in the margin area." (multiple-value-bind (px foo py bar) (uv-inside self) (declare (ignore foo bar)) (setq py (- py (legend-offset self))) (with-character-style ((parse-text-style *legend-style*) stream) (let ((hidden (hidden-datasets self))) (dolist (dataset (datasets self)) (or (member dataset hidden) (multiple-value-bind (dx dy) (legend-size dataset stream) (display-legend-dataset dataset STREAM self px py dx dy) (setq py (- py dy))))))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/copy.lisp0000644000175000017500000002475007750444411023123 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: TOOL -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :tool) (eval-when (compile load eval) (export 'with-stack-list-copy 'tool) (export '(with-slot-copying copy-slot copy-set-slot copy-slots) 'tool) (export '(copyable-mixin copy-inner-class) 'tool) (export '(copy-self copy-inner) 'tool) (export '(copy-top-level copy) 'tool)) ;;; COPY-TOP-LEVEL: ;;; Copy objects with aribtrarily complex substructure. ;;; Objects are kept track of in a HashTable, so only make one copy of each. ;;; Things which are EQ in the original (i.e. objects, sublists, etc.) come out ;;; EQ in the corresponding places in the copy. (let ((copy-htable (make-hash-table))) (defmethod copy-top-level (ORIGINAL-THING) (clrhash COPY-HTABLE) (copy ORIGINAL-THING COPY-HTABLE))) (defgeneric copy (SELF COPY-HTABLE) (:documentation "Returns a fullfledged copy of SELF, set-up and ready to go.")) ;;;******************************************************************************** ;;; Some simple cases. ;;; Copies these objects are always eq to the original and have no ;;; internal structure. --> So just use the objects use themselves. ;;; (I.e. no need to worry about caching them). ;;;**********************************************************************NLC21NOV90 (defmethod copy ((ORINGINAL-SYMBOL symbol) COPY-HTABLE) (declare (ignore COPY-HTABLE)) ORINGINAL-SYMBOL) (defmethod copy ((ORINGINAL-NUMBER number) COPY-HTABLE) (declare (ignore COPY-HTABLE)) ORINGINAL-NUMBER) ;;;******************************************************************************** ;;; The hairier, default case. ;;; In general, ;;; 1] Objects can have internal structure (and, for instance, circular ;;; refrences) and/or ;;; 2] Copies are not eql to the original. ;;; ;;; The basic idea here is to only make one copy of the ORIGINAL-THING and ;;; store it in the HashTable for future use. In this way, the Copied ;;; Object has the same "eq-connectedness" that the original had. ;;;**********************************************************************NLC21NOV90 (defgeneric copy-self (SELF) (:documentation "Return a new, empty version of SELF")) (defgeneric copy-inner (SELF COPY-OBJECT COPY-HTABLE) (:documentation "Copy the relevant portions of SELF into COPY-OBJECT. OK if it calls COPY on sub-objects.")) (defgeneric copy-final (SELF) (:documentation "Last pass to make sure everything is in place.")) ;;;NLC21NOV90 - The call to COPY-INNER has to be inside this guy, else it ;;; will loose if ORIGINAL-THING contains a pointer to itself. ;;; ;;; So, in short there are three steps (if I've not already been Copied): ;;; 1] Create a new, empty copy (using COPY-SELF). ;;; 2] Shove it in the HashTable. ;;; 3] Setup its internal structure, as needed (using COPY-INNER). (defmethod copy (ORIGINAL-THING COPY-HTABLE) (multiple-value-bind (VALUE FOUND?) (gethash ORIGINAL-THING COPY-HTABLE) (or (and FOUND? VALUE) (let ((COPY-THING (copy-self ORIGINAL-THING))) (setf (gethash ORIGINAL-THING COPY-HTABLE) COPY-THING) (copy-inner ORIGINAL-THING COPY-THING COPY-HTABLE) (copy-final ORIGINAL-THING) COPY-THING)))) (defmethod copy-self (SELF) (error "Don't know how to copy ~A" self)) (defmethod copy-self ((ORIGINAL string)) (subseq ORIGINAL 0 (length ORIGINAL))) (defmethod copy-self ((original array)) (subseq original 0 (length original))) (defmethod copy-inner (SELF COPY-OBJECT COPY-HTABLE) "Default is to do nothing." (declare (ignore SELF COPY-OBJECT COPY-HTABLE)) nil) (defmethod copy-final ((self t)) "Default is to do nothing." nil) ;;;******************************************************************************** ;;; Lists ;;;**********************************************************************NLC14DEC90 ;;; The Old, Boring, Common-Lisp compatible Way. #-lispm (defmethod copy-self ((ORIGINAL-LIST list)) (and ORIGINAL-LIST (cons nil nil))) (defmethod copy-inner ((ORIGINAL-LIST list) COPY-LIST COPY-HTABLE) ;; This handles circular lists, but is slower and isn't cdr coded. (unless (null ORIGINAL-LIST) (setf (car COPY-LIST) (copy (car ORIGINAL-LIST) COPY-HTABLE)) (setf (cdr COPY-LIST) (copy (cdr ORIGINAL-LIST) COPY-HTABLE)))) ;;;NLC15DEC90 - New, improved copy on lists. ;;; This isn't as "elegant" as the above, but it preserves Cdr-coding. #+lispm (defmethod copy ((ORIGINAL-LIST list) COPY-HTABLE) (and ORIGINAL-LIST (multiple-value-bind (VALUE FOUND?) (gethash ORIGINAL-LIST COPY-HTABLE) (if FOUND? VALUE (let (COPY-LIST) (multiple-value-bind (NUM-CDR-NEXT LAST-CONTIG-PART) (si:contiguous-list-info ORIGINAL-LIST) (if (eq LAST-CONTIG-PART ORIGINAL-LIST) ;;; THIS CONS (AT LEAST) ISN'T CDR-CODED. ;;; SO MAKE A COPY OF THIS CONS, AND CACHE IT ;;; THEN COPY BOTH SIDES OF THE ITS SUB-TREE. (setf COPY-LIST (cons nil nil) (gethash ORIGINAL-LIST COPY-HTABLE) COPY-LIST (car COPY-LIST) (copy (car ORIGINAL-LIST) COPY-HTABLE) (cdr COPY-LIST) (copy (cdr ORIGINAL-LIST) COPY-HTABLE)) ;;; ELSE, THE LIST STARTS WITH (AT LEAST SOME) CDR-CODING. ;;; SO GET A CDR-CODED COPY OF THE SAME LENGTH ;;; AND CDR DOWN IT, COPYING EACH ELEMENT. ;;; NOTE THAT WE NEED TO CACHE EACH CONS. (prog ((COPY-PNTR (setq COPY-LIST (make-list (1+ NUM-CDR-NEXT))))) LOOP-TAG (setf (gethash ORIGINAL-LIST COPY-HTABLE) COPY-PNTR (car COPY-PNTR) (copy (car ORIGINAL-LIST) COPY-HTABLE)) (unless (eq LAST-CONTIG-PART ORIGINAL-LIST) (setq COPY-PNTR (cdr COPY-PNTR) ORIGINAL-LIST (cdr ORIGINAL-LIST)) (go LOOP-TAG)) ;;; FINALLY, MAKE SURE THE LAST CDR IS HANDLED RIGHT. (and (cdr ORIGINAL-LIST) (setf (cdr COPY-PNTR) (copy (cdr ORIGINAL-LIST) COPY-HTABLE)))))) COPY-LIST)))) ) ;;;******************************************************************************** ;;; Copy-able Class objects. ;;;**********************************************************************NLC21NOV90 (defclass copyable-mixin () () (:documentation "Provides method for doing COPY that creates a copy on an object. Each mixin should provide an COPY-INNER-CLASS method to copy its slots appropriately.")) (defmethod copy-self ((SELF copyable-mixin)) (make-instance (class-of SELF))) (defgeneric copy-inner-class (SELF COPY-OBJECT COPY-HTABLE) (:method-combination progn) (:documentation "Defined for each component class of an object with mixin COPYABLE-MIXIN. It should setup its slots as appropriate. This needs to be a seperate method (from COPY-INNER) because it has to be done with a PROGN Method-Combination.")) (defmethod copy-inner-class progn ((ORIGINAL-OBJECT copyable-mixin) COPY-LIST COPY-HTABLE) (declare (ignore COPY-LIST COPY-HTABLE)) nil) (defmethod copy-inner ((ORIGINAL-OBJECT copyable-mixin) COPY-LIST COPY-HTABLE) (copy-inner-class ORIGINAL-OBJECT COPY-LIST COPY-HTABLE)) (defgeneric copy-final-class (SELF) (:method-combination progn) (:documentation "Defined for each component class of an object with mixin COPYABLE-MIXIN. It should setup its slots as appropriate. This needs to be a seperate method (from COPY-FINAL) because it has to be done with a PROGN Method-Combination.")) (defmethod copy-final-class progn ((ORIGINAL-OBJECT copyable-mixin)) nil) (defmethod copy-final ((ORIGINAL-OBJECT copyable-mixin)) (copy-final-class ORIGINAL-OBJECT)) ;;;******************************************************************************** ;;; Things to make using COPY-INNER-CLASS easier. ;;;**********************************************************************NLC06DEC90 ;;; KRA: these 2 macros should be macrolet inside with-slot-copying. (defmacro copy-set-slot-1 (COPY-OBJECT SLOT-NAME VALUE) `(setf (slot-value ,COPY-OBJECT ,SLOT-NAME) ,VALUE)) (defmacro copy-slot-1 (COPY-OBJECT SLOT-NAME ORIGINAL-OBJECT COPY-HTABLE) `(copy-set-slot-1 ,COPY-OBJECT ,SLOT-NAME (copy (slot-value ,ORIGINAL-OBJECT ,SLOT-NAME) ,COPY-HTABLE))) ;;; (copy-set-slot (SLOT-NAME VALUE) ;;; Set the contents of SLOT-NAME in COPY-OBJECT to VALUE. ;;; (copy-slot (SLOT-NAME) ... ;;; Set the contents of SLOT-NAME in COPY-OBJECT to be a copyicate of the ;;; contents of the same slot in ORIGINAL-OBJECT. (defmacro with-slot-copying ((COPY-OBJECT COPY-HTABLE &optional (ORIGINAL-OBJECT 'SELF)) &body BODY) `(macrolet ((copy-slot (SLOT-NAME) `(copy-slot-1 ,',COPY-OBJECT ',SLOT-NAME ,',ORIGINAL-OBJECT ,',COPY-HTABLE)) (copy-set-slot (SLOT-NAME VALUE) `(copy-set-slot-1 ,',COPY-OBJECT ',SLOT-NAME ,VALUE))) (macrolet ((copy-slots (&rest SLOT-NAMES) `(progn ,@(loop for SLOT-NAME in SLOT-NAMES collecting `(copy-slot ,SLOT-NAME))))) ,@BODY))) ;;; ;;; ;;; (defmacro WITH-STACK-LIST-COPY ((variable list) &body body) "Like `((let ((,variable (copy-list ,list))) ,@body) except that the copy is consed on the stack." #+Genera `(let ((.n. (length ,list)) (.l. ,list)) (flet ((.body. (&rest ,variable) ,@body)) (sys:%start-function-call #'.body. return .n. nil) (do () ((null .l.)) (sys:%push (pop .l.))) (sys:%finish-function-call #'.body. return .n. nil))) #-Genera `(let ((,variable (copy-list ,list))) ,@body)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/moving-object.lisp0000644000175000017500000006072610104702554024707 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: GRAPH -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :graph) ;;; MOVING-OBJECT PROTOCOL: ;;; ;;; Provides an object with the ability to be dragged by the mouse. ;;; ;;; DRAG-OBJECT ;;; Object follows the mouse until a click is seen. This should work whether or ;;; not an object keeps track of its position on state variables, though if it does ;;; not, you must provide its initial position explicitly. ;;; DRAW-AT ;;; Draw the object at given stream coordinates. By default, this method calls ;;; SET-STREAM-POSITION to update the state variables of the object so that it ;;; knows its new position; then it calls DISPLAY, which takes only the object and ;;; the stream as arguments and therefore must rely on state variables for ;;; position. If this is very expensive, you may want to override DRAW-AT with ;;; code that makes some abbreviated drawing for the duration of mouse tracking. ;;; ERASE-AT ;;; Erase the object at given stream coordinates. (defclass moving-object (essential-display-mixin) () (:documentation "An abstract class that provides a displayable object with the ability to be dragged with the mouse.")) (defmethod stream-position ((self moving-object) stream) "Stream coordinates of object" (declare (ignore stream)) (values 0 0)) (defmethod set-stream-position ((self moving-object) stream newx newy) "Set stream coordinates of object." (declare (ignore stream newx newy)) nil) (defmethod draw-at ((self moving-object) stream x y) (set-stream-position self stream x y) (display self stream)) (defmethod erase-at ((self moving-object) stream x y) (declare (ignore x y)) ;; No need to set position here, it should be the same as the last draw. (erase self stream)) (defmethod drag-object ((self moving-object) STREAM &optional mouse-line initial-x initial-y) "Drag the object around by tracking the mouse." ;;(declare (values stream-x stream-y button)) (when (and initial-x initial-y) (stream-set-pointer-position* stream initial-x initial-y)) (multiple-value-setq (initial-x initial-y) ;; Do this even if stream-set-pointer-position* was just called, ;; because that doesn't always seem to work (clim 1.0). jpm. (stream-pointer-position* stream)) (let ((stream-x initial-x) (stream-y initial-y)) ;; Give object a chance to notice its initial position. (set-stream-position self stream stream-x stream-y) ;; Start tracking. (multiple-value-bind (button) (drag-icon stream #'(lambda (str) (declare (downward-function)) (draw-at self str stream-x stream-y)) #'(lambda (str) (declare (downward-function)) (erase-at self str stream-x stream-y)) #'(lambda (dx dy) (declare (downward-function)) (incf stream-x dx) (incf stream-y dy)) mouse-line) (values stream-x stream-y button)))) ;;; Need some stubs to put constraint checking. (defmethod before-motion ((object t) (stream t)) nil) (defmethod after-motion ((object t) (stream t)) nil) (defmethod move ((self moving-object) STREAM) "Interactively move the object." (unwind-protect (progn (erase self stream) (before-motion self stream) (drag-object self stream) (after-motion self stream)) (display self STREAM))) (define-graph-command com-move-object ((object 'invisible-object) (window 'sheet)) "Reposition an object, such as an annotation." (move object WINDOW)) (defclass moving-point (moving-object) ((x :initform 0 :initarg :x) (y :initform 0 :initarg :y)) (:documentation "A point that can be dragged with the mouse. A part of point annotations.")) (defmethod graph ((object moving-point)) (error "A missing method GRAPH was detected.")) (defmethod xy-position ((object moving-point)) (with-slots (x y) object (values x y))) (defmethod set-xy-position ((object moving-point) newx newy &optional constrain-p) (declare (ignore constrain-p)) (with-slots (x y) object (setq x newx y newy))) (defmethod uv-position ((object moving-point)) (multiple-value-bind (x y) (xy-position object) (xy-to-uv (graph object) x y))) (defmethod set-uv-position ((self moving-point) x y &optional constrain-p) (declare (ignore constrain-p)) (multiple-value-setq (x y) (uv-to-xy (graph self) x y)) (set-xy-position self x y)) (defmethod set-stream-position ((self moving-point) stream x y) (multiple-value-setq (x y) (screen-to-uv stream x y)) (multiple-value-setq (x y) (uv-to-xy (graph self) x y)) (set-xy-position self x y)) (defmethod stream-position ((self moving-point) stream) (multiple-value-bind (x y) (xy-position self) (multiple-value-setq (x y) (xy-to-uv (graph self) x y)) (uv-to-screen stream x y))) (defclass moving-polygon (moving-object) ((corners :initform nil :initarg :corners :accessor corners) (motion-corner :initform nil :accessor motion-corner)) (:documentation "A polygon whose corners can be moved around with the mouse. The instance variable MOTION-CORNER caches the chosen corner. A part of region annotations.")) (defmethod moveable-polygon-p ((object t)) nil) (defmethod moveable-polygon-p ((object moving-polygon)) t) (defmethod graph ((object moving-polygon)) (error "A missing method GRAPH was detected.")) (defmethod draw-xy-polygon ((object moving-polygon) stream &optional (alu %draw)) (let ((graph (graph object))) (with-clipping-to-graph (graph stream t) (map-polygon-edges #'(lambda (x1 y1 x2 y2) (declare (downward-function)) (multiple-value-setq (x1 y1) (xy-to-uv graph x1 y1)) (multiple-value-setq (x2 y2) (xy-to-uv graph x2 y2)) (device-draw-line stream x1 y1 x2 y2 :alu alu)) (corners object))))) (defmethod set-stream-position ((self moving-polygon) stream x y) (multiple-value-setq (x y) (screen-to-uv stream x y)) (multiple-value-setq (x y) (uv-to-xy (graph self) x y)) (let ((corner (motion-corner self))) (setf (first corner) x (second corner) y))) (defmethod stream-position ((self moving-polygon) stream) (let ((corner (motion-corner self))) (multiple-value-bind (u v) (xy-to-uv (graph self) (first corner) (second corner)) (uv-to-screen stream u v)))) (defun closest-point (u v mapper points) "Map over a set of points to find the nearest one." ;; Don't care about coordinate systems here, that is the caller's problem. ;;(declare (values closest-point closest-u closest-v)) (macrolet ((distance (a0 b0 a1 b1) ;; Omit the sqrt as an efficiency hack. `(let ((a (- ,a0 ,a1)) (b (- ,b0 ,b1))) (+ (* a a) (* b b))))) (let (d0 u0 v0 datum0) (funcall mapper #'(lambda (u1 v1 datum1) (declare (downward-function)) (let ((d (distance u1 v1 u v))) (when (or (not d0) (< d d0)) (setq d0 d u0 u1 v0 v1 datum0 datum1)))) points) (values datum0 u0 v0)))) (defmethod cache-moving-corner ((self moving-polygon) stream stream-x stream-y) (when (and stream-x stream-y) (setq stream-x (truncate stream-x)) (setq stream-y (truncate stream-y)) (let ((graph (graph self))) (multiple-value-bind (x y) (screen-to-uv stream stream-x stream-y) (setf (motion-corner self) (closest-point x y #'(lambda (function points) (declare (downward-function)) (dolist (point points) (let ((x0 (car point)) (y0 (cadr point))) (multiple-value-setq (x0 y0) (xy-to-uv graph x0 y0)) (funcall function x0 y0 point)))) (corners self))))))) (defclass basic-slider (moving-object tool::basic-object) ((bounds :initform nil :initarg :bounds) ;limit range by graph values (!NIL) (graphs :initform nil :accessor slider-graphs)) (:documentation "Base class for crosshairs and rectangle-sliders")) (defmethod BOUNDS ((self basic-slider)) (with-slots (bounds) self (multiple-value-bind (x-min y-min x-max y-max) (values-list bounds) (let ((graph (car (slider-graphs self)))) (when graph (multiple-value-bind (left right bottom top) (xy-inside graph) (setq x-min (or x-min left) y-min (or y-min bottom) x-max (or x-max right) y-max (or y-max top)))) (values x-min y-min x-max y-max))))) (defmethod SET-BOUNDS ((self basic-slider) &optional x-min y-min x-max y-max) ;; Values are in graph coordinates -- slider will be limited to this range, ;; in spite of the actual limits in the graph itself. (setf (slot-value self 'bounds) (when (or x-min x-max y-min y-max) `(,x-min ,y-min ,x-max ,y-max)))) (defmethod drag-object :before ((self basic-slider) stream &optional mouse-line x y) (declare (ignore stream mouse-line x y)) ;; recache boundaries. (set-bounds self) (multiple-value-bind (a b c d) (bounds self) (set-bounds self a b c d))) (defmethod redraw-overlapping-sliders ((self basic-slider) STREAM) ;; Not smart enough to really find overlapping ones; ;; instead returns all sliders which appear on same graph with this one. (dolist (slider (delete self (reduce #'union (loop for graph in (slider-graphs self) collect (sliders graph))))) (erase slider STREAM) (draw-without-labels slider STREAM))) (defmethod SLIDER-REMOVE-INTERNAL ((self basic-slider) STREAM) (dolist (g (slider-graphs self)) (remove-slider g STREAM self))) (defmethod KILL ((self basic-slider) STREAM) (erase self STREAM) (redraw-overlapping-sliders self STREAM) (slider-remove-internal self STREAM)) (defmethod set-stream-position ((self basic-slider) stream newx newy) "Set stream coordinates of object." (multiple-value-setq (newx newy) (screen-to-uv stream newx newy)) (multiple-value-setq (newx newy) (uv-to-xy (car (slider-graphs self)) newx newy)) (setf (slider-x self) newx (slider-y self) newy) (multiple-value-bind (left bottom right top) (bounds self) (constrain-position self left bottom right top)) t) (defmethod CONSTRAIN-POSITION ((self basic-slider) left bottom right top) "Try to constrain X,Y to be within the bounds." (multiple-value-bind (x1 y1) (constrain-point-in-rectangle (slider-x self) (slider-y self) left bottom right top) (setf (slider-x self) x1 (slider-y self) y1) (values x1 y1))) (defmethod TRACK ((self basic-slider) WINDOW &optional mouse-line) (multiple-value-bind (x y button) (drag-object self WINDOW mouse-line) (multiple-value-setq (x y) (screen-to-uv window x y)) (multiple-value-setq (x y) (uv-to-xy (car (slider-graphs self)) x y)) (values x y button))) (defclass crosshairs (basic-slider) ((x :initform 0.0 :accessor slider-x) ;current coordinates in first graph (y :initform 0.0 :accessor slider-y) (x-label :initform nil :accessor x-label) (y-label :initform nil :accessor y-label) (x? :initform t :accessor slider-x?) (y? :initform t :accessor slider-y?))) (defmethod stream-position ((self crosshairs) stream) (let ((x (slider-x self)) (y (slider-y self))) (multiple-value-setq (x y) (xy-to-uv (car (slider-graphs self)) x y)) (uv-to-screen stream x y))) (defmethod compute-labels ((self crosshairs)) (setf (x-label self) (float-to-string (slider-x self) *max-digits* (x-label self))) (setf (y-label self) (float-to-string (slider-y self) *max-digits* (y-label self)))) (defmethod set-stream-position :after ((self crosshairs) stream newx newy) (declare (ignore stream newx newy)) (compute-labels self)) (defmethod DRAW-CROSSHAIRS ((self crosshairs) stream graph x y alu) "Draw the horizontal and vertical lines but no labels" (multiple-value-bind (ull uur vll vur) (uv-inside graph) (multiple-value-setq (x y) (xy-to-uv graph x y)) (multiple-value-setq (ull vll) (uv-to-screen stream ull vll)) (multiple-value-setq (uur vur) (uv-to-screen stream uur vur)) (multiple-value-setq (x y) (uv-to-screen stream x y)) (when (slider-y? self) (draw-line x vll x vur :stream stream :alu alu)) (when (slider-x? self) (draw-line ull y uur y :stream stream :alu alu)))) (defmethod DRAW-SLIDER-X-LABEL ((self crosshairs) graph STREAM alu value text) (or text (setq text (float-to-string value (x-digits graph)))) (multiple-value-bind (u v) (xy-to-uv graph value (yll graph)) (multiple-value-setq (u v) (uv-to-screen stream u v)) (incf v (* 2 (stream-line-height stream))) (draw-string text u v :stream stream :alu alu))) (defmethod DRAW-SLIDER-Y-LABEL ((self crosshairs) graph STREAM alu value text) (or text (setq text (float-to-string value (y-digits graph)))) (multiple-value-bind (u v) (xy-to-uv graph (xll graph) value) (multiple-value-setq (u v) (uv-to-screen stream u v)) (setq u (max 0 (- u (string-size stream nil text)))) (draw-string text u v :stream stream :alu alu))) #-clim (defmethod DRAW-SLIDER-X-LABEL :around ((self crosshairs) graph STREAM alu value text) ;; Without without-interrupts, writing the text was so slow that ;; that the sliding aspect of the slider was destroyed. ;; This was a crude hammer but it helped a lot. NLC. ;; ;; But without-interrupts loses in CLIM XLIB. Draw-text* ultimately tries to ;; get some kind of lock (xlib:draw-glyph) and complains that scheduling was ;; inhibited. JPM. (without-interrupts (call-next-method self graph stream alu value text))) #-clim (defmethod DRAW-SLIDER-Y-LABEL :around ((self crosshairs) graph STREAM alu value text) ;; ditto (without-interrupts (call-next-method self graph stream alu value text))) (defmethod DRAW-INTERNAL ((self crosshairs) STREAM x y &optional (labels? t)) ;; Only draw labels on the "head" graph -- seemed to take to long otherwise (RBR) (with-slots (graphs) self (let ((alu %flip)) (dolist (g graphs) (draw-crosshairs self stream g x y alu)) (when labels? (let ((graph (car graphs))) (when (slider-x? self) (draw-slider-x-label self graph STREAM alu x (x-label self))) (when (slider-y? self) (draw-slider-y-label self graph STREAM alu y (y-label self)))))))) (defmethod DISPLAY ((self crosshairs) STREAM) (draw-internal self STREAM (slider-x self) (slider-y self) t)) (defmethod DRAW-WITHOUT-LABELS ((self crosshairs) STREAM) (draw-internal self STREAM (slider-x self) (slider-y self) nil)) (defmethod ERASE ((self crosshairs) STREAM) (draw-internal self STREAM (slider-x self) (slider-y self) t)) (defclass rectangle-slider (basic-slider) ((dx :initform 0 :initarg :dx :accessor rectangle-slider-dx) (dy :initform 0 :initarg :dx :accessor rectangle-slider-dy) (du :initform 0 :initarg :du :accessor rectangle-slider-du) (dv :initform 0 :initarg :dv :accessor rectangle-slider-dv) (slider1 :initform (make-instance 'crosshairs) :accessor rectangle-slider-1) (slider2 :initform (make-instance 'crosshairs) :accessor rectangle-slider-2)) (:documentation "Two cross hairs that can move as a unit.")) (defmethod display ((self rectangle-slider) stream) (display (rectangle-slider-1 self) stream) (display (rectangle-slider-2 self) stream)) (defmethod erase ((self rectangle-slider) stream) (erase (rectangle-slider-1 self) stream) (erase (rectangle-slider-2 self) stream)) (defmethod stream-position ((self rectangle-slider) stream) (stream-position (rectangle-slider-1 self) stream)) (defmethod set-stream-position ((self rectangle-slider) stream newx newy) (set-stream-position (rectangle-slider-1 self) stream newx newy) (set-stream-position (rectangle-slider-2 self) stream (+ newx (rectangle-slider-du self)) (+ newy (rectangle-slider-dv self))) (multiple-value-bind (left bottom right top) (bounds self) (constrain-position self left bottom right top))) (defmethod CONSTRAIN-POSITION ((self rectangle-slider) left bottom right top) ;; Try to constrain X,Y, DX, and DY to be within the bounds. (with-slots (slider1 slider2 dx dy) self (cond ((and (minusp dx) (minusp dy)) (constrain-position slider1 (- left dx) (- bottom dy) right top) (constrain-position slider2 left bottom (+ right dx) (+ top dy))) ((and (plusp dx) (plusp dy)) (constrain-position slider1 left bottom (- right dx) (- top dy)) (constrain-position slider2 (+ left dx) (+ bottom dy) right top)) ((and (plusp dx) (minusp dy)) (constrain-position slider1 left (- bottom dy) (- right dx) top) (constrain-position slider2 (+ left dx) bottom right (+ top dy))) (t (constrain-position slider1 (- left dx) bottom right (- top dy)) (constrain-position slider2 left (+ bottom dy) (+ right dx) top))))) (defmethod set-rectangle-size ((self rectangle-slider) stream) (with-slots (dx dy du dv slider1 slider2) self (let ((x1 (slider-x slider1)) (y1 (slider-y slider1)) (x2 (slider-x slider2)) (y2 (slider-y slider2))) (setq dx (- x2 x1) dy (- y2 y1)) (multiple-value-setq (x1 y1) (xy-to-uv (car (slider-graphs self)) x1 y1)) (multiple-value-setq (x2 y2) (xy-to-uv (car (slider-graphs self)) x2 y2)) (multiple-value-setq (x1 y1) (uv-to-screen stream x1 y1)) (multiple-value-setq (x2 y2) (uv-to-screen stream x2 y2)) (setq du (- x2 x1) dv (- y2 y1))))) (defmethod slider-graphs ((self rectangle-slider)) (slider-graphs (rectangle-slider-1 self))) (defmethod (setf slider-graphs) (new (self rectangle-slider)) (setf (slider-graphs (rectangle-slider-1 self)) new) (setf (slider-graphs (rectangle-slider-2 self)) new)) (defmethod TRACK :around ((self rectangle-slider) WINDOW &optional mouse-line) window mouse-line (multiple-value-bind (a b c) (call-next-method) (values a b c (slider-x (rectangle-slider-2 self)) (slider-y (rectangle-slider-2 self))))) (defvar *slider* (make-instance 'crosshairs)) (defvar *rectangle-slider* (make-instance 'rectangle-slider)) (defun define-point (graph stream &key (x 0) (y 0) (slider *slider*)) "Use the slider to choose a point off the graph." ;;(declare (values x y)) (setf (slider-graphs slider) (graphs-for-slider graph)) (setf (slider-x slider) x (slider-y slider) y) (multiple-value-bind (x1 y1 button) (track slider STREAM "L,R:Fix point, M:Abort.") (button-case button :left (values x1 y1) :right (values x1 y1) :middle nil))) (defun define-region (graph stream &key (x1 0) (y1 0) (x2 0) (y2 0) (slider *rectangle-slider*)) "Use the slider to choose two points defining the edges of a box." ;;(declare (values (x1 y1 x2 y2))) (let ((slider1 (rectangle-slider-1 slider)) (slider2 (rectangle-slider-2 slider))) (setf (slider-graphs slider) (graphs-for-slider graph)) (setf (slider-x slider1) x1 (slider-y slider1) y1) (setf (slider-x slider2) x2 (slider-y slider2) y2) (let ((button nil) (string1 "L,R:Fix and continue, M:Abort") (string2 "L:Fix other edge and finish, M:Abort, R:Fix other edge and continue.") (string3 "L,R:Fix and finish, M:Abort.")) (when (catch 'abort (labels ((DRAG-THE-BOX () (set-rectangle-size slider stream) (multiple-value-setq (x1 y1 button x2 y2) (track slider STREAM string3)) (button-case button :middle (throw 'abort nil))) (CHOOSE-THE-SECOND-POINT () (multiple-value-setq (x2 y2 button) (with-output-recording-disabled (stream) (unwind-protect (progn (display slider1 stream) (track slider2 stream string2)) (erase slider1 stream)))) (button-case button :middle (throw 'abort nil) :left t :right (drag-the-box))) (CHOOSE-THE-FIRST-POINT () (multiple-value-setq (x1 y1 button) (track slider1 STREAM string1)) (button-case button :right (choose-the-second-point) :middle (throw 'abort nil) :left (choose-the-second-point)))) (choose-the-first-point) t)) (values x1 y1 x2 y2))))) (defclass graph-slider-mixin (graph-mouse-resolution-mixin basic-graph) ((sliders :initform nil :initarg :sliders :accessor sliders) ;List of sliders on this graph. ;; X and y labeling resolution; Uses dx/dy-mouse if !given. (dx-slider :initform nil :initarg :dx-slider) (dy-slider :initform nil :initarg :dy-slider)) ) (defmethod after-fasd ((self graph-slider-mixin)) `(set-sliders ',self ',(sliders self))) (defmethod add-slider ((self graph-slider-mixin) (STREAM t) slider) (pushnew slider (sliders self))) (defmethod REMOVE-SLIDER ((self graph-slider-mixin) (STREAM t) slider) (setf (sliders self) (delete slider (sliders self)))) (defmethod REMOVE-ALL-SLIDERS ((self graph-slider-mixin) STREAM) (dolist (s (sliders self)) (remove-slider self STREAM s))) (defmethod KILL-ALL-SLIDERS ((self graph-slider-mixin) STREAM) (dolist (s (sliders self)) (kill s STREAM) (remove-slider self STREAM s))) ;;; Erase and draw sliders along with the graph itself. (defmethod ERASE :before ((self graph-slider-mixin) STREAM) (dolist (s (sliders self)) (erase s STREAM))) ;;; !KRA: This has a bug because slider may not be drawn correctly if ;;; on multiple windows after a :REFRESH, say. (defmethod display :after ((self graph-slider-mixin) STREAM) (dolist (s (sliders self)) (display s STREAM))) (defclass GRAPH-SLIDER-INTERACTION-MIXIN (graph-slider-mixin graph-mouse-resolution-mixin basic-graph) () (:documentation "Provides graphs with a protocol for interacting with a slider through the SLIDER-INTERACT and SLIDER-SETUP methods.")) (defmethod graphs-for-slider ((self graph-slider-interaction-mixin)) (list self)) (defmethod slider-setup ((self graph-slider-interaction-mixin) slider) ;; Set up a slider any way you like. (setf (slider-graphs slider) (graphs-for-slider self))) (defmethod slider-interact ((self graph-slider-interaction-mixin) STREAM x y &optional (point-p nil)) ;; Interact with a slider, initially at (x y) to define a point if ;; POINT-P or a region if (NOT POINT-P). ;; Returns values X1 Y1 X2 Y2. (if point-p (define-point self STREAM :x x :y y) (define-region self STREAM :x1 x :y1 y :x2 x :y2 y))) (defmethod describe-point ((self graph-slider-interaction-mixin) x y) ;; No op. You may want to redefine this. (declare (ignore x y)) nil) (defclass GRAPH-ZOOM-MIXIN (graph-slider-interaction-mixin basic-graph) ((zoom-stack :initform () :accessor zoom-stack :initarg :zoom-stack)) (:documentation "Lets you ZOOM in on an area of the graph.")) (defmethod do-auto-scale :around ((self graph-zoom-mixin)) ;; Don't auto-scale when zoomed in. (unless (zoom-stack self) (call-next-method))) (defmethod choose-xy-rectangle (graph stream) (multiple-value-bind (left top right bottom button) (device-specify-rectangle stream) (when left (multiple-value-setq (left top) (uv-to-xy graph left top)) (multiple-value-setq (right bottom) (uv-to-xy graph right bottom)) (values (min left right) (max top bottom) (max left right) (min top bottom) button)))) (defmethod zoom-in ((self graph-zoom-mixin) STREAM) (with-slots (xll xur yll yur zoom-stack) self (multiple-value-bind (x1 y1 x2 y2) (choose-xy-rectangle self stream) (when (and x1 y1 x2 y2 (not (= x1 x2)) (not (= y1 y2))) (push (list xll xur yll yur) zoom-stack) (if (< x2 x1) (psetq x1 x2 x2 x1)) (if (< y2 y1) (psetq y1 y2 y2 y1)) (set-xy-inside self STREAM x1 x2 y1 y2) (refresh self STREAM))))) (defmethod zoom-out ((self graph-zoom-mixin) STREAM) (with-slots (zoom-stack) self (when zoom-stack (apply #'set-xy-inside self STREAM (pop zoom-stack))) (refresh self STREAM))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/duplicate-methods.lisp0000644000175000017500000001244607750444412025564 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: GRAPH -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :graph) (duplicator-methods (raw-graph-data) ((duplicate-slots data) )) (duplicator-methods (accessor-datum-mixin) ((duplicate-slots x-accessor y-accessor))) (duplicator-methods (graph-data-x-offset-mixin) ((duplicate-slots x-offset))) (duplicator-methods (graph-data-y-offset-mixin) ((duplicate-slots y-offset))) (duplicator-methods (graph-data-xy-offset-mixin) ((duplicate-slots x-offset y-offset))) (duplicator-methods (graph-data-dither-mixin) ((duplicate-slots x-dither y-dither))) (duplicator-methods (graphics-style-mixin) ((duplicate-set pattern pattern) (duplicate-slots thickness line-end-shape))) (duplicator-methods (basic-graph-datum-symbology-mixin) ((duplicate-slots symbologies))) (duplicator-methods (graph-datum-line-symbology-mixin) ((duplicate-slots line-style))) (duplicator-methods (graph-datum-bar-symbology-mixin) ((duplicate-slots bar-width))) (duplicator-methods (graph-datum-scatter-symbology-mixin) ((duplicate-slots data-symbol symbol-height))) (duplicator-methods (graph-data-color-mixin) ((duplicate-slots color))) (duplicator-methods (graph-data-auto-scale-mixin) ((duplicate-slots auto-scale?))) ;;; Copying or dumping the alu is unnecessary if dataset has a COLOR that ;;; determines the ALU so provide your own versions of these if you need to. (defmethod dump-forms append ((self basic-graph-data)) (with-slot-dumping (self) (dump-slots graph))) ;;;****************************************************************** ;;; From BASIC-GRAPH.lisp. ;;;****************************************************************** (duplicator-methods (uv-box) ((duplicate-slots ull vll uur vur))) (duplicator-methods (xy-box) ((duplicate-slots xll yll xur yur))) (duplicator-methods (basic-graph-coordinates-mixin) ((duplicate-slots x-u-scale y-v-scale))) (defmethod copy-inner-class progn ((SELF essential-display-mixin) COPY-OBJECT COPY-HTABLE) (with-slot-copying (COPY-OBJECT COPY-HTABLE self) (copy-slots DISPLAYED?))) (defmethod dump-forms append ((SELF essential-display-mixin)) (with-slot-dumping (self) (dump-set-slot DISPLAYED? nil))) (duplicator-methods (basic-graph) ((duplicate-slots edge-spec))) (duplicator-methods (named-object) ((duplicate-slots name))) (defmethod copy-inner-class progn ((SELF equation-data) COPY-OBJECT COPY-HTABLE) (with-slots (DATA-FUNCTION) SELF (with-slot-copying (COPY-OBJECT COPY-HTABLE self) (copy-slots VARIABLE MIN MAX INCREMENT PARAMETERS EQUATION) (copy-set-slot DATA-FUNCTION DATA-FUNCTION)))) (defmethod dump-forms append ((SELF equation-data)) (with-slot-dumping (self) (dump-slots VARIABLE MIN MAX INCREMENT PARAMETERS EQUATION))) (defmethod copy-inner-class progn ((SELF histogram-data) COPY-OBJECT COPY-HTABLE) (with-slot-copying (COPY-OBJECT COPY-HTABLE self) (copy-slots MIN MAX BIN-COUNT BIN-SIZE BINS))) (defmethod dump-forms append ((SELF histogram-data)) (with-slot-dumping (self) (dump-slots MIN MAX BIN-COUNT BIN-SIZE))) (duplicator-methods (line-mixin) ((duplicate-slots line-a line-b line-c))) (duplicator-methods (graph-mouse-resolution-mixin) ((duplicate-slots dx-mouse dy-mouse))) (duplicator-methods (graph-border-mixin) ((duplicate-slots show-border tick-size title x-label x-digits x-auto-tick x-dtick y-label y-digits y-auto-tick y-dtick))) (duplicator-methods (graph-grid-mixin) ((duplicate-slots show-grid x-auto-grid x-dgrid y-auto-grid y-dgrid))) (duplicator-methods (graph-datasets-mixin) ((duplicate-slots datasets))) (duplicator-methods (graph-auto-scale-mixin) ((duplicate-slots auto-scale-needed auto-scale))) (duplicator-methods (graph-auto-scale-extensions-mixin) ((duplicate-slots auto-scale-extensions))) (duplicator-methods (show-legend-mixin) ((duplicate-slots show-legend))) (duplicator-methods (basic-slider) ((duplicate-slots graphs bounds x-increment y-increment x y dx dy lastx lasty x? y?))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/annotations.lisp0000644000175000017500000010235507750444411024504 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: GRAPH -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :graph) ;;;An annotation is an object that can be visualized on a graph. Usually, it is a ;;; bit of text, but sometimes annotations are arbitrary graphical shapes like ;;; polygons, lines, etc. ;;; ;;;Annotations can be moved, edited, and deleted using the mouse, much like ;;; MacIntosh MacDraw object. Character styles can also be controlled. ;;; (defclass basic-annotation (moving-point) ((graph :initform nil :initarg :graph :accessor graph) (alu :initform %draw :initarg :alu :accessor alu) ;; We could probably have a color-mixin since we have an alu variable. (style :initform nil :initarg :style :accessor style) (PRESENTATION :initform nil :initarg :presentation :accessor presentation) (editable :initform nil :initarg :editable :accessor editable)) (:documentation "The essential characteristics of an annotation.")) (defmethod annotation-text ((any basic-annotation)) (princ-to-string any)) (defmethod annotation-p ((any t)) nil) (defmethod annotation-p ((annotation basic-annotation)) t) (defmethod editable ((object t)) nil) #+clim-0.9 (defun clim-update-sensitivity (stream) "Fix major CLIM sins" ;; Try living without this function once clim 2.0 arrives. 10 apr 91 jpm. (let ((root (ci::output-recording-stream-output-record stream))) ;; Scroll bars are wrong, so update them. (ci::update-region stream (bounding-rectangle-width root) (bounding-rectangle-height root)) ;; Annotations get inserted out of order, so sort the records. (ci::sort-coordinate-sorted-set (slot-value root 'ci::coordinate-sorted-set)))) (defmethod annotation-presentation-type ((self basic-annotation)) 'annotation) (defmethod annotation-single-box ((self basic-annotation)) nil) (defmethod display :around ((self basic-annotation) stream) "Set up the display environment and capture output as a presentation." ;; with-every-trick-in-the-book ... (with-slots (graph style) self ;; Check to see if I'm clipped. (when (setf (displayed? self) (display-p self)) ;; Okay, try to display, but let the graph clip me too. (with-clipping-to-graph (graph stream nil) ;; Move the cursor to shadow clim bugs. (with-character-style ((or style (stream-current-text-style stream)) stream) (multiple-value-bind (sl st) (uv-for-display self) (multiple-value-setq (sl st) (uv-to-screen stream sl st)) (with-temporary-cursor-position (stream sl st) (setf (presentation self) ;; Capture the output of all the display methods in one big ;; presentation, mainly so we can erase it later. (with-output-as-presentation (:stream stream :object self :single-box (annotation-single-box self) :type (annotation-presentation-type self)) (call-next-method self stream))))))) #+clim-0.9 (clim-update-sensitivity stream)))) (defmethod display-p ((self basic-annotation)) t) (defmethod width ((self basic-annotation)) 0) (defmethod height ((self basic-annotation)) 0) (defmethod uv-for-display ((self basic-annotation)) "Get the uv position of (left,top), but constrain it within the graph" (multiple-value-bind (l r b to) (uv-outside (graph self)) (decf r (width self)) (incf b (height self)) (multiple-value-bind (left top) (uv-position self) (multiple-value-setq (left top) (constrain-point-in-rectangle left top l b r to)) (values (truncate left) (truncate top))))) (defmethod erase ((self basic-annotation) STREAM) "Erase an annotation by erasing the underlying presentation." (with-slots (presentation) self (when presentation (erase-graphics-presentation presentation :stream STREAM) (setq presentation nil) #+clim-0.9 (clim-update-sensitivity stream)))) (defmethod kill ((self basic-annotation) STREAM) "Erase the annotation and resign from the graph." (with-slots (graph) self (erase self STREAM) (setf (annotations graph) (remove self (annotations graph))))) (defmethod draw-at ((self basic-annotation) stream x y) (set-stream-position self stream x y) (mark self stream)) (defmethod erase-at ((self basic-annotation) stream x y) (declare (ignore x y)) (unmark self stream)) (defmethod unmark ((self basic-annotation) stream) "Undraw the box highlighting the annotation." ;; You cant just erase the presentation because we don't take time ;; to make them during mouse tracking. If we use the :flip alu, then we can just ;; mark it again. (mark self stream)) (defmethod move :around ((self basic-annotation) stream) "Clip to graph-outside edges while moving the annotation." (with-clipping-to-graph ((graph self) stream nil) (call-next-method self stream))) ;; Stubs to hang methods upon. (defmethod mark ((self basic-annotation) stream) stream) (defmethod display ((self basic-annotation) stream) stream) (defmethod figure-geometry ((self basic-annotation) stream) stream) (defmethod recompute-annotation-appearance ((self basic-annotation) stream) stream) ;;;ANNOTATION ;;; ;;; This basic annotation type is simply a string that may contain return ;;; characters. (defclass ANNOTATION (basic-annotation) ((text :initform nil :initarg :text :accessor annotation-text) (width :initform 0 :initarg :width :accessor width) (height :initform 0 :initarg :height :accessor height) (ANGLE :initform 0 :initarg :angle :accessor angle)) ; usually 0 or pi/2 (:default-initargs :editable t)) (defmethod (setf width) (value (self basic-annotation)) ;; it is crucial that width and height are fixnums. (setf (slot-value self 'width) (values (truncate value)))) (defmethod (setf height) (value (self basic-annotation)) (setf (slot-value self 'height) (values (truncate value)))) (defmethod display-p ((self annotation)) "Let the annotation decide when to clip itself." (with-slots (graph width height) self (multiple-value-bind (left top) (uv-position self) (or (uv-is-inside graph left top) (uv-is-inside graph (+ left width) (+ top height) ))))) (defmethod display ((self annotation) stream) (let ((angle (angle self))) (multiple-value-bind (u v) (uv-for-display self) (multiple-value-setq (u v) (uv-to-screen stream u v)) (let ((record (with-output-as-presentation (:stream stream :object self :type 'annotation :single-box t) (draw-text-internal stream u v (annotation-text self) :alu (alu self) :rotation angle :stream stream )))) ;; Even though we have dimensions by now, we can get a better estimate ;; because there is a presentation box to look at. (when record (let ((*standard-output* stream)) ; bounding-rectangle cares! (multiple-value-bind (le te re be) (bounding-rectangle* record) (setf (width self) (- re le) (height self) (- be te))))))))) (defvar *annotation-whitespace* '(#\return #\space #\tab #+genera #\line #\page)) (defmethod figure-text-dimensions ((self annotation) STREAM) "Compute the width and height that the text will cover on the stream." (with-slots (graph style width height text angle) self (let* ((whitespace *annotation-whitespace*) (beginning 0)) ;; If the string starts out with empty lines, hack them off. (dotimes (i (length text)) (let ((ch (aref text i))) (cond ((not (member ch whitespace :test #'char=)) (return)) ((char= ch #\return) (setq beginning (1+ i)))))) (if (not (zerop beginning)) (setq text (subseq text beginning))) (setq text (string-trim whitespace text)) (multiple-value-setq (width height) (string-size stream style text)) (unless (zerop angle) (rotatef width height)) (values width height) ))) (defgeneric rescale-annotation (SELF) (:method-combination progn #-Lucid :most-specific-last) (:documentation "Called when the graph has been rescaled.")) (defmethod rescale-annotation progn ((self t)) nil) (defmethod figure-geometry ((self annotation) STREAM) (with-slots (presentation width height angle) self (with-output-truncation (stream) (figure-text-dimensions self STREAM)) (if (< (abs (- angle (/ pi 2))) single-float-epsilon) ;; Kludge the case of an annotation rotated 90 degrees. (setq height (- height))))) (defmethod set-text ((self annotation) STREAM new-string) ;; This method defined for convenience but not strictly necessary... (setf (annotation-text self) new-string (presentation self) nil) (figure-geometry self STREAM)) (defmethod mark ((self annotation) stream) "Draw a rectangle marking the edges of the annotation." (with-slots (width height) self (multiple-value-bind (left top) (uv-for-display self) (let ((right (+ left width)) (bottom (- top height))) (multiple-value-setq (left top) (uv-to-screen stream left top)) (multiple-value-setq (right bottom) (uv-to-screen stream right bottom)) (draw-rectangle left right bottom top :alu %flip :stream stream :opaque nil :filled nil))))) (defmethod edit ((self annotation) STREAM &optional the-string) "Interactively edit the text of the annotation." (with-slots (graph width height text) self (or the-string (setq the-string text)) (erase self STREAM) (with-output-truncation (stream) (unwind-protect ;; Make sure that ABORTing does the right thing. (multiple-value-bind (u v) (uv-for-display self) (multiple-value-bind (u1 v1) (uv-to-screen stream u v) (let ((u2 (+ u1 width)) (v2 (+ v1 height))) (setq the-string (window-edit-text stream u1 v1 u2 v2 the-string)) (set-text self STREAM the-string)))) (display self stream))))) (defmethod default-point1 ((a annotation)) (multiple-value-list (uv-for-display a))) (defmethod map-points-1 ((function t) (a annotation)) ;; point1 is one of the corners (UV) of the text annotation. (multiple-value-bind (l to) (uv-for-display a) (let* ((width (or (width a) 0)) (height (or (height a) 0)) (u-mid (+ l (values (truncate width 2)))) (v-mid (- to (values (truncate height 2)))) (points '(:top :bottom :left :right :ltop :lbottom :rtop :rbottom))) (labels ((coordinates (corner) (ecase corner (:top (values u-mid to )) (:bottom (values u-mid (- to height))) (:left (values l v-mid)) (:right (values (+ l width) v-mid)) (:ltop (values l to)) (:lbottom (values l (- to height))) (:rtop (values (+ l width) to)) (:rbottom (values (+ l width) (- to height)))))) (dolist (point points) (multiple-value-bind (u v) (coordinates point) (funcall function u v point))))))) ;;; Does anybody call this guy anymore? JPM 8 May 92. ;;; KRA 09JUN93: Yes (method annotate ( annotated-graph-mixin t t)) (defmethod create ((self annotation) STREAM) "Create an initial string and interactively edit it." (with-slots (graph width height) self (let ((initial-string (make-string 0))) (set-uv-position self (ull graph) (vur graph)) (set-text self STREAM initial-string) (setf (style self) (default-text-style graph stream)) ;; A nice size: (setq width 220 height 100) (move self STREAM) (edit self STREAM) self))) ; Return Non-NIL for success. (defun ANNOTATE-GRAPH (graph STREAM text x y &optional (display t) (type 'annotation)) "Noninteractively add an annotation." (let ((annotation (make-instance type :graph graph))) (install-annotation annotation graph stream text x y nil) (if display (display annotation stream)) annotation)) (defmacro WITH-OUTPUT-TO-ANNOTATION ((stream graph x y) &body body) "All output to STREAM really goes to an annotation located at x,y on graph" (let ((g (gensym)) (x0 (gensym)) (y0 (gensym)) (string (gensym))) `(let* ((,stream nil) (,g ,graph) ,string (,x0 ,x) (,y0 ,y)) (when (setq ,string (with-output-to-string (,stream) ,@body)) (annotate-graph ,g ,stream ,string ,x0 ,y0))))) ;;;POINT-ANNOTATION ;;; ;;; an annotation with a line that points to something. (defclass recompute-annotation-mixin () ((compute-function :initform nil :initarg :compute-function :accessor compute-function)) (:documentation "The compute-function is either a closure or NIL. The closure is used in a variety of ways to recompute something about the annotation. It was invented for the purpose of updating the text of an annotation when the thing that it points to has been changed in some way.")) (defmethod recompute ((self recompute-annotation-mixin)) (with-slots (compute-function) self (when compute-function (funcall compute-function self) t))) (defmethod recompute-annotation-appearance ((self recompute-annotation-mixin) (STREAM t)) (let* ((recompute-p (compute-function self)) (refresh-p (displayed? self))) (when recompute-p (cond (refresh-p (erase self stream) (recompute self) (display self stream)) (t (recompute self)))))) (defclass moving-annotation-piece-mixin () ((annotation :initform nil :initarg :annotation :accessor annotation)) (:documentation "Couple a moving-object to an annotation")) (defmethod graph ((object moving-annotation-piece-mixin)) (graph (annotation object))) (defmethod after-motion ((self moving-annotation-piece-mixin) (STREAM t)) (recompute-annotation-appearance (annotation self) STREAM)) (defmethod display ((self moving-annotation-piece-mixin) stream) (display (annotation self) stream)) (defmethod erase ((self moving-annotation-piece-mixin) stream) (erase (annotation self) stream)) (defmethod draw-at ((self moving-annotation-piece-mixin) stream u v) (set-stream-position self stream u v) (figure-geometry (annotation self) stream) (mark (annotation self) stream)) (defmethod erase-at ((self moving-annotation-piece-mixin) stream u v) (declare (ignore u v)) (unmark (annotation self) stream)) (defclass moving-annotation-point (moving-annotation-piece-mixin moving-point) ((radius :initform 5 :initarg :radius :accessor point-radius)) (:documentation "The 'point' part of a point-annotation")) (defmethod draw-xy-point ((object moving-annotation-point) stream &optional (alu %draw)) (with-slots (x y radius) object (multiple-value-bind (u v) (xy-to-uv (graph object) x y) (multiple-value-setq (u v) (uv-to-screen stream u v)) (device-draw-circle stream u v radius :alu alu :filled nil)))) (define-presentation-type moving-point () :description "a moving point" :printer ((object stream) (format stream "~S" object)) :parser ((stream) (read-char stream) (error "You must select an annotation with the mouse."))) (define-presentation-to-command-translator com-move-annotation-point (moving-point :command-name com-move-object :command-table :graph ;; Annotations are covered by a different translator. :tester ((object) (not (dwim::typep* object 'basic-annotation))) ; NLC :gesture :select :menu t :documentation "Move") (object &key WINDOW) `(,object ,WINDOW)) (defclass annotation-link-mixin () ((point1 :initform nil :initarg :point1 :accessor point1) (point2 :initform nil :initarg :point2 :accessor point2)) (:documentation "Defines a protocol for connecting two widgets with a line. Subclasses must provide MAP-POINTS-1 and MAP-POINTS-2 for mapping over consecutive corners of the two widgets.")) (defmethod draw-link ((object annotation-link-mixin) stream &optional (alu %draw)) (let* ((p1 (point1 object)) (p2 (point2 object)) (x1 (pop p1)) (y1 (pop p1)) (x2 (pop p2)) (y2 (pop p2))) (device-draw-line stream x1 y1 x2 y2 :alu alu))) (defmethod display :after ((object annotation-link-mixin) stream) (draw-link object stream)) (defmethod mark :after ((object annotation-link-mixin) stream) (draw-link object stream %flip)) (defmethod compute-point2-position ((object annotation-link-mixin)) (let ((point1 (or (point1 object) (default-point1 object)))) (multiple-value-bind (choice x2 y2) (closest-point (first point1) (second point1) #'map-points-2 object) (declare (ignore choice)) (setf (point2 object) (list x2 y2))))) (defmethod compute-point1-position ((object annotation-link-mixin)) (let ((point2 (or (point2 object) (default-point2 object)))) (multiple-value-bind (choice x1 y1) (closest-point (first point2) (second point2) #'map-points-1 object) (declare (ignore choice)) (setf (point1 object) (list x1 y1))))) (defmethod rescale-annotation progn ((self annotation-link-mixin)) ;; Since point positions are in uv coordinates, we need to recache ;; their values. (compute-point2-position self) (compute-point1-position self)) (defmethod figure-geometry :after ((self annotation-link-mixin) STREAM) (declare (ignore STREAM)) (compute-point2-position self) (compute-point1-position self)) (defmethod set-xy-position :after ((self annotation-link-mixin) x y &optional z) (declare (ignore x y z)) (compute-point2-position self) (compute-point1-position self)) (defclass POINT-ANNOTATION (annotation-link-mixin recompute-annotation-mixin annotation) ((point :initform nil :initarg :point :accessor point)) (:documentation "An annotation with a pointer to some uv point.")) (defmethod display :after ((self point-annotation) stream) (with-output-as-presentation (:stream stream :object (point self) :single-box t :type 'moving-point) (draw-xy-point (point self) stream %draw))) (defmethod mark :after ((self point-annotation) stream) (draw-xy-point (point self) stream %flip)) (defmethod display-p :around ((self point-annotation)) (or (call-next-method) (let ((point (point self))) (multiple-value-bind (u v) (xy-position point) (multiple-value-setq (u v) (xy-to-uv (graph self) u v)) (uv-is-inside (graph self) u v))))) (defmethod default-point2 ((a point-annotation)) (multiple-value-bind (u v) (xy-position (point a)) (multiple-value-setq (u v) (xy-to-uv (graph a) u v)) (list u v))) (defmethod map-points-2 ((function t) (a point-annotation)) ;; point2 is one of the corners (UV) of the polygon. (multiple-value-bind (u v) (xy-position (point a)) (multiple-value-setq (u v) (xy-to-uv (graph a) u v)) (funcall function u v (point a)))) ;;; Does anybody call this guy anymore? JPM 8 May 92. ;;; KRA 09JUN93: Yes (method annotate ( annotated-graph-mixin t t)) (defmethod create ((self point-annotation) STREAM) "Create an initial string and interactively edit it." (with-slots (graph width height) self (multiple-value-bind (u v) (device-mouse-point STREAM "Choose Point With Mouse") (when (and u v) (multiple-value-setq (u v) (uv-to-xy (graph self) u v)) (setf (point self) (make-instance 'moving-annotation-point :x u :y v :annotation self)) (let ((initial-string (make-string 0))) (set-uv-position self (ull graph) (vur graph)) (set-text self STREAM initial-string) (setf (style self) (default-text-style graph stream)) ;; A nice size: (setq width 220 height 100) (figure-geometry self stream) (move self STREAM) (edit self STREAM) self))))) ; Return non-nil for success. (defun ANNOTATE-POINT (graph STREAM text x y point-x point-y &optional text-fn) "Noninteractively annotate a point" (let ((annotation (make-instance 'point-annotation :graph graph))) (setf (point annotation) (make-instance 'moving-annotation-point :x point-x :y point-y :annotation annotation)) (install-annotation annotation graph stream text x y text-fn) (display annotation STREAM) annotation)) (defun install-annotation (annotation graph STREAM text x y text-fn) ;; KRA 09JUN93: This code was factored out from 3 places. ;; It could probably be a good :after initialize method. (set-xy-position annotation x y) (set-text annotation STREAM text) ;; Fixed-width looks better here. (setf (style annotation) (default-text-style graph stream)) (if text-fn (setf (slot-value annotation 'compute-function) text-fn)) (recompute-annotation-appearance annotation stream) (figure-geometry annotation stream) (setf (annotations graph) (cons annotation (annotations graph))) (values)) (defmethod choose-datum (dataset STREAM graph) "Return the datum nearest a mouse click." (multiple-value-bind (u1 v1) (device-mouse-point STREAM) (when u1 (multiple-value-bind (ignore1 ignore2 datum) (nearest-datum graph dataset u1 v1) (declare (ignore ignore1 ignore2)) datum)))) (defmethod nearest-datum (graph dataset u v) "Return the x,y datum nearest the given u,v coordinates." ;; Do this in uv coordinates, because what matters is what looks close on the ;; screen, not what seems close in x,y space. (multiple-value-bind (datum u0 v0) (closest-point u v #'(lambda (function dataset) (declare (downward-function)) (map-data dataset #'(lambda (datum) (declare (downward-function)) (multiple-value-bind (fric frac) (datum-position dataset datum) (multiple-value-bind (u1 v1) (xy-to-uv graph fric frac) (funcall function u1 v1 datum)))) (data dataset))) dataset) (multiple-value-setq (u0 v0) (uv-to-xy graph u0 v0)) (values u0 v0 datum))) (defmethod maybe-change-datum ((point-annotation point-annotation) STREAM dataset) ;; Constraint function for point annotations that always have to point to a datum. (let* ((point (point point-annotation)) (graph (graph point-annotation))) (multiple-value-bind (x y) (xy-position point) (multiple-value-bind (new-x new-y datum) (multiple-value-bind (u v) (xy-to-uv graph x y) (nearest-datum graph dataset u v)) (when (not (and (= x new-x) (= y new-y))) (cond ((displayed? point-annotation) (erase point-annotation STREAM) (set-xy-position point new-x new-y) (figure-geometry point-annotation stream) (display point-annotation stream)) (t (set-xy-position point new-x new-y) (figure-geometry point-annotation stream)))) datum)))) (defmethod text-for-datum (graph dataset datum) (let ((yname (and graph (string (y-label graph)))) (xname (and graph (string (x-label graph)))) (*print-circle* nil)) (when (or (not yname) (zerop (length yname))) (setq yname "Y")) (when (or (not xname) (zerop (length xname))) (setq xname "X")) (multiple-value-bind (x y) (datum-position dataset datum) (if (floatp x) (setq x (float-to-string x))) (if (floatp y) (setq y (float-to-string y))) (format nil "~A~%~A = ~A~%~A = ~A" (name dataset) xname x yname y)))) (defmethod annotate-data-point ((self graph-data) STREAM &optional graph datum) "Add a graph annotation describing a chosen data point." ;; This is essentially the same as DataProbe's Label Point command. (unless graph (setq graph (graph self))) (unless datum (setq datum (choose-datum self stream graph))) (when datum (let ((closure #'(lambda (annotation) (setq datum (maybe-change-datum annotation STREAM self)) (set-text annotation STREAM (text-for-datum graph self datum))))) (multiple-value-bind (x y) (datum-position self datum) (let ((a (annotate-point graph STREAM "" (xll graph) (yur graph) x y closure))) (when a (move a STREAM))))))) ;;; ;;; Region annotations ;;; (defclass annotation-polygon (moving-annotation-piece-mixin moving-polygon) ((annotation :initform nil :initarg :annotation :accessor annotation)) (:documentation "Couple a polygon to an annotation")) (define-presentation-type polygon-presentation () :description "a polygon" :printer ((object stream) (format stream "~S" object)) :parser ((stream) (read-char stream) (error "You must select a polygon with the mouse."))) (define-presentation-to-command-translator com-move-polygon (polygon-presentation :command-name com-move-object :command-table :graph :gesture :select :menu t :tester ((object) (moveable-polygon-p object)) :documentation "Move") (object &key WINDOW X Y) (progn (cache-moving-corner object window x y) `(,object ,WINDOW))) (defclass region-annotation (annotation-link-mixin recompute-annotation-mixin annotation) ((data :initform nil :initarg :data :accessor data) (region :initform nil :initarg :region :accessor region)) (:documentation "Annotate a set of data points contained within a region of the graph.")) (defmethod initialize-instance :after ((self region-annotation) &key &allow-other-keys) (let ((data (data self))) (when data (let ((corners (corners data))) (when corners (setf (region self) (make-instance 'annotation-polygon :corners corners :annotation self))))))) (defmethod display :after ((a region-annotation) stream) (let ((polygon (region a))) (with-output-as-presentation (:stream stream :object polygon :type 'polygon-presentation) (draw-xy-polygon polygon stream %draw)))) (defmethod display-p :around ((self region-annotation)) (or (call-next-method) (let ((graph (graph self))) (some #'(lambda (corner) (declare (downward-function)) (let ((u (first corner)) (v (second corner))) (multiple-value-setq (u v) (xy-to-uv graph u v)) (uv-is-inside graph u v))) (corners (region self)))))) (defmethod mark :after ((a region-annotation) stream) (draw-xy-polygon (region a) stream %flip)) (defmethod set-xy-position :after ((self region-annotation) x y &optional z) (declare (ignore x y z)) (compute-point2-position self) (compute-point1-position self)) (defmethod default-point2 ((a region-annotation)) (first (corners (region a)))) (defmethod map-points-2 ((function t) (a region-annotation)) ;; point2 is one of the corners (UV) of the polygon. (let ((graph (graph a))) (dolist (point (corners (region a))) (let ((x0 (car point)) (y0 (cadr point))) (multiple-value-setq (x0 y0) (xy-to-uv graph x0 y0)) (funcall function x0 y0 point))))) (defun ANNOTATE-REGION (graph stream text x y dataset &optional text-fn) "Noninteractively annotate a region of data." (let ((annotation (make-instance 'region-annotation :graph graph :data dataset ))) (install-annotation annotation graph stream text x y text-fn) (display annotation stream) annotation)) (defmethod annotate-data-region (dataset graph STREAM) "Add a graph annotation describing a chosen data interval." (let* ((choices (description-choices dataset)) gated) (when choices (setq gated (create-gated-dataset graph dataset stream)) (when gated (let* ((text-x (xll graph)) (text-y (yur graph)) (title (name dataset)) (closure (choose-description-function title STREAM choices gated)) (a (and closure (annotate-region graph stream "Hello" text-x text-y gated closure)))) (when a (move a STREAM))))))) ;;; This allows you to annotate a graph with a description tailored from a menu. All you ;;; need to do is provide a method for DESCRIPTION-CHOICES. You get a list of strings like ;;; " ". Your method should return an association list of ;;; 1) descriptive string and 2) function or message name. The function gets applied to an ;;; object to compute the value. (defgeneric DESCRIPTION-CHOICES (object) (:method-combination append #-lucid :most-specific-first) ; Fixed in 1991? (:documentation "Returns an association list of descriptive string, function name.")) (defun COMPUTE-DESCRIPTOR (function argument &rest arguments) ;; If function is a keyword, assume it is a Flavor message to be sent to argument. ;; Otherwise, apply it as in common lisp. (if (keywordp function) (apply argument function arguments) (apply function argument arguments))) (defun COMPUTE-DESCRIPTION-STRING (title choices &rest arguments) (let ((strings nil) (N 0) control-string (*print-circle* nil)) ;; First, figure out the tab stops. (dolist (choice choices (setq control-string (format nil "~~A~~~AT ~~A" (1+ N)))) (setq N (max N (length (first choice))))) ;; Now make the strings. (dolist (choice choices (setq strings (nreverse strings))) (let* ((value (apply #'compute-descriptor (second choice) arguments)) (string-value (cond ((stringp value) value) ((characterp value) (string value)) ((floatp value) (float-to-string value)) (t (format nil "~A" value))))) (push (format nil control-string (first choice) string-value) strings))) (when title (if (listp title) (setq strings (append title strings)) (setq strings (cons title strings)))) (format nil "~{~A~%~}" strings))) (defun CHOOSE-DESCRIPTORS (choices &optional (title "the selected data")) ;; CHOICES is a list of (string symbol) pairs. This function returns ;; a subset of those pairs. (multiple-value-bind (list abort-p) (several-choose choices :label (format nil "Choose several descriptors of ~A:" title)) (if abort-p (values nil t) (let ((result nil)) (dolist (item list) (push (find item choices :key #'second) result)) result)))) (defun CHOOSE-DESCRIPTION-STRING (title choices &rest arguments) ;; Used to annotate boxplots. (multiple-value-bind (the-choices abort-p) (choose-descriptors choices title) (unless abort-p (apply #'compute-description-string title the-choices arguments)))) (defun CHOOSE-DESCRIPTION-FUNCTION (title STREAM choices dataset) "Generate a closure that can update the description text." (multiple-value-bind (the-choices abort-p) (choose-descriptors choices title) (unless abort-p #'(lambda (annotation) (set-text annotation STREAM (compute-description-string title the-choices dataset)))))) ;;; When you annotate using all of these, some things obviously get computed twice. ;;; The cost is negligible, however, unless you have really huge datasets. (defmacro 2nd (form) "Return the second value returned by FORM" `(multiple-value-bind (ignore this) ,form (declare (ignore ignore)) this)) (defun n-samples (dataset) (2nd (x-mean dataset))) (defun minimum-x (dataset) (values (x-min-and-max dataset))) (defun maximum-x (dataset) (2nd (x-min-and-max dataset))) (defun minimum-y (dataset) (values (y-min-and-max dataset))) (defun maximum-y (dataset) (2nd (y-min-and-max dataset))) (defun mean-x (dataset) (values (x-mean dataset))) (defun mean-y (dataset) (values (y-mean dataset))) (defun standard-deviation-x (dataset) (2nd (x-mean-and-stdev dataset))) (defun standard-deviation-y (dataset) (2nd (y-mean-and-stdev dataset))) (defmethod description-choices append ((self graph-data)) (copy-list ; lucid uses Nconc instead of append? ; 9 apr 91 jpm. `(("# Samples" n-samples) ("X Minimum" minimum-x) ("X Maximum" maximum-x) ("X Mean" mean-x) ("X St. Dev." standard-deviation-x) ("Y Minimum" minimum-y) ("Y Maximum" maximum-y) ("Y Mean" mean-y) ("Y St. Dev." standard-deviation-y)))) (define-graph-command com-identify ((dataset 'graph-data) (graph 'graph) (datum 'invisible-object) (stream 'sheet)) "Add an annotation describing a data point." (cond ((and dataset graph datum stream) (annotate-data-point dataset stream graph datum)) (t (beep)))) (defmethod datum-presentation-p ((object t) presentation) ;; Check that it's a part of a graph and not part of the legend. (and (eql (presentation-type presentation) 'expression) (graph-under-presentation presentation) (not (graph-under-annotation-under-presentation presentation)))) (defun dataset-sensitive-p (presentation) (let ((dataset (dataset-under-presentation presentation))) (and dataset (present-self-p dataset)))) ;;; Make individual datums mouse-sensitive. This is a little bit tricky, ;;; since datums can literally be any lisp object. (define-presentation-to-command-translator com-identify (expression :command-name com-identify :command-table :graph :gesture :select :menu t :documentation "Identify Data Point" :tester ((object &key presentation) (and (datum-presentation-p object presentation) (dataset-sensitive-p presentation)))) (object &key presentation window) (list (dataset-under-presentation presentation) (graph-under-presentation presentation) object window)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/scigraph-system.lisp0000600000175000017500000000757610423413302025254 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: User -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :user) #| Scigraph is a system for graphing numeric data. It is not a program per se, but rather a toolbox that can be embedded in other Common Lisp applications. There have been many versions of scigraph. This version is designed to run both in dynamic windows and in CLIM interface environments. Much of this is done with macros, therefore we must keep separate binaries representing instantiations of this system with and without CLIM. The sources should be portable enough to run on any platform that runs CLIM (e.g. Lucid Lisp). Of course the binaries are both machine-dependent and GUI-dependent. See the file scigraph.doc for user documentation. |# #+genera (setq *load-pathname* (make-pathname :defaults si:fdefine-file-pathname :name nil :type nil :version nil)) (defsys:defsystem scigraph (:default-pathname *load-pathname* :default-binary-pathname (suggest-bin-directory) :default-package "USER" :default-optimizations () :patch-file-pattern NIL :needed-systems (dwim) :load-before-compile (dwim)) ("package") ("copy" :load-before-compile ("package")) ("dump" :load-before-compile ("copy")) ("duplicate" :load-before-compile ("dump")) ("random" :load-before-compile ("duplicate")) ("menu-tools" :load-before-compile ("random")) ("basic-classes" :load-before-compile ("menu-tools")) ("draw" :load-before-compile ("basic-classes")) ("mouse" :load-before-compile ("draw")) ("color" :load-before-compile ("mouse")) ("basic-graph" :load-before-compile ("color")) ("graph-mixins" :load-before-compile ("basic-graph")) ("axis" :load-before-compile ("graph-mixins")) ("moving-object" :load-before-compile ("axis")) ("symbol" :load-before-compile ("moving-object")) ("graph-data" :load-before-compile ("symbol")) ("legend" :load-before-compile ("graph-data")) ("graph-classes" :load-before-compile ("legend")) ("present" :load-before-compile ("graph-classes")) ("annotations" :load-before-compile ("present")) ("annotated-graph" :load-before-compile ("annotations")) ("contour" :load-before-compile ("annotated-graph")) ("equation" :load-before-compile ("contour")) ("popup-accept" :load-before-compile ("equation")) ("popup-accept-methods" :load-before-compile ("popup-accept")) ("duplicate-methods" :load-before-compile ("popup-accept-methods")) ("frame" :load-before-compile ("duplicate-methods")) ("export" :load-before-compile ("frame")) ("demo-frame" :load-before-compile ("export"))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/basic-classes.lisp0000644000175000017500000001102407750444411024653 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: TOOL -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :tool) ;;; NAMED-MIXIN ;;; Allows an object to have a name that effects the way it is printed or chosen from ;;; a menu. If a name is not provided one will be generated automatically like ;;; OBJECT-1, OBJECT-2 .... (eval-when (compile load eval) (export '(named-mixin name name-string make-name)) (export '(named-object) 'tool) (export 'declare-required-method) ) (defclass named-mixin () ((name :initform nil :initarg :name :reader name)) (:documentation "Allows each instance to have a name. One is generated for it if not provided. The name is always a symbol.")) (defmethod initialize-instance :after ((self named-mixin) &key) "Generate a name if necessary." (let ((name (name self))) (when (or (not name) (not (symbolp (name self)))) (setf (name self) (or name (make-name self)))))) (defmethod make-name ((self named-mixin)) "Make a name for yourself if necessary." (let ((class-name (class-name (class-of self)))) (intern (format nil "~a-~a" class-name (setf (get class-name 'name-index) (1+ (or (get class-name 'name-index) 0)))) (symbol-package class-name)))) (defmethod (setf name) (new-name (self named-mixin)) "This version make sure name is a symbol. You may want something else." (setf (slot-value self 'name) (cond ((not new-name) (make-name self)) ((symbolp new-name) new-name) ((stringp new-name) (intern new-name)) (t (intern (format nil "~a" new-name)))))) (defmethod name-string ((self t)) "Returns name as a string." (let ((name (name self))) (cond ((stringp name) name) ((symbolp name) (string-capitalize name)) (t (format nil "~a" name))))) (defmethod print-object ((self named-mixin) stream) (if *print-escape* (printing-random-object (self stream :no-pointer) (format stream "~a ~a" (class-name (class-of self)) (name self))) (format stream "~a" (name self)))) ;;; Since Objects do not have negative inheritance, it is difficult to get rid of ;;; behavior once it has been mixed in (append combinded methods for example). Thus ;;; methods for the OBJECT protocols are sometimes broken out into separate mixins ;;; with the suffix -OB-MIXIN. This gives you better control over pop-edit etc. (defclass BASIC-OBJECT (copyable-mixin dumpable-mixin) () (:documentation "The base of all scigraph objects. Any general capabilites can go here, rather than standard-object.")) (defclass NAMED-OBJECT (named-mixin basic-object) ()) ;;; Handy macro. ;;; Make a completely unspecific version of the method. If this ;;; gets called, it's a bug in the setup of the code. (defmacro declare-required-method (METHOD-NAME METHOD-ARGS) (let* ((REAL-ARGS ()) (ARG-LIST (loop for THING in METHOD-ARGS as REAL-ARG = (cond ((listp THING) (first THING)) ((and THING (not (char-equal (aref (symbol-name THING) 0) #\&))) THING)) when REAL-ARG do (push REAL-ARG REAL-ARGS) collecting (or REAL-ARG THING)))) `(defmethod ,METHOD-NAME ,ARG-LIST (declare (ignore ,@REAL-ARGS)) (error "Undefined :required-method ~A" ',method-name)))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/basic-graph.lisp0000600000175000017500000005460710423413302024307 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: GRAPH -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :graph) ;;; BASIC GRAPH CLASSES. ;;; To do: ;;; o High level idea: Separate transform, from graphics state and style ;;; o Move essential-graph-display into a basic-object mixin. (defvar *max-digits* 6 "Default number of digits of precision in a float for axis labeling.") (defvar *width-between-graphs* 3 "Pixels between graphs horizontally.") (defvar *height-between-graphs* 3 "Pixels between graphs vertically.") ;;; THE FOLLOWING MACROS ARE USED IN METHOD BODIES FOR DRAWING. (defmacro inside-rectangle? (x y left bottom right top) `(and (>= ,x ,left) (<= ,x ,right) (>= ,y ,bottom) (<= ,y ,top))) (eval-when (compile load eval) (proclaim '(inline constrain-point-in-rectangle)) (proclaim '(inline constrain-value-between))) (defun constrain-value-between (min x max) #+wrong (min (max min x) max) (if (<= min max) (min (max min x) max) (min (max max x) min))) (defun constrain-point-in-rectangle (x y left bottom right top) (values (constrain-value-between left x right) (constrain-value-between bottom y top))) ;;; Boxes are specified by their OUTSIDE edges, but their inside edges ;;; are stored... Users should only user -OUTSIDE methods. (defclass UV-BOX ; Corners of box (poor choice of names) () ((ull :initform 50 :initarg :ull :accessor ull) ; u lower left (vll :initform 50 :initarg :vll :accessor vll) ; v lower left (uur :initform 700 :initarg :uur :accessor uur) ; u upper right (vur :initform 700 :initarg :vur :accessor vur)) ; v upper right ) (defmethod uv-inside ((self uv-box)) "Returns graph's inside UV edges: LEFT RIGTH BOTTOM TOP." (with-slots (ull vll uur vur) self (values ull uur vll vur))) (defmethod uv-is-inside ((self uv-box) u v) (with-slots (ull vll uur vur) self (inside-rectangle? u v ull vll uur vur))) (defmethod set-uv-inside ((self uv-box) STREAM ul ur vb vt) (declare (ignore STREAM)) (with-slots (ull vll uur vur) self (when ul (setq ull (values (round ul)))) (when ur (setq uur (values (round ur)))) (when vb (setq vll (values (round vb)))) (when vt (setq vur (values (round vt)))))) ;;; Inside = Outside. (defmethod uv-outside ((self uv-box)) (uv-inside self)) (defmethod set-uv-outside ((self uv-box) STREAM ul ur vb vt &optional verify-p) (declare (ignore verify-p)) (set-uv-inside SELF STREAM ul ur vb vt)) (defclass XY-BOX () ((xll :initform 0.0 :initarg :xll :accessor xll) ; Lower left and upper ; right corners (yll :initform 0.0 :initarg :yll :accessor yll) ; Of the x-y box (xur :initform 1.0 :initarg :xur :accessor xur) (yur :initform 1.0 :initarg :yur :accessor yur))) (defmethod xy-inside ((self xy-box)) (with-slots (xll yll xur yur) self (values xll xur yll yur))) (defmethod set-xy-inside ((self xy-box) STREAM left right bottom top) (declare (ignore STREAM)) (with-slots (xll yll xur yur) self (when left (setq xll left)) (when right (setq xur right)) (when bottom (setq yll bottom)) (when top (setq yur top)))) (defclass BASIC-GRAPH-COORDINATES-MIXIN (xy-box uv-box) ((x-u-scale :initarg :x-u-scale :accessor x-u-scale) ; Scale factors for the mapping (y-v-scale :initarg :y-v-scale :accessor y-v-scale)) (:documentation "A mapping between two coordinate systems the (x y) coordinate system normally used by the user and the (u v) coordinate system which are integer device coordinates. A mapping between these two coordinate systems is set up by specifying the lower left and upper right corners of a window in each system that correspond.")) (defmethod with-graph-coordinates-1 ((self basic-graph-coordinates-mixin) STREAM ul ur vb vt xl xr yb yt continuation) "Warp graph inside coordinates to these new coordinates." ;; Used by legend drawing. (multiple-value-bind (oul our ovb ovt) (uv-inside self) (multiple-value-bind (oxl oxr oyb oyt) (xy-inside self) (unwind-protect (progn (set-uv-inside self STREAM ul ur vb vt) (set-xy-inside self STREAM xl xr yb yt) (funcall continuation)) (set-xy-inside self STREAM oxl oxr oyb oyt) (set-uv-inside self STREAM oul our ovb ovt))))) (defmacro with-graph-coordinates ((graph stream ul ur vb vt xl xr yb yt) &body body) `(with-graph-coordinates-1 ,graph ,stream ,ul ,ur ,vb ,vt ,xl ,xr ,yb ,yt #'(lambda () (declare (downward-function)) ,@body))) (defmethod set-xy-inside :after ((self basic-graph-coordinates-mixin) STREAM left right bottom top) (declare (ignore stream)) (when (or left right bottom top) (rescale self))) (defmethod set-uv-inside :after ((self basic-graph-coordinates-mixin) STREAM ul ur vb vt) (declare (ignore stream)) (when (or ul ur vb vt) (rescale self))) (defmethod uv-to-xy ((self basic-graph-coordinates-mixin) u v) (with-slots (xll ull x-u-scale yll vll y-v-scale) self (values (+ XLL (/ (- U ULL) X-U-SCALE)) (+ YLL (/ (- V VLL) Y-V-SCALE))))) (defmethod uv-to-xy-transform ((self basic-graph-coordinates-mixin)) (let ((xll (slot-value self 'xll)) (ull (slot-value self 'ull)) (x-u-scale (slot-value self 'x-u-scale)) (yll (slot-value self 'yll)) (vll (slot-value self 'vll)) (y-v-scale (slot-value self 'y-v-scale))) #'(lambda (u v) (values (+ xll (/ (- u ull) x-u-scale)) (+ yll (/ (- v vll) y-v-scale)))))) (defmethod xy-to-uv ((self basic-graph-coordinates-mixin) x y) (with-slots (xll ull x-u-scale yll vll y-v-scale) self (values (truncate (+ ULL (* (- X XLL) X-U-SCALE))) (truncate (+ VLL (* (- Y YLL) Y-V-SCALE)))))) (defmethod xy-to-stream ((self basic-graph-coordinates-mixin) stream x y) (multiple-value-bind (u v) (xy-to-uv self x y) (uv-to-screen stream u v))) (defmethod xy-to-uv-transform ((self basic-graph-coordinates-mixin)) ;; Carefully optimized to death. Calling the closure should not ;; cons any floats, unless the inputs X and Y are not floats. (let* ((xll (slot-value self 'xll)) (yll (slot-value self 'yll)) (ull (slot-value self 'ull)) (vll (slot-value self 'vll)) (x-u-scale (float (slot-value self 'x-u-scale))) (y-v-scale (float (slot-value self 'y-v-scale))) (temp1 (float (- ull (* xll x-u-scale)))) (temp2 (float (- vll (* yll y-v-scale))))) (declare (short-float x-u-scale temp1 y-v-scale temp2)) #'(lambda (x y) (values (truncate (the (short-float -1000000.0 1000000.0) (+ temp1 (* (the short-float (float x)) x-u-scale)))) (truncate (the (short-float -1000000.0 1000000.0) (+ temp2 (* (the short-float (float y)) y-v-scale)))))))) (defmethod xy-to-stream-transform ((self basic-graph-coordinates-mixin) stream) (let* ((xll (slot-value self 'xll)) (yll (slot-value self 'yll)) (ull (slot-value self 'ull)) (vll (slot-value self 'vll)) (x-u-scale (float (slot-value self 'x-u-scale))) (y-v-scale (float (slot-value self 'y-v-scale))) (height (the fixnum (sheet-inside-height stream))) (temp1 (float (- ull (* xll x-u-scale)))) (temp2 (float (- vll (* yll y-v-scale))))) (declare (short-float x-u-scale temp1 y-v-scale temp2)) (setq y-v-scale (- y-v-scale)) (setq temp2 (- height temp2)) #'(lambda (x y) (values (truncate (the (short-float -1000000.0 1000000.0) (+ temp1 (* (the short-float (float x)) x-u-scale)))) (truncate (the (short-float -1000000.0 1000000.0) (+ temp2 (* (the short-float (float y)) y-v-scale)))))))) (defmethod rescale ((self basic-graph-coordinates-mixin)) "Determine scales used in mapping between x-y and u-v." (with-slots (xll ull x-u-scale yll vll y-v-scale uur xur yur vur) self ;; Float to avoid consing big-rats. (setq x-u-scale (/ (- uur ull) (float (- xur xll)))) (setq y-v-scale (/ (- vur vll) (float (- yur yll)))))) (defmethod is-inside ((self basic-graph-coordinates-mixin) x y) "Is x-y point inside graph?" (multiple-value-setq (x y) (xy-to-uv self x y)) (uv-is-inside self x y)) #+genera (flavor:defflavor GRAPH-SIZE-ERROR (graph message) (error) :initable-instance-variables) #+genera (flavor:defmethod (:PROCEED graph-size-error :abandon) () "Abandon attempt to change size or margin." :abandon) #+genera (flavor:defmethod (:REPORT graph-size-error) (stream) (format stream "For graph ~a: ~a" graph message)) (defclass ESSENTIAL-GRAPH-MARGIN-MIXIN (basic-graph-coordinates-mixin) ;; Margin sizes in pixels. ((left-margin-size :initform 0 :reader left-margin-size) (right-margin-size :initform 0 :reader right-margin-size) (bottom-margin-size :initform 0 :reader bottom-margin-size) (top-margin-size :initform 0 :reader top-margin-size)) (:documentation "Provides graphs with a margin outside the normal plotting region.")) (defgeneric verify-new-outside (self left right bottom top left-margin right-margin bottom-margin top-margin) (:method-combination or #-Lucid :most-specific-last )) (defmethod display :before ((self essential-graph-margin-mixin) STREAM) (reset-margins self STREAM)) (defmethod margins ((self essential-graph-margin-mixin)) (with-slots (left-margin-size right-margin-size bottom-margin-size top-margin-size) self (values left-margin-size right-margin-size bottom-margin-size top-margin-size))) ;;; Have the committee on code purity look at this! ;;; BW: this resets the old values of uv-inside ;;; if the new ones (from :set-uv-outside) were bad!!!! (defmethod set-margins ((self essential-graph-margin-mixin) lm rm bm tm) (with-slots (left-margin-size right-margin-size bottom-margin-size top-margin-size) self (setf left-margin-size lm right-margin-size rm bottom-margin-size bm top-margin-size tm))) (defmethod reset-margins ((self essential-graph-margin-mixin) STREAM &optional verifyp) "Recompute margins after verifying they are OK." (multiple-value-bind (out-l out-r out-b out-t) (uv-outside self) (multiple-value-bind (lm rm bm tm) (compute-margins self STREAM) (unless (or (new-outside-check self verifyp out-l out-r out-b out-t lm rm bm tm) verifyp) (set-margins self lm rm bm tm) (set-uv-outside self STREAM out-l out-r out-b out-t))))) (defmethod compute-margins ((self essential-graph-margin-mixin) STREAM) "Compute the margin sizes. Whopperize this to add margin size. DON'T SIDE EFFECT." (declare (ignore STREAM) #+nil (values left-margin-size right-margin-size bottom-margin-size top-margin-size)) (values 0 0 0 0)) (defmethod uv-outside ((self essential-graph-margin-mixin)) (with-slots (left-margin-size right-margin-size bottom-margin-size top-margin-size ull uur vll vur) self (values (- ull left-margin-size) (+ uur right-margin-size) (- vll bottom-margin-size) (+ vur top-margin-size)))) (defmethod set-uv-outside :around ((self essential-graph-margin-mixin) STREAM u-ll u-ur v-ll v-ur &optional verifyp) "Specify the outside edges of the u-v window in pixels." (with-slots (left-margin-size right-margin-size bottom-margin-size top-margin-size) self (let ((complaint (new-outside-check self (not verifyp) u-ll u-ur v-ll v-ur left-margin-size right-margin-size bottom-margin-size top-margin-size))) (unless (or verifyp complaint) (call-next-method self STREAM u-ll u-ur v-ll v-ur verifyp)) complaint))) (defmethod set-uv-outside ((self essential-graph-margin-mixin) STREAM u-ll u-ur v-ll v-ur &optional verifyp) (declare (ignore verifyp)) (with-slots (left-margin-size right-margin-size bottom-margin-size top-margin-size) self (set-uv-inside self STREAM (values (round (+ u-ll left-margin-size))) (values (round (- u-ur right-margin-size))) (values (round (+ v-ll bottom-margin-size))) (values (round (- v-ur top-margin-size)))))) ;;; BW: change name from :new-outside-ok-p (defmethod new-outside-check ((self essential-graph-margin-mixin) complain-p left right bottom top left-margin right-margin bottom-margin top-margin) "Check that new edges and margin is OK, complaining" (let ((error (verify-new-outside self left right bottom top left-margin right-margin bottom-margin top-margin))) (when (and error complain-p) #+Genera (scl:signal-proceed-case (() 'graph-size-error :graph self :message error) (:abandon nil)) #-Genera (cerror error nil) ) ;; BW: return error, rather than success flag error)) (defmethod verify-new-outside or ((self essential-graph-margin-mixin) left right bottom top left-margin right-margin bottom-margin top-margin) "Return a error message if you don't like these edges and margins. This method just checks that there is room left to plot." (when (or (< (- right left left-margin right-margin) 0) (< (- top bottom bottom-margin top-margin) 0)) "Not enough room for inside of graph.")) (defmethod SCREEN-OUTSIDE ((self ESSENTIAL-GRAPH-MARGIN-MIXIN) STREAM) "Returns outside edges of graph in screen coordinates." ;;(declare (values left right bottom top)) (multiple-value-bind (le re be te) (uv-outside self) (multiple-value-setq (le be) (uv-to-screen stream le be)) (multiple-value-setq (re te) (uv-to-screen stream re te)) (values le re be te))) (defmethod SCREEN-INSIDE ((self ESSENTIAL-GRAPH-MARGIN-MIXIN) STREAM) "Returns inside edges of graph in screen coordinates." ;;(declare (values left right bottom top)) (with-slots (ull vll uur vur) self (multiple-value-bind (le be) (uv-to-screen stream ull vll) (multiple-value-bind (re te) (uv-to-screen stream uur vur) (values le re be te))))) ;;; This is now used by graphs, sliders, and annotations so that an object ;;; knows when it is displayed. (defclass essential-display-mixin () ((Displayed? :initform nil :initarg :displayed? :accessor displayed?))) (defmethod display :after ((self essential-display-mixin) (STREAM t)) (setf (displayed? self) t)) (defmethod erase :after ((self essential-display-mixin) (STREAM t)) (setf (displayed? self) nil)) (defmethod refresh ((self essential-display-mixin) STREAM) "Erase, then draw." (erase self stream) (display self STREAM)) (defclass BASIC-GRAPH-DRAW-MIXIN (basic-graph-coordinates-mixin) () (:documentation "Provide basic draw functionality for drawing lines and text.")) (let ((cosines-cache (make-hash-table))) (defun ROTATION-COSINES (rotation) (let ((cache cosines-cache)) (multiple-value-bind (value foundp) (gethash rotation cache) (when (not foundp) (setq value (cis rotation)) (setf (gethash rotation cache) value)) (values (realpart value) (imagpart value)))))) (defmethod char-position-relative-to-uv ((self BASIC-GRAPH-DRAW-MIXIN) STREAM x-rel y-rel dx dy rotation) ;; This assumes fixed-width fonts, and should be made obsolete. jpm. ;; m-X drop unnecessary funcalls (or (zerop dx) (setq dx (* dx (stream-character-width stream)))) (or (zerop dy) (setq dy (* dy (stream-line-height stream)))) (let ((c 1.0) (s 0.0)) (or (zerop rotation) (multiple-value-setq (c s) (rotation-cosines rotation))) (values (values (round (+ x-rel (* c dx) (- (* s dy))))) (values (round (+ y-rel (* s dx) (* c dy))))))) (defmethod xy-draw-line ((self basic-graph-draw-mixin) STREAM x1 y1 x2 y2 &rest keys) (multiple-value-setq (x1 y1) (xy-to-uv self x1 y1)) (multiple-value-setq (x2 y2) (xy-to-uv self x2 y2)) (apply #'device-draw-line stream x1 y1 x2 y2 keys)) (defmethod xy-draw-lines ((self basic-graph-draw-mixin) STREAM points &rest keys) "Draw a line between points x1 y1 y2 y2 ..." (let ((ds (or (getf keys :dash-ds) 0))) (multiple-value-bind (x1 y1) (xy-to-uv self (first points) (second points)) (do ((x1 x1 x2) (y1 y1 y2) (x2 (third points) (third points)) (y2 (fourth points) (fourth points)) (points (cddr points) (cddr points))) ((null points)) (multiple-value-setq (x2 y2) (xy-to-uv self x2 y2)) (setq ds (apply #'device-draw-line stream x1 y1 x2 y2 :dash-ds ds keys)))) ds)) (defmethod xy-draw-point ((self basic-graph-draw-mixin) x y &rest keys) (with-slots (stream) self (multiple-value-bind (u v) (xy-to-uv self x y) (apply #'device-draw-point stream u v keys)))) (defmethod text ((self basic-graph-draw-mixin) STREAM u v message &rest keys) "Print message on graph with lower left of first character at last position moved to." (multiple-value-setq (u v) (uv-to-screen stream u v)) (apply #'device-text stream u v (cond ((stringp message) message) ((characterp message) (string message)) ((floatp message) (float-to-string message)) (t (format nil "~a" message))) keys)) (defclass BASIC-GRAPH (essential-graph-margin-mixin basic-graph-draw-mixin essential-display-mixin) ((edge-spec :initform nil :initarg :edge-spec))) ; How edges were specified. (defmethod display ((graph basic-graph) (STREAM t)) "Render a graph on its display medium. Primary method is a stub." nil) ;;; KRA: temporary place for this. Generalize so fraction is in terms ;;; of a "superior" (defmethod set-uv-outside :around ((self basic-graph) STREAM left right bottom top &optional verifyp) "Lets edges be defined in terms of fractions of the window size." (with-slots (edge-spec) self (flet ((is-fractional (number) "Is NUMBER a fraction?" (and (numberp number) (<= 0.0 number 1.0)))) (setq edge-spec (list left right bottom top)) (multiple-value-bind (screen-width screen-height) (stream-viewport-size stream) (when (and stream (is-fractional left) (is-fractional right) (is-fractional bottom) (is-fractional top)) (setq left (+ (* left screen-width) *width-between-graphs*) right (- (* right screen-width) *width-between-graphs*) bottom (+ (* bottom screen-height) *height-between-graphs*) top (- (* top screen-height) *height-between-graphs*))) (call-next-method self STREAM (values (round left)) (values (round right)) (values (round bottom)) (values (round top)) verifyp))))) (defmethod uv-outside-from ((self basic-graph) STREAM &rest where) "Set edges from specification. WHERE can be: NIL - Reset edges from current edge-spec. :mouse - Specify with mouse :window - Fill the window. ((row rows) (col cols)) - Position graph in position (row col) of a rows by cols matrix of graphs. (left bottom right top) - Position of lower left and upper right corners of graph. If fractions, that fraction of window is used. Otherwise, absolute pixel positions are used." (with-slots (edge-spec) self (setq where (or (and where (copy-list where)) edge-spec (list :window))) (cond ((eq (first where) :mouse) (mouse-specify-edges self STREAM)) ((eq (first where) :window) (window-specify-edges self STREAM)) ((listp (first where)) (matrix-specify-edges self STREAM where)) ((numberp (first where)) (apply #'set-uv-outside self STREAM where)) (t (error "(graph uv-outside-from): invalid where specification ~a" where))) (setq edge-spec where))) (defmethod window-specify-edges ((self basic-graph) STREAM) (set-uv-outside self STREAM 0.0 1.0 0.0 1.0)) (defmethod mouse-specify-edges ((self basic-graph) STREAM) (with-slots (displayed?) self (multiple-value-bind (left top right bottom) (device-specify-rectangle stream) (if displayed? (erase self STREAM)) (set-uv-outside self STREAM left right bottom top)))) (defmethod matrix-specify-edges ((self basic-graph) STREAM spec) (let ((ROW (first (first SPEC))) (ROWS (second (first SPEC))) (COL (first (second SPEC))) (COLS (second (second SPEC)))) (let ((dx (/ 1.0 cols)) (dy (/ 1.0 rows))) (set-uv-outside self STREAM (* col dx) (* (1+ col) dx) (* (- rows row 1) dy) (* (- rows row) dy))))) (defmethod graph-with-clipping ((self basic-graph) STREAM inside-p continuation) ;; Internal to WITH-CLIPPING-TO-GRAPH macro. #-(or sbcl cmu) (declare (downward-funarg continuation)) (multiple-value-bind (le re be te) (if inside-p (screen-inside self STREAM) (screen-outside self STREAM)) (with-clipping-screen-rectangle (stream le re te be) ;; (draw-rectangle le re be te :filled nil :stream stream) (funcall continuation)))) (defmethod default-text-style ((graph basic-graph) stream) (stream-current-text-style stream)) (defmacro WITH-CLIPPING-TO-GRAPH ((graph STREAM inside-p) &body body) "Perform body while constraining clipping to GRAPH. If INSIDE-P, the clipping rectangle is the inside of the graph, otherwise it is the outside." `(graph-with-clipping ,graph ,STREAM ,inside-p #'(lambda () (declare (downward-function)) ,@body))) ;;; put commands in both the GRAPH and GLOBAL command tables. (defmacro define-graph-command (name arguments &body body) `(progn (define-command (,name :command-table :graph) ,arguments ,@body) (install-command :global ',name))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/frame.lisp0000644000175000017500000003015507753623070023242 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: GRAPH -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :graph) #| This file implements the function VIEW-GRAPHS as a way of getting a generic program frame for viewing a list of graphs. The program can be either temporary or persistent depending upon the keyword :wait-until-done. The program consists of a single, main display pane where graphs get drawn. In CLIM, the scigraph frame can also be made a "slave" of a second "master" frame by providing the :master keyword. The slave is like an extension of the master, where presentations on the slave are mouse-sensitive, but the master's command loop is responsible for reading and executing all commands. For this to work, the master must inherit the graph command table. |# ;;; ;;; Make a pane that runs the redisplayer when asked to repaint, so that ;;; frame resizing also resizes the graphs. ;;; #| How to get a pane to redraw its contents when it's been reshaped: The generic function to specialize on, as I told you, is WS::SHEET-REGION-CHANGED (which should have been exported from CLIM, but wasn't). However, that generic function is invoked on a clim-stream-pane every time something is added to the output history. It's only invoked on its viewport when the actual space taken up really changes, but there's no easy way for you to specialize on the viewport class. So you should do the following (in the ws package, 'natch): |# #+clim-0.9 (progn ;; JPM: The MAP system also provides the following two methods. ;; Whichever gets loaded last wins. Perhaps the common code should ;; be placed in a common file. (defmethod clim-shared::sheet-region-changed :after ((self ws::viewport-pane)) (with-slots (ws::extent-pane) self (ws::viewport-extent-changed ws::extent-pane))) (defmethod ws::viewport-extent-changed ((pane ci::pane)) nil) (defclass reshape-display-function-mixin () () (:Documentation "Run the redisplay function when window gets reshaped.")) (defmethod ws::viewport-extent-changed ((pane reshape-display-function-mixin)) ;; Test to see if the frame is enabled to suppress an unnecessary ;; redisplay for the case where the frame is initially getting enabled. (when (eq (frame-state (pane-frame pane)) :enabled) ;; JPM. This is done asynchronously, and could cause momentary ;; inconsistencies when done in a master/slave context, so inhibit ;; scheduling. (clim-utils:without-interrupts (pane-needs-redisplay pane) (redisplay-frame-pane pane)))) (defclass viewer-display-pane (reshape-display-function-mixin clim-stream-pane) ()) ;; Inherit the graph command table. (make-command-table graph-viewer :inherit-from (graph)) ) ;;; ;;; Now define the scigraph viewer frame. ;;; #+(and clim (not clim-0.9)) (define-application-frame graph-viewer () ((display-pane :accessor display-pane) (graphs :initform nil :accessor frame-graphs) (display-settings :initform nil :accessor display-settings)) #+clim-1.0 (:panes ((display :application :display-function 'redisplay-graphs :default-text-style (parse-text-style '(:fix :roman :normal)) :end-of-line-action :allow :end-of-page-action :allow :display-after-commands nil :initial-cursor-visibility nil :scroll-bars :both :stream-background +black+ :stream-foreground +white+) (documentation :pointer-documentation :stream-background +black+ :stream-foreground +white+))) #+(and clim-2 (not :mcclim)) (:panes (display (scrolling () (make-pane 'application-pane :display-function 'redisplay-graphs :display-time t :text-style (parse-text-style '(:fix :roman :normal)) :initial-cursor-visibility nil ;; There is a clim bug whose workaround is to use a non-default ;; output history. The bug is displaying overlapping presentations ;; in combination with a coordinate sorted set output history. In ;; our case, graph annotations sometimes get put into the history wrong. ;; At that point, they lose their mouse sensitivity. :OUTPUT-RECORD (MAKE-INSTANCE 'CLIM:R-TREE-OUTPUT-HISTORY) )))) ;; In McCLIM, the name of the pane goes with the top level pane in the ;; definition, which seems to follow the spec. But we want the name ;; to go with the application pane... #+mcclim (:panes (display :application :display-function 'redisplay-graphs :display-time t :text-style (parse-text-style '(:fix :roman :normal)) :initial-cursor-visibility nil :scroll-bars t)) #+clim-2 (:pointer-documentation t) #+clim-2 (:layouts (default (vertically () display))) #+(or clim-1.0 clim-2) (:command-table (graph-viewer :inherit-from (:graph))) (:top-level (scigraph-top-level)) ) #+clim-0.9 (clim:define-application-frame graph-viewer () ((display-pane :accessor display-pane) (command-table :initform 'graph-viewer :accessor frame-command-table) (graphs :initform nil :accessor frame-graphs) (display-settings :initform nil :accessor display-settings)) (:pane (clim:with-frame-slots (display-pane) (ws::viewing :subtransformationp t ;; KRA: There is something magic in this line. ;; If you remove it, it breaks. :hs 100 :vs 100 :hs+ clim:*fill* :hs- clim:*fill* :vs+ clim:*fill* :vs- clim:*fill* (setq display-pane (clim:make-pane 'viewer-display-pane :initial-cursor-visibility nil :display-function '(redisplay-graphs) :display-time nil))))) (:top-level (scigraph-top-level))) #-clim (dw:define-program-framework graph-viewer :size-from-pane display :selectable nil :top-level (scigraph-top-level) :command-table (:inherit-from '("graph" "colon full command" "standard arguments" "input editor compatibility") :kbd-accelerator-p t) :state-variables ((frame-graphs nil) (display-settings nil)) :other-defflavor-options ((:conc-name nil)) :panes ((display :display :flavor dw:dynamic-window-pane :redisplay-function 'redisplay-graphs :incremental-redisplay :own-redisplayer :redisplay-after-commands nil :more-p nil :blinker-p nil :margin-components nil))) (defun scigraph-top-level (self) (let* ((*package* (find-package :graph))) (loop (with-simple-restart (scigraph-top-level "Abort to SCIGRAPH Top Level") #+clim-2 (redisplay-frame-pane (get-frame-pane self 'display)) #FEATURE-CASE ((:clim-0.9 (clim-top-level self)) ((or :clim-1.0 :clim-2) (default-frame-top-level self)) ((not :clim) (dw:default-command-top-level self :echo-stream 'ignore :dispatch-mode :command-preferred))))))) #+clim-0.9 (defmethod enable-frame :after ((frame graph-viewer)) ;; Process all pending events for us, to get those ;; gratuitous repaint events from window managers handled early. (let ((g (frame-graphs frame))) (unwind-protect (with-slots (ws::queue) frame (setf (frame-graphs frame) nil) (do ((event (ws::peek-event ws::queue) (ws::peek-event ws::queue))) ((null event)) (setq event (ws::get-next-event ws::queue)) (when (typep event 'ws::repaint-event) ;; This is always a repaint event when things are working correctly. ;; Do a typecheck anyway, to guard against minor problems. (ws::default-execute-event event)))) ;; Pretend there aren't any graphs while processing repaint events. (setf (frame-graphs frame) g)))) (defun redisplay-graphs (self stream) ;; Vertically stack the graphs to fill the pane. (apply #'fill-window-with-graphs (frame-graphs self) :stream stream (display-settings self))) #-clim-0.9 (defun view-graphs (graphs &key (columns 1) autoscale (reverse-video t) (backing-store :when-mapped) create master (type 'graph-viewer) (title "View Graphs") (left 0) (bottom 0) (width 600) (height 400) (wait-until-done nil) &allow-other-keys) "Display a list of graphs in an interactive program frame." (launch-frame type :backing-store backing-store :master master :create create :title title :width width :height height :left left :bottom bottom :wait-until-done wait-until-done :initializer #'(lambda (application) (setf (frame-graphs application) graphs) (setf (display-settings application) `(:columns ,columns :reverse-video ,reverse-video :autoscale ,autoscale)) ;; Now we need to make sure the panes get sized BEFORE ;; the pane displayer gets run. By default, this happens ;; in the opposite order. Order is important because ;; scigraph asks the pane how big it is before drawing ;; the graph. #+clim-2 (resize-sheet (frame-top-level-sheet application) width height) ))) #+clim-0.9 (defun view-graphs (graphs &key (columns 1) autoscale (reverse-video t) (backing-store :when-mapped) create master (type 'graph-viewer) (command-table 'graph-viewer) (title "View Graphs") (left 0) (bottom 0) (width 600) (height 400) (wait-until-done nil) &allow-other-keys) "Display a list of graphs in an interactive program frame." ;; This is essentially launch-frame, with a few twists. ;; MASTER is either NIL or another frame. If provided, the two frames ;; share a frame manager and an event queue. ;; (let* ((manager (if master (clim:frame-manager master) (ws::find-frame-manager))) (frame (if (not create) (ws::get-reusable-frame manager type)))) (when frame ;; BUG: title is wrong on reused frames(?). (clim:reset-frame frame :title title)) (unless frame (setq frame (clim:make-frame type :title title)) (ws::adopt-frame manager frame)) (setf (ws::frame-prop frame :reusable) t) (setf (frame-graphs frame) nil) (when master ;; Change the event queue and reinitialize. ;; How should this be undone if this frame is recycled? (setf (slot-value frame 'ws::queue) (ws::frame-queue master)) (ci::initialize-stream-queues frame)) (ws::move-frame frame left bottom) (ws::size-frame frame width height) (window-clear (display-pane frame)) ;; If these are X windows, enable backing-store. #+xlib (let* ((pane (clim:frame-pane frame)) (port (clim:port pane))) (when (typep port 'on-x::x-port) (setf (xlib:window-backing-store (w::sheet-mirror! pane)) backing-store))) (if (graph-p graphs) (setq graphs (list graphs))) (setf (frame-graphs frame) graphs) (setf (frame-command-table frame) command-table) (setf (display-settings frame) `(:columns ,columns :reverse-video ,reverse-video :autoscale ,autoscale)) (if (not master) (clim:start-frame frame wait-until-done) (progn (clim:enable-frame frame) (clim:panes-need-redisplay frame) (clim:redisplay-frame-panes frame))) frame)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/mouse.lisp0000600000175000017500000004111210423413302023242 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: graph -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :graph) ;;; ;;; Mouse stuff ;;; (defun uv-under-mouse (stream) "The UV position of the mouse." (multiple-value-bind (x y) (stream-pointer-position* stream) (screen-to-uv stream x y))) (defmacro button-case (button &key left middle right) "Implementation-specific way to dispatch based on the button pushed." #FEATURE-CASE (((not :clim) `(case ,button ,@(if left `((#\mouse-l ,left))) ,@(if middle `((#\mouse-m ,middle))) ,@(if right `((#\mouse-r ,right))))) (:clim-0.9 `(case ,button ,@(if left `((:left ,left))) ,@(if middle `((:middle ,middle))) ,@(if right `((:right ,right))))) (:clim-1.0 `(cond ,@(if left `(((clim::button-press-event-matches-gesture-name ,button :select) ,left))) ,@(if middle `(((clim::button-press-event-matches-gesture-name ,button :describe) ,middle))) ,@(if right `(((clim::button-press-event-matches-gesture-name ,button :menu) ,right))))) ((and :clim-2 (not :mcclim)) `(cond ,@(if left `(((clim-internals::button-press-event-matches-gesture-name-p ,button :select) ,left))) ,@(if middle `(((clim-internals::button-press-event-matches-gesture-name-p ,button :describe) ,middle))) ,@(if right `(((clim-internals::button-press-event-matches-gesture-name-p ,button :menu) ,right))))) (:mcclim `(cond ,@(when left `(((event-matches-gesture-name-p ,button :select) ,left))) ,@(when middle `(((event-matches-gesture-name-p ,button :describe) ,middle))) ,@(when right `(((event-matches-gesture-name-p ,button :menu) ,right))))))) (defmethod post-mouse-documentation (stream string) #FEATURE-CASE ((:clim-0.9 (let ((frame (pane-frame stream))) ;; In 0.9, we can take advantage of one of the BBN clim extensions. (notify-user frame string))) (:clim-1.0 (locally (declare (ignore stream)) (let ((stream clim::*pointer-documentation-output*) #+genera (documentation-window (clim::mouse-documentation-window stream))) #+genera (when documentation-window (scl:send documentation-window :clear-window) (scl:send documentation-window :string-out string)) (when stream (window-clear stream) (format stream string))))) ((and :clim-2 (not :mcclim)) (locally (declare (ignore stream)) (clim:frame-manager-display-pointer-documentation-string (frame-manager *application-frame*) *application-frame* clim:*pointer-documentation-output* string))) (:mcclim (locally (declare (ignore stream)) (clim-extensions:frame-display-pointer-documentation-string *application-frame* clim:*pointer-documentation-output* string))) ((not :clim) nil))) (defmacro with-mouse-documentation ((window string) &body body) `(unwind-protect (progn (post-mouse-documentation ,window (or ,string " ")) ,@body) (post-mouse-documentation ,window " "))) (defmacro with-pointer-cursor ((sheet cursor) &body body) ;; XXX McCLIM will get pointer-cursors soon... -- moore #+(or (not clim-2) mcclim) `(progn ,@body) #+(and clim-2 (not mcclim)) `(let ((.old. (sheet-pointer-cursor ,sheet))) (unwind-protect (progn (setf (sheet-pointer-cursor ,sheet) ,cursor) ,@body) (setf (sheet-pointer-cursor ,sheet) .old.)))) ;;; DRAG-ICON is used to do most all of the mouse tracking. It differs from ;;; dragging-output in that the latter simply does output once and drags ;;; the output record around the screen. This function explicitly erases and ;;; redraws, which is useful if the shape of the output depends upon its location ;;; (e.g. sliders). (defun drag-icon (stream draw-it erase-it move-it &optional documentation (cursor :move)) "Mouse tracker for dragging graphic objects." ;; Erase the object before calling this function. ;; Dont forget to redraw the object after this function returns. ;; This requirement gives the caller the freedom to use an "abbreviated" ;; drawing for the inner loop, which may be necessary to create the ;; illusion of animation. #+nil (declare (downward-funarg draw-it erase-it move-it) (values gesture x y) (compiled-function draw-it erase-it move-it)) (unless #-clim (scl:send stream :interactive) #+clim (extended-input-stream-p stream) (error "Cannot track the mouse on this stream (~S)" stream)) (with-pointer-cursor (stream cursor) (let (last-x last-y (movements 0) ;; If we have had some movement and then the mouse is released, we ;; probably want to quit the loop. We don't count the first few because the ;; user might still be releasing the button that got him here. (down-threshold #+clim-0.9 5 #-clim-0.9 0) (up-threshold #+clim-0.9 15 #-clim-0.9 0)) ;; Sometimes we get rationals. ;; (declare (fixnum last-x last-y movements)) (unless documentation (setq documentation "Click/Release mouse to set new position")) (multiple-value-setq (last-x last-y) (stream-pointer-position* stream)) (unless (and last-x last-y) (beep) (setq last-x 0 last-y 0)) #+clim-0.9 (stream-clear-input stream) (flet ((update-position (x y) ;; "pixel" positions are often ratios and floats in clim #+(or clim-1.0 clim-2) (post-mouse-documentation stream documentation) (let ((dx (- x last-x)) (dy (- y last-y))) ;;(declare (fixnum dx dy) (fixnum x y)) (when (or (not (zerop dx)) (not (zerop dy))) ;;(draw-circle last-x last-y 5 :filled t :alu %flip :stream stream) ;;(draw-circle x y 5 :filled t :alu %flip :stream stream) (incf movements) (funcall erase-it stream) (funcall move-it dx dy) (setq last-x x last-y y) (funcall draw-it stream) ;; In X-windows, you need to force any buffered output. (force-output stream) ))) (button-clicked (button release-p) ;; Seem to get spurious left-click button releases shortly ;; after entering the tracker (13 movements). Maybe leftover ;; from the presentation menu that got us here... (when (if release-p (> movements up-threshold) (> movements down-threshold)) (return-from drag-icon (values button last-x last-y))))) #-clim (sleep .33) ; Kludge. Seems (empirically) to ; solve some synchronization problems ; involved with dynamic windows. (with-output-recording-disabled (stream) (unwind-protect (progn (funcall draw-it stream) (force-output stream) #-clim (dw:tracking-mouse (stream :who-line-documentation-string documentation) (:mouse-motion-hold (x y) (update-position x y)) (:mouse-motion (x y) (update-position x y)) (:mouse-click (click x y) (declare (ignore x y)) (button-clicked click nil)) (:release-mouse () (button-clicked nil t))) #+clim (with-mouse-documentation (stream documentation) #+clim-0.9 (tracking-pointer (stream) (:pointer-motion-hold (sheet x y) (DECLARE (IGNORE sheet)) (update-position x y)) (:pointer-motion (sheet x y) (DECLARE (IGNORE sheet)) (update-position x y)) (:button-release (button-name) (button-clicked button-name t)) (:button-press (button-name) (button-clicked button-name nil))) #+(or clim-1.0 clim-2) (tracking-pointer (stream) (:pointer-motion (x y) (update-position (values (truncate x)) (values (truncate y)))) (:pointer-button-press (event x y) (update-position (values (truncate x)) (values (truncate y))) (button-clicked event nil)) (:pointer-button-release (event x y) (update-position (values (truncate x)) (values (truncate y))) (button-clicked event t))))) ;; CLIM leaves the button event resulting from :button-press in the input ;; buffer, so take it out now. #+clim-0.9 (stream-clear-input stream) (funcall erase-it stream) (force-output stream))))))) #| (defun test-tracking (&optional (stream *standard-output*)) (let ((string "Test Tracking") x y) (multiple-value-setq (x y) (stream-pointer-position* stream)) (drag-icon stream #'(lambda (stream) (draw-string string x y :stream stream :alu %flip)) #'(lambda (stream) (draw-string string x y :stream stream :alu %flip)) #'(lambda (dx dy) (incf x dx) (incf y dy) (setq string (format nil "~S ~S" x y)))))) |# (defun device-mouse-point (stream &optional (documentation "Mouse-Left: Select Point; Mouse-Middle: Cancel")) "Returns u,v and gesture chosen by the mouse." ;; It is good to draw a 'cursor' even though the true mouse cursor is drawn as ;; well, so that the user can see by looking at the screen what the hell is ;; going on. (let ((fudge 10) button) (multiple-value-bind (x y) (stream-pointer-position* stream) (flet ((x-marks-the-spot (str) (draw-line x (- y fudge) x (+ y fudge) :stream str :alu %flip) (draw-line (- x fudge) y (+ x fudge) y :stream str :alu %flip) (draw-circle x y fudge :stream stream :alu %flip))) (setq button (drag-icon stream #'x-marks-the-spot #'x-marks-the-spot #'(lambda (dx dy) (incf x dx) (incf y dy)) documentation)) (multiple-value-setq (x y) (screen-to-uv stream x y)) (button-case button :left (values x y button) :right (values x y button)))))) (defun shift-p (window) "Determine whether the shift key is depressed." #-clim (declare (ignore window)) #FEATURE-CASE (((not :clim) (sys:console-key-state (scl:send (tv:console-default-superior) :console) :shift)) (:clim-0.9 (multiple-value-bind (x y mask) (ci::do-poll-pointer (port window) (silica::fetch-mirrored-sheet window)) (declare (ignore x y)) (= mask +shift-key+))) (:clim-1.0 (= #.(clim::make-shift-mask :shift) (clim::window-shift-mask window))) (:clim-2 (logtest +shift-key+ (port-modifier-state (port window))) ))) (defun mouse-input-rectangle (stream) "Return edges of rectangle in stream coordinates." ;;(declare (values left top right bottom button)) (multiple-value-bind (left top) (device-mouse-point stream) (when left (multiple-value-setq (left top) (uv-to-screen stream left top)) (multiple-value-bind (right bottom) (stream-pointer-position* stream) (let (button) (flet ((drawit (str) (shift-p str) (draw-rectangle left right top bottom :stream str :alu %flip))) (setq button (drag-icon stream #'drawit #'drawit #'(lambda (dx dy) (when (shift-p stream) (incf left dx) (incf top dy)) (incf right dx) (incf bottom dy)) "Mouse-Left: Done; Mouse-Middle: Cancel; Shift: Drag")) (if (< right left) (psetq left right right left)) (if (< top bottom) (psetq top bottom bottom top)) (button-case button :left (values left top right bottom button) :right (values left top right bottom button)))))))) (defun device-specify-rectangle (stream) "Ask user to specify a rectangle on STREAM with the mouse. Returns LEFT TOP RIGHT BOTTOM in UV coordinates." ;;(declare (values left top right bottom)) (multiple-value-bind (left top right bottom button) (mouse-input-rectangle stream) (when left (multiple-value-setq (left top) (screen-to-uv stream left top)) (multiple-value-setq (right bottom) (screen-to-uv stream right bottom)) (values (min left right) (max top bottom) (max left right) (min top bottom) button)))) (defun map-polygon-edges (function corners) (let* ((this (car (last corners))) (next (pop corners)) (x1 (pop this)) (y1 (pop this)) (x2 (pop next)) (y2 (pop next))) (loop (if (not x2) (return)) (funcall function x1 y1 x2 y2) (setq next (pop corners)) (setq x1 x2 y1 y2) (setq x2 (pop next) y2 (pop next))))) (defun draw-screen-polygon (corners stream alu) (map-polygon-edges #'(lambda (x1 y1 x2 y2) (declare (downward-function)) (draw-line x1 y1 x2 y2 :stream stream :alu alu)) corners)) (defun select-screen-polygon (stream &optional (cursor :position)) "Select a sequence of points in screen coordinates. Finish by clicking on first point." (with-output-recording-disabled (stream) (multiple-value-bind (lastx lasty) (device-mouse-point stream) (when lastx (multiple-value-setq (lastx lasty) (uv-to-screen stream lastx lasty)) (when lastx (sleep .4) ; wait for button release. (let* ((first (list lastx lasty)) (first-highlighted nil) (points (list first)) (rad 5) (documentation "Mouse-Left: Select Point; Mouse-Middle: Cancel; Mouse-Right: Finish") (x lastx) (y lasty)) (unwind-protect (block tracking (with-pointer-cursor (stream cursor) (labels ((distance (x1 y1 x2 y2) (sqrt (+ (expt (- x2 x1) 2) (expt (- y2 y1) 2)))) (near-first (x0 y0) (< (distance x0 y0 (car first) (cadr first)) rad)) (highlight-first () (setq first-highlighted (not first-highlighted)) (draw-circle (car first) (cadr first) rad :filled nil :alu %flip :stream stream)) (rubberband (x0 y0) (draw-line lastx lasty x0 y0 :stream stream :alu %flip)) (update-position (x0 y0) #+(or clim-1.0 clim-2) (post-mouse-documentation stream documentation) (Rubberband x y) (setq x x0 y y0) (rubberband x y) (if first-highlighted (if (near-first x0 y0) nil (highlight-first)) (if (near-first x0 y0) (highlight-first) nil)) (force-output stream)) (all-done () (update-position (car first) (cadr first)) (if first-highlighted (highlight-first)) (force-output stream) (return-from tracking points)) (button-clicked (button) (button-case button :middle (progn ;; cancel (update-position (car first) (cadr first)) (push (list (truncate x) (truncate y)) points) (if first-highlighted (highlight-first)) (return-from tracking nil)) :right (all-done) :left (cond ((near-first x y) (all-done)) (t ;; select another point (push (list (truncate x) (truncate y)) points) (setq lastx x lasty y)))))) #-clim (dw:tracking-mouse (stream :who-line-documentation-string documentation) (:mouse-motion-hold (x y) (update-position x y)) (:mouse-motion (x y) (update-position x y)) (:mouse-click (click x y) (declare (ignore x y)) (button-clicked click))) #+clim (with-mouse-documentation (stream documentation) #+clim-0.9 (tracking-pointer (stream) (:pointer-motion-hold (sheet x y) (DECLARE (IGNORE sheet)) (update-position x y)) (:pointer-motion (sheet x y) (DECLARE (IGNORE sheet)) (update-position x y)) (:button-press (button-name) (button-clicked button-name))) #+(or clim-1.0 clim-2) (tracking-pointer (stream) (:pointer-motion (x y) (update-position x y)) (:pointer-button-press (event x y) (update-position x y) (button-clicked event))) points)))) ;; Erase results when done: (draw-screen-polygon points stream %flip)))))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/menu-tools.lisp0000644000175000017500000002667107750444412024260 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: TOOL -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :tool) (eval-when (compile load eval) (export '(several-choose choose-character-style window-edit-text string-size))) (defun string-size (stream style format-string &rest format-args) ;; A bad implementation of this can really slow down graph generation. (unless (stringp format-string) (setq format-string (string format-string))) (when format-args ;; Typically, the formatter is not needed. (setq format-string (apply #'format nil format-string format-args))) #+clim-1.0 (when (eq style clim:*null-text-style*) ;; A kludge for sure. (setq style clim:*default-text-style*)) #+clim (let* ((return #.(aref (format nil "~%") 0)) (line-cnt (1+ (count return format-string :test #'char=)))) ;; This is 2-3 times faster than using continuation-output-size. (multiple-value-bind (x xmax) (stream-string-width stream format-string :text-style style) (declare (ignore x)) (values xmax (* line-cnt (stream-line-height stream style))))) #-clim (continuation-output-size #'(lambda (s) (if style (with-character-style (style s) (format s format-string)) (format s format-string))) stream)) ;;; These things are needed mainly for annotations, but they are kept in a separate ;;; file to minimize the clutter in the annotations code. (defun draw-radio-button (stream object text selected-p &optional size) (declare (ignore object)) (or size (setq size (stream-line-height stream))) (let* ((rad (values (truncate (- size 2) 2))) (offset rad)) ;; Since clim insists on flipping the coordinate system... #+(or clim-1.0 clim-2) (setq offset (- offset)) ;; #+clim-0.9 (terpri stream) (multiple-value-bind (x y) (stream-cursor-position* stream) #+clim-0.9 (stream-set-cursor-position* stream (setq x (+ x size)) y) (draw-circle (+ x offset) (+ y offset) rad :stream stream :filled selected-p) (if selected-p (with-character-face (:bold stream) (draw-string text (+ x (* size 2)) (+ y (* offset 2)) :stream stream)) (draw-string text (+ x (* size 2)) (+ y (* offset 2)) :stream stream))))) #+clim-2 (define-presentation-type-abbreviation button-subset (&key alist (test 'equal)) `(subset-alist ,alist :test ,test)) #+(or (not clim) clim-0.9 clim-1.0) (define-presentation-type button-subset (&key alist) :parser ((stream) (accept `(sequence (alist-member :alist ,alist)) :stream stream :prompt nil)) :printer ((object stream) (present object `(sequence (alist-member :alist ,alist)) :stream stream)) :typep ((object) (block testem (dolist (element object) (or (find element alist :key #'dwim::menu-execute-no-side-effects) (return-from testem nil))) t)) :describer ((stream) (write-string "any of " stream) (let (length (name-key #'dwim::token-element-string) (rest-of-elements alist)) (loop (or rest-of-elements (return)) (setq length (length rest-of-elements)) (format stream "~A" (funcall name-key (car rest-of-elements))) (cond ((> length 2) (write-string ", " stream)) ((= length 2) (write-string " or " stream)))))) :accept-values-displayer ((stream object query-identifier) ;; OBJECT is the currently chosen subset. (accept-values-choose-from-sequence stream alist object query-identifier :select-action #'(lambda (new list) (cond ((not (listp list)) (list new)) ((member new list) (remove new list)) (t (adjoin new list)))) :selection-test #'member :n-columns 1 :drawer #'(lambda (stream object text selected-p) (draw-radio-button stream object text selected-p))))) (defun SEVERAL-CHOOSE (ITEM-LIST &key highlighted-values (label "Choose Several") (stream *standard-output*) (own-window t)) "Lets you select several choices." (declare (values choices abort-p)) ;; Used by choose-descriptors to produce interval annotations. ;; ;; item-list is a list whose elements are either: ;; a. atoms ;; b. lists of length 2 whose CAR is the pretty name and whose CADR is the ;; actual value. (labels ((stringify (thing) (typecase thing (string thing) (symbol (symbol-name thing)) (otherwise (format nil "~A" thing))))) (let ((ptype `(button-subset :alist ,(mapcar #'(lambda (item) (if (atom item) (list (stringify item) :value item) (list (stringify (car item)) :value (cadr item)))) item-list)))) (if (eq :abort (accepting-values (stream :own-window own-window :label "Choose") (format stream label) (terpri stream) (setq highlighted-values #+clim-2 (accept ptype :default highlighted-values :view '(check-box-view :orientation :vertical) :prompt "Choose Several" :stream stream) #-clim-2 (accept ptype :default highlighted-values :prompt "Choose Several" :stream stream)) (terpri stream))) (values nil t) (nreverse highlighted-values))))) (defun test-chooser () (several-choose '(apples oranges pears))) (defun character-style-choices (family) (mapcar #'(lambda (style) `(,(apply #'format nil "~A ~A ~A" style) :value ,style :style ,style)) (mapcar #'(lambda (face-size) (cons family face-size)) (mapcan #'(lambda (size) `((:bold-italic ,size) (:bold ,size) (:italic ,size) (:roman ,size))) '(:very-large :large :normal :small :very-small))))) (defun CHOOSE-CHARACTER-STYLE () (let* ((family (menu-choose (mapcar #'(lambda (fam) `(,fam :value ,fam :style (,fam :roman :normal))) '(:fix #+clim :serif #-clim :dutch :sans-serif)) :prompt "Family")) (style (when family (menu-choose (character-style-choices family) :prompt "Character Styles")))) style)) (defvar *EDIT-DELIMITER* #-clim #\end #+clim #\return) (defvar *min-window-height* 100) (defvar *min-window-width* 220) #-clim (let ((edit-window nil)) (defun FIND-EDIT-WINDOW (stream) (let ((window edit-window)) (unless window (setq window (tv:make-window 'tv:pop-up-text-window :deexposed-typeout-action :permit :more-p nil :save-bits t :superior stream :label (format nil "Edit text (~C or ~C):~%" *edit-delimiter* #\abort) )) (setq edit-window window)) (funcall #'(setf sheet-parent) stream window) ; +++ Unresolved genera problem. window))) #-clim (defmacro with-edit-window ((symbol superior) &body body) `(let ((,symbol (find-edit-window ,superior))) ,@body)) #-clim (defun WINDOW-EDIT-TEXT (window left top right bottom &optional string) "Edit text in the given region of the window." (if (> top bottom) (psetq bottom top top bottom)) (if (> left right) (psetq right left left right)) (with-edit-window (ed-window window) (multiple-value-bind (ml mto mr mb) (scl:send ed-window :margins) (let* ((extra-width (+ ml mr (values (truncate (* (- right left) .5))))) (extra-height (+ mto mb (* (stream-line-height ed-window) 2))) width height) (setq width (max *min-window-width* (+ (- right left) extra-width))) (setq height (max *min-window-height* (+ (- bottom top) extra-height))) (change-size ed-window width height) (dw::position-window-near-carefully ed-window '(:mouse))) (scl:send ed-window :clear-window) (tv:with-window-shadowed-for-selection ((sys:console-selected-window (tv:sheet-console window)) ed-window) (tv:window-call (ed-window :deactivate) (scl:with-input-editing-options ((:initial-input string)) (scl:read-delimited-string *edit-delimiter* ed-window))))))) #+clim (defun WINDOW-EDIT-TEXT (window left top right bottom &optional string) "Edit text in the given region of the window." ;; This only reads a single line... ;; Note that clim 0.9 ignores the default string. (if (> top bottom) (psetq bottom top top bottom)) (if (> left right) (psetq right left left right)) (multiple-value-bind (x y) (stream-cursor-position* window) (let* ((prompt "Input a string") (prompt-width (string-size window nil "~A: " prompt)) (cursor-x (max 0 (- left prompt-width))) (cursor-y top) string-width) (unwind-protect (catch #+clim-0.9 'ci::abort-gesture-seen #-clim-0.9 :abort (stream-set-cursor-position* window cursor-x cursor-y) (with-output-recording-disabled (window) (setq string (accept 'string :stream window :default string :prompt prompt)) (setq string-width (string-size window nil string)) ;; erase editor typeout (let* ((right (+ cursor-x prompt-width string-width)) (bottom (+ top (stream-line-height window))) (rect (make-rectangle* cursor-x top right bottom))) (draw-rectangle cursor-x right top bottom :stream window :filled t :alu %erase) #-clim-2 (output-recording-stream-replay window rect) #+clim-2 (stream-replay window rect)) )) (stream-set-cursor-position* window x y)))) string) #+someday (defun read-note (&optional default-note) (with-menu (stream) ;; Set up the pop-up window the way we want to see it (setf (clim::cursor-visibility (clim::stream-text-cursor stream)) :off) (clim::window-set-inside-size stream (* 60 (stream-character-width stream #\Space)) (* 10 (stream-line-height stream))) (write-string "Enter a note:" stream) (fresh-line stream) (setf (stream-text-margin stream) (bounding-rectangle-width (window-viewport stream))) (window-expose stream) (unwind-protect (with-input-editing (stream) ;; Put the default note into the input buffer and ensure that ;; we never do it again (when default-note (replace-input stream default-note :rescan t) (setq default-note nil)) ;; Now get the input from the user (with-activation-characters ('(#\Newline) :override t) (unwind-protect (read-token stream) ;; Eat the activation character (read-gesture :stream stream :timeout 0)))) (setf (clim::cursor-visibility (clim::stream-text-cursor stream)) :inactive)))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/color.lisp0000644000175000017500000001742507750444411023270 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: GRAPH -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :graph) ;;; ;;; A feeble color naming facility. These names represent a selection ;;; of about 30 of the more than 700 names defined by X11. We don't want ;;; too many colors, because menus should be short and because there are limits to ;;; how many colors X Windows will let you use. ;;; (defvar *color-specifications* '(;; Primary colors. (:Green 0.0 1.0 0.0) ;;(:Blue 0.0 0.0 1.0) (:Magenta 1.0 0.0 1.0) (:Cyan 0.0 1.0 1.0) ;;(:Yellow 1.0 1.0 0.0) (:Red 1.0 0.0 0.0) ;; Earth Tones (:gold 1.0 .843 0.0) (:goldenrod .855 .647 .125) (:khaki .941 .902 .549) (:olivedrab .420 .557 .137) (:dark-khaki .741 .718 .420) (:peachpuff 1.0 .855 .725) (:sienna 0.627 0.322 0.176) (:orange 1.0 0.647 0.0) ;; (:maroon 0.690 0.188 0.376) (:firebrick 0.698 0.133 0.133) (:salmon 0.980 0.502 0.447) (:aquamarine 0.498 1.0 0.831) ;; (:dark-green 0.0 0.392 0.0) ;; (:green-yellow 0.678 1.0 0.184) (:pink 1.000 0.753 0.796) ;; (:orchid .855 .439 .839) (:violet-red 0.816 0.125 0.565) (:violet 0.933 0.510 0.933) ;; Grays (chosen to make sense in 8-bit color) ;;(:dark-slate-gray 0.184 0.31 0.31) (:Black 0.0 0.0 0.0) (:gray25 0.25 0.25 0.25) (:gray50 0.500 0.500 0.500) (:gray75 0.75 0.75 0.75) (:White 1.0 1.0 1.0) ;; Blues (:royal-blue .255 .412 .882) (:sky-blue 0.529 0.808 0.922) (:steel-blue 0.275 0.510 0.706) (:light-blue 0.678 0.847 0.902) ;; (:navy-blue 0.0 0.0 0.502) (:dark-turquoise 0.0 0.808 0.820) (:turquoise 0.251 0.878 0.816) ;; (:indian-red 0.804 0.361 0.361) ) "List of (color-name red green blue) for each color a user can choose from for drawing graphs.") (defvar *colors* nil "Used for pop-edit.") (let ((colors (make-hash-table))) (defun ALU-FOR-COLOR (color-name) "Translate a color name to an ink/alu" (or *colors* (initialize-color-system)) (or (gethash color-name colors nil) (gethash :white colors nil))) (defun MAKE-COLOR-CHOICES (color-specifications &optional reinitialize) "Makes an Alist of colors to choose from." (if reinitialize (setq colors (make-hash-table))) (cond ((color-exists-p) (loop for (name red green blue) in color-specifications do (setf (gethash name colors) (make-color-rgb red green blue)) (pushnew (list (string-capitalize name) :value name) *colors* :test #'equal))) #+genera (t (pushnew (list "White" tv:alu-ior) *colors*) (pushnew (list "Black" tv:alu-andca) *colors*) (setf (gethash :white colors) tv:alu-ior) (setf (gethash :black colors) tv:alu-andca))))) (defun initialize-color-system () "Initialize the color screen if available." ;; Called by ALU-FOR-COLOR the first time an alu is needed. #-clim (declare (special color:color-screen)) #+genera (when (color:color-exists-p) (or color:color-screen ;; Funcalls avoid compiler complaint when color system not ;; loaded at compile time. (funcall 'color:create-color-screen)) (scl:send color:color-screen :standardize-color-map)) (make-color-choices *color-specifications*)) (defun alu-for-stream (stream color-name) "Translate a color name to an ink/alu" (if (color-stream-p stream) (alu-for-color color-name) #+clim (if (eq color-name :black) %erase %draw) #-clim (if (eq color-name :black) tv:alu-andca tv:alu-ior))) (defun draw-color-swatch (stream color-name pretty-name selected-p &optional size) "Draw a sample of the given color at the current cursor position." (declare (ignore pretty-name)) (or size (setq size (stream-line-height stream))) (let ((rad (1- (values (truncate size 2))))) (multiple-value-bind (x y) (stream-cursor-position* stream) (draw-circle (+ x rad 1) (+ y rad 1) rad :filled t :stream stream :alu (alu-for-stream stream color-name)) (draw-rectangle x (+ x size -1) y (+ y size -1) :stream stream :filled nil :alu (if selected-p %draw %erase))))) (defun display-colors (&optional (stream *standard-output*) (colors *colors*)) "Display the current colors and their names." (dolist (color-name colors) (setq color-name (third color-name)) (terpri stream) (draw-color-swatch stream color-name nil nil) (stream-increment-cursor-position* stream 15 0) (format stream " ~A " color-name))) (defun display-gray-wash (&optional (stream *standard-output*) (quantum (/ 1.0 200))) "Display the range of gray scales." ;; Useful on 8-bit color systems to see what resolution there really is. (window-clear stream) (multiple-value-bind (left top right bottom) (stream-viewport stream) (let* ((intensity 0.0) (width (- right left)) (height (- bottom top)) (increment 0.0)) (setq left (+ left (* .1 width)) increment (* .8 quantum width) right (+ left increment) top (+ top (* .1 height)) bottom (- bottom (* .1 height))) (loop (if (> intensity 1.0) (return)) (let ((gray (make-color-rgb intensity intensity intensity))) (draw-rectangle left right bottom top :stream stream :alu gray :filled t) (setq left right right (+ right increment)) (incf intensity quantum)))))) #-clim-2 (define-presentation-type color-presentation () :description "a color" :parser ((stream) (completing-from-suggestions (stream) (dolist (color *colors*) (suggest (first color) (third color))))) :printer ((object stream) ;; Present the textual name, rather than a swatch of color. (write-string (string object) stream)) :accept-values-displayer ((stream object query-identifier) (accept-values-choose-from-sequence stream *colors* object query-identifier :drawer #'(lambda (stream object name selected-p) (draw-color-swatch stream object name selected-p))))) #+clim-2 (clim:define-presentation-type-abbreviation color-presentation () ;; Can't simply call this 'color' because that already names a class. `((member ,@(mapcar #'third *colors*)) :name-key string-capitalize :printer present-color :highlighter highlight-color)) #+clim-2 (defun present-color (object stream &key acceptably) (declare (ignore acceptably)) (with-room-for-graphics (stream) (draw-color-swatch stream object (string object) nil))) #+clim-2 (defun highlight-color (continuation object stream) (clim:surrounding-output-with-border (stream) (funcall continuation object stream))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/random.lisp0000600000175000017500000003330310423413302023375 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: STATISTICS -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :statistics) (eval-when (compile load eval) (export 'random-seed) (export 'with-seed) (export 'uniform) (proclaim '(inline uniform)) (proclaim '(inline uniform-basic)) (proclaim '(inline combined-uniform)) (export 'uniform-0-1) (export 'uniform-between) (export 'gaussian-random) (export 'gaussian) (export 'random-yes-no) (export 'erf)) ;;; PORTABLE UNIFORM AND GAUSSIAN RANDOM NUMBERS #|| Should work in most Common LISP's. See description of UNIFORM-BASIC. This was written before CL to provide a portable random number generator. If you want to use the portable uniform-basic function then do (PUSHNEW *FEATURES* SYSTEM-RANDOM), and you will use the portable uniform random number generator provided below. Linus Schrage, A More Portable Fortran Random Number Generator, ACM Trans. Math. Soft., V5, No. 2, p 132-138, 1979. S.K. Park and K.W. Miller, Random number generators: good ones are hard to find, CACM, v31, 10, Oct. 1988, p. 1192 - 1201. Pierre L'Ecuyer, Efficient and Portable Combined Random Number Generators, CACM, June 1988, Vol 31, Number 6, p. 742-774. ||# ;;; Better numbers, see Ecuyer, 1988. (eval-when (compile load eval) (defconstant *uniform-a* 40692) (defconstant *uniform-m* 2147483399)) (defun random-seed () "Return a random seed." #-system-random (get-internal-real-time) ; integer #+system-random (make-random-state)) ; structure #-system-random (eval-when (compile load eval) (when (>= most-positive-fixnum *uniform-m*) (pushnew ':fast-random-numbers *features*))) #-fast-random-numbers (defun uniform-basic (previous-fixnum) "Returns a random fixnum between 1 and (1- *uniform-m*)." #|| Repeated calls will generate fixnums in the range 1 -> *uniform-m* The basic ideas is that a is a primitive root of m, a large prime, 2 <= a <= m-1. f(z) = a*z mod m, The sequence zn = f(n-1), with initial seed, z1 , 1 <= z1 <= m-1 is: zn = a^n z1 mod m. a^m-1 mod m = 1. (Fermats' Theorem) a is a primitive root iff a^n mod m != 1 for 1 <= n <= m-2. If we start with z1 = 1, zn = a^n, zp = 1 for some p, which is the period of the random number sequence. When a is a primitive root of m, p = m-1, so p is as large as possible. This is a good random number generator but is not be the fastest! On most COMMON LISP's it will require bignums since (* *uniform-a* previous-fixnum) can have 46 bits in it. ||# (mod (* #.*uniform-a* previous-fixnum) #.*uniform-m*)) (defmacro uniform-internal (seed m a) "This version does not cons, but fixnums must be >= m, and (< (expt a 2) m)." (multiple-value-bind (q r) (truncate (eval m) (eval a)) `(multiple-value-bind (sq sr) (truncate (the fixnum ,seed) ,q) (declare (fixnum sq sr)) (let ((random (- (the fixnum (* ,a sr)) (the fixnum (* sq ,r))))) (declare (fixnum random)) (if (> random 0) random (+ random ,m)))))) (defun combined-uniform (seed-1 seed-2) "Returns a uniform random number between 0 and 1. It is computed from the difference between 2 uniform random numbers s1 and s2, mod (1- m1). S1, and s2 are linear congruential generators, with the constants m1, a1, m2, and a2, provided below. With these choices the period of the generator is (/ (* (1- m1) (1- m2))) or 2.305842648436452E18." (setq seed-1 (uniform-internal seed-1 2147483563 40014) seed-2 (uniform-internal seed-2 2147483399 40692)) (let ((random (- seed-1 seed-2))) (values (* (if (< random 1) (+ random (1- 2147483563)) random) (/ (coerce (- 2147483563 1) 'single-float))) seed-1 seed-2))) (defun make-uniform-stream (seed-1 seed-2) #'(lambda () (let (r) (multiple-value-setq (r seed-1 seed-2) (combined-uniform seed-1 seed-2)) r))) (defvar *uniform-seed* 63400018) ; 0 < fixnum < (- *uniform-m* 1) (defmacro with-seed (s-newseed &body body) "evaluates body with the seed of the random numbers set to S-NEWSEED. the value of S-NEWSEED is updated. Thus this is a way of Keeping several sequences of random numbers with their own seeds." #-system-random `(let ((*uniform-seed* ,s-newseed)) (prog1 (progn ,@body) (setf ,s-newseed *uniform-seed*))) #+system-random `(let ((*random-state* ,s-newseed)) (prog1 (progn ,@body) (setq ,s-newseed *random-state*)))) (defun uniform () "Returns the next uniform random number in the sequence To have your own sequence, use the macro WITH-SEED." #-system-random (setq *uniform-seed* (uniform-internal *uniform-seed* *uniform-m* *uniform-a*)) #+system-random (random *uniform-m* *random-state*)) (defun make-uniform-1-stream (seed) ;; Stream of uniform random numbers between 0 and 1 #'(lambda () (setq seed (uniform-internal seed *uniform-m* *uniform-a*)) (* seed (/ (float *uniform-m*))))) (defun uniform-0-1 () "A uniform random number greater than 0 and less than 1." (* (uniform) (/ (float *uniform-m*)))) #+debug (defun try (n) (let ((f '(lambda (N) (without-interrupts (time (dotimes (i N) (uniform))))))) (funcall (compile nil f) N))) ;;; For speed, you probably want an inline version of uniform-between for your application. (defun uniform-between (low-num high-num) "Returns a uniform random number, X, LOW-NUM < X < HIGH-NUM If low-num and/or high-num are fixnums, a fixnum is returned." (if (= low-num high-num) low-num #-system-random (if (and (integerp low-num) (integerp high-num)) (+ low-num (values (truncate (uniform) (/ #.(- *uniform-m* 1) (- high-num low-num))))) (+ low-num (* (* (uniform) #.(/ (float *uniform-m*))) (- high-num low-num)))) #+system-random (+ low-num (random (- high-num low-num))) )) (defun gaussian-random-1 () "Returns a gaussian random variable with mean 0.0 and standard deviation 1.0. Good tails." #-system-random (* (sqrt (* -2.0 (log (uniform-0-1)))) (sin (* #.(* 2.0 (coerce pi 'single-float)) (uniform-0-1)))) #+system-random (* (sqrt (* -2.0 (log (random 1.0)))) (sin (* #.(* 2.0 (coerce pi 'single-float)) (random 1.0))))) (defun gaussian-random (mean standard-deviation) "Returns a Gaussian random number with mean MEAN and standard deviation standard-deviation." (+ mean (* (gaussian-random-1) standard-deviation))) (defun gaussian (x) (/ (exp (- (/ (expt x 2) 2.0))) (sqrt #.(* 2.0 (coerce pi 'single-float))))) (defun random-yes-no (fraction-yes) "Returns t randomly FRACTION-YES of the time." (<= (uniform-0-1) fraction-yes)) (defmacro HORNER (x &rest coefs) "Expand polynomials by Horner's rule." (check-type x symbol) (cond ((null coefs) (error "There must be at least one coefficient.")) ((null (cdr coefs)) (first coefs)) ((null (cddr coefs)) (let ((multiple (second coefs))) (if (= (abs multiple) 1) (if (minusp multiple) `(- ,(first coefs) ,x) `(+ ,(first coefs) ,x)) `(+ ,(first coefs) (* ,x ,multiple))))) (t `(+ ,(first coefs) (* ,x (horner ,x . ,(cdr coefs))))))) (defun erf (x &aux y) "(ERF x) => (* (/ 2 (sqrt pi)) (integral from 0 to x of (exp (- (expt z 2)))) dz)) Approximation good to (abs error) <= 1.5e-7. Equation 7.1.26 of M. Abramowitz and I.A. Segun,\"Handbook of Mathematical Function\", 7th Edition, Dover Publications Inc., New York, 1968." (setq x (float x)) (cond ((< x 0) (- (erf (- x)))) ((> x 9) 1.0) ; Too big for exp. (t (setq y (/ 1.0 (+ 1.0 (* 0.3275911 x)))) (coerce (- 1.0 (* (exp (- (expt x 2))) (* y (horner y 0.2548296d0 -0.28449672d0 1.4214138d0 -1.4531521d0 1.0614054d0)))) 'single-float)))) #+testing (defun erf-int (z dx) (loop for x from 0.0d0 to z by dx sum (* dx (gaussian x)) into sum finally (return sum))) #+testing (defun erf-series (x) "Series erf function 7.1.5 of Abramowitz and Segun." (setq x (float x)) (loop for n from 0 by 1 for term = x then (/ (* -1.0d0 term (expt x 2)) n) while (> (abs term) (* 1.e-16 sum)) sum (/ term (+ 1.0 n n)) into sum finally (return (/ (* 2.0 sum) #.(sqrt pi))))) #+testing (defun make-it (N) (let ((data ()) (last (uniform))) (dotimes (i N) (push (list last (setq last (uniform))) data)) (make-instance 'graph::graph-data :data (nreverse data) :data-symbol :point))) ;;; ;;; Numerical Recipes in LISP ;;; (defmacro memoize-last (args &body body) (let ((result (cons nil nil)) (old-args (make-list (1+ (length args))))) (setf (car (last old-args)) result) `(let ((.old-args. ',old-args)) (let ((.p. .old-args.)) (if (and ,@(map 'list #'(lambda (a) `(equal ,a (pop .p.))) args) (not (eq (car .old-args.) (first .p.)))) ; Initialized? (first .p.) (let ((.p. .old-args.)) ,@(map 'list #'(lambda (a) `(progn (setf (first .p.) ,a) (setq .p. (cdr .p.)))) args) (setf (first .p.) (progn ,@body)))))))) (defmacro memoize (args &body body) (let ((body `(multiple-value-bind (.entry. .found.) (gethash .args. .table.) (if .found. (values-list .entry.) (progn (setf (gethash .args. .table.) (setq .entry. (multiple-value-list ,@body))) (values-list .entry.)))))) `(let ((.table. (load-time-value (make-hash-table :test #'equal)))) ,(if (cdr args) `(with-stack-list (.args. ,@args) ,body) `(let ((.args. ,(first args))) ,body))))) ;;; ;;; Gamma Distribution p. 206. ;;; (defun gamma-random (a random) "Returns a deviate distributed as a gamma distribution of interger order A, i.e. a waiting time to the A'th even in a Poisson process of unit mean, using RANDOM as the source of uniform deviates. A must be >= 1. For example, when A = 1, it is just the exponential distribution, the waithing time to the first event." (if (< a 6) ; Add waiting times directly. (let ((x 1.0)) (loop repeat a doing (setq x (* x (funcall random)))) (- (log x))) (loop (let ((v1 (- (* 2.0 (funcall random)) 1.0)) ; Rejection method. (v2 (- (* 2.0 (funcall random)) 1.0))) (if (<= (+ (* v1 v1) (* v2 v2)) 1.0) (let* ((y (/ v2 v1)) ; y = tan(pi + random). (am (- a 1.0)) (s (sqrt (+ (* 2.0 am) 1.0))) (x (+ (* s y) am))) (if (> x 0.0) (let ((e (* (+ 1.0 (* y y)) (exp (- (* am (log (/ x am))) (* s y)))))) (if (<= (funcall random) e) (return x)))))))))) ;;; ;;; Poisson Deviates p. 207. ;;; (defun poisson-random (m random) "Returns a integer that is a random deviate drawn from a Poisson distribution of mean m using RANDOM as the source of uniform random deviates." (if (< m 12) (let ((em -1) (temp 1.0)) ; Multiplying uniform deviates is the (loop (setf em (1+ em) ; same as adding expoential ones. temp (* temp (funcall random))) (unless (> temp ; Compare exponential rather than (memoize (m) (exp (- m)))) ; computing the log. (return))) em) (progn ; Use rejection method. (multiple-value-bind (sq log-m g) (memoize (m) (let ((log-m (log m))) (values (sqrt (* 2.0 m)) log-m (- (* m log-m (gammln (+ m 1.0))))))) (let (y em) (loop ;; Y is a deviate from a Lorentzian comparison function. (setf y (tan (* pi (funcall random))) ;; EM is Y shifted and scaled. em (+ (* sq y) m)) (if (>= em 0.0) ; Keep? ;; The trick for integer-valued distributions. (progn (setq em (values (truncate em))) ;; The ratio of the desired distribution to the comparison function. ;; Reject by comparing it to another uniform deviate. ;; The factor 0.9 makes in never exceed 1.0. (if (<= (funcall random) (* 0.9 (+ 1.0 (* y y)) (exp (- (* em log-m) (gammln (+ em 1.0)) g)))) (return em)))))))))) ;;; ;;; 6.1 Gamma Function, Beta Function, Factorials, Binomial Coefficients. ;;; Page 157. (defun gammln (x) "Returns the value of (log (gamma x)) for (> x 0). Full accuracy is obtained when (> x 1). For (< 0 X 1), the reflextion formula (6.1.4) can be used first." ;; Omit double precision if five figure accuracy is good enough. (let* ((x (- x 1.0d0)) (tmp (let ((tmp (+ x 5.5d0))) (- (* (+ x 0.5d0) (log tmp)) tmp))) (ser 1.0d0)) (incf ser (/ 76.18009173d0 (incf x 1.0d0))) (incf ser (/ -86.50532033d0 (incf x 1.0d0))) (incf ser (/ 24.01409822d0 (incf x 1.0d0))) (incf ser (/ -1.231739516d0 (incf x 1.0d0))) (incf ser (/ 0.120858003d-2 (incf x 1.0d0))) (incf ser (/ -0.536382d-5 (incf x 1.0d0))) (+ (log (* 2.50662827465d0 ser)) tmp))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/graph-data.lisp0000600000175000017500000012374410423413302024136 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: GRAPH -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :graph) #| Graphs apply the following functions to datasets: DISPLAY-DATA MAP-DATA DATUM-POSITION DATUM-DISPLAYER DATUM-STYLE-DISPLAYER AUTO-SCALE-LIMITS MAP-DATA-XY DATUM-POSITION SHOW-LEGEND DISPLAY-LEGEND-DATASET this has a subprotocol, see legend.lisp. TITLE X-LABEL Y-LABEL |# ;;; MT - put the DATA into a separate mixin, for ease of recombining the classes (defclass RAW-GRAPH-DATA () ((data :initform () :initarg :data :accessor data))) ; data to display (defclass BASIC-GRAPH-DATA (named-object) (;; Backpointer to the graph. (Maybe this should be GRAPHS instead of GRAPH.jpm) ;; KRA 27APR93: Maybe it should be removed #+OLD (graph :initform nil :initarg :graph :accessor graph) ;; The alu is basically a (relatively) internal representation of a color so the ;; value here is implementation specific. ;; On LISPM it is either a number like tv:alu-xor, a keyword like :DRAW ;; In CLIM, it is an ink. (alu :initform %alu :initarg :alu :accessor alu))) (declare-required-method display-data (SELF STREAM graph)) ; For drawing (declare-required-method name (SELF)) ; For presenting ;;; Define these guys just to simplify the protocol requirements. (defmethod data ((thing t)) nil) (defmethod map-data-xy ((dataset t) (function t) (data t)) nil) (defmethod x-label ((thing t)) nil) (defmethod y-label ((thing t)) nil) (defmethod title ((thing t)) nil) (defmethod rescale ((thing t)) nil) #| The following classes provide a protocol for manipulating data in a generic way that are used by other classes, for autoscaling etc. When defining new types of data classes, either use the generic interface, or override the methods that use them. PROTOCOL: (MAP-DATA function) - Map function over each datum. (MAP-DATA-XY function) - Map function over each xy pair. |# (defclass ESSENTIAL-GRAPH-DATA-MAP-MIXIN () () (:documentation "Generic protocol for mapping over data elements. See BASIC-GRAPH-DATUM-SYMBOLOGY-MIXIN")) (defmethod map-data ((dataset t) function (data sequence)) "Map FUNCTION over each datum." #-(or sbcl cmu) (declare (downward-funarg function)) (map nil function data)) (defmethod map-data-xy ((dataset ESSENTIAL-GRAPH-DATA-MAP-MIXIN) function data) "Map function over each x y pair." #-(or sbcl cmu) (declare (downward-funarg function)) (declare (compiled-function function)) (map-data dataset #'(lambda (datum) (declare (downward-function)) (multiple-value-bind (x y) (datum-position dataset datum) (funcall function x y))) data)) (defmacro with-alu ((stream alu) &body body) #+clim `(with-drawing-options (,stream :ink ,alu) ,@body) #-clim `(let ((.old. (scl:send ,stream :char-aluf)) (.new. #-clim (if (eq ,alu :draw) tv:alu-ior ,alu) #+clim ,alu)) (unwind-protect (progn (scl:send-if-handles ,stream :set-char-aluf .new.) ,@body) (scl:send-if-handles ,stream :set-char-aluf .old.)))) (defmethod display-data ((self essential-graph-data-map-mixin) STREAM graph) "Display the data on graph GRAPH using DATUM-DISPLAYER." (with-alu (stream (alu self)) ;; Fixup the alu just once, since its the same for every datum. (let ((displayer (datum-displayer self graph)) (H (sheet-inside-height stream)) (Trans (xy-to-uv-transform graph))) (declare (compiled-function displayer Trans) (fixnum H)) (map-data self #'(lambda (datum) (declare (downward-function)) (multiple-value-bind (x y) (datum-position self datum) (multiple-value-setq (x y) (funcall trans x y)) (setq y (- H (the fixnum y))) (funcall displayer stream x y datum) ;; Forcing the x buffer is nice here, but it is ;; extremely expensive. It slows drawing by 4x. #+slow (force-output stream))) (data self))))) (defmethod datum-displayer ((self essential-graph-data-map-mixin) graph) "Returns a function that expects a stream, UV coordinates of next datum, and the datum itself." (let ((displayers nil)) (dolist (symbology (symbologies self)) (let ((d (datum-style-displayer self graph symbology))) (when d (push d displayers)))) (if (cdr displayers) #'(lambda (stream u v datum) (dolist (d displayers) (funcall (the compiled-function d) stream u v datum))) (car displayers)))) (defmethod datum-position ((dataset t) (datum list)) "Extract the x,y coordinates of this datum." (values (first datum) (second datum))) (defclass ACCESSOR-DATUM-MIXIN () ((symbol-height) (x-accessor :accessor x-accessor :initform #'first :initarg :x-accessor) (y-accessor :accessor y-accessor :initform #'second :initarg :y-accessor)) (:documentation "Provides DATUM-POSITION based on accessor functions.")) (defmethod datum-position ((self accessor-datum-mixin) datum) "Returns the actual X Y to plot. It should: 1. decode the datum to determine its X and Y, and 2. use :XY-TO-PLOT to determine the actual values to be plotted." (values (funcall (the compiled-function (x-accessor self)) datum) (funcall (the compiled-function (y-accessor self)) datum))) (defclass GRAPH-DATA-X-OFFSET-MIXIN () ((x-offset :initform nil :initarg :x-offset :accessor x-offset)) (:documentation "Modifies DATUM-POSITION method to plot data with a constant x offset.")) (defmethod datum-position :around ((self graph-data-x-offset-mixin) datum) (let ((x-offset (x-offset self))) (multiple-value-bind (x y) (call-next-method self datum) (when x-offset (incf x x-offset)) (values x y)))) (defclass GRAPH-DATA-Y-OFFSET-MIXIN () ((y-offset :initform nil :initarg :y-offset :accessor y-offset)) (:documentation "Modifies DATUM-POSITION to plot data with a constant y offset.")) (defmethod datum-position :around ((self graph-data-y-offset-mixin) datum) (let ((y-offset (y-offset self))) (multiple-value-bind (x y) (call-next-method self datum) (when y-offset (incf y y-offset)) (values x y)))) ;;; GRAPH-DATA-XY-OFFSET-MIXIN is written as a separate mixin rather ;;; than a mixture of the 2 above to avoid adding 2 whoppers instead ;;; of 1 in the inner plot loop. (defclass GRAPH-DATA-XY-OFFSET-MIXIN () ((x-offset :initform nil :initarg :x-offset :accessor x-offset) (y-offset :initform nil :initarg :y-offset :accessor y-offset)) (:documentation "Modifies DATUM-POSITION to plot data with a constant x or y offset.")) (defmethod datum-position :around ((self graph-data-xy-offset-mixin) datum) (let ((x-offset (x-offset self)) (y-offset (y-offset self))) (multiple-value-bind (x y) (call-next-method self datum) (when x-offset (incf x x-offset)) (when y-offset (incf y y-offset)) (values x y)))) (defclass GRAPH-DATA-DITHER-MIXIN () ((x-dither :initform 0 :initarg :x-dither :accessor x-dither) (y-dither :initform 0 :initarg :y-dither :accessor y-dither) (dither-seed :initform (random-seed) :initarg :dither-seed :accessor dither-seed)) (:documentation "Used for data whose values are quantized, so that many datums will not map to exactly the same screen location. Modifies displayer methods but not map methods, because we still want to know exactly where datums are. The random seed is kept in hopes of generating a reproducible dithering.")) (defmethod xy-to-uv-distance (graph x-distance y-distance) ;; there must be a better equation (multiple-value-bind (u0 v0) (xy-to-uv graph 0 0) (declare (fixnum u0 v0)) (multiple-value-bind (u1 v1) (xy-to-uv graph x-distance y-distance) (declare (fixnum u1 v1)) (values (- u1 u0) (- v1 v0))))) (defmethod uv-to-xy-distance (graph x-distance y-distance) ;; there must be a better equation (multiple-value-bind (u0 v0) (uv-to-xy graph 0 0) (multiple-value-bind (u1 v1) (uv-to-xy graph x-distance y-distance) (values (- u1 u0) (- v1 v0))))) (defmethod datum-displayer :around ((self GRAPH-DATA-DITHER-MIXIN) graph) (with-slots (x-dither y-dither dither-seed) self (let ((f (call-next-method self graph))) (declare (compiled-function f)) (if (and x-dither x-dither (zerop x-dither) (zerop y-dither)) f (multiple-value-bind (u-dither v-dither) (xy-to-uv-distance graph (or x-dither 0) (or y-dither 0)) (declare (fixnum u-dither v-dither)) ;; Do dithering in uv coordinates so we can avoid floating point arithmetic ;; (big win for Lucid). (setq u-dither (abs u-dither) v-dither (abs v-dither)) #'(lambda (stream u v datum) (declare (fixnum u v)) (funcall f stream (+ u (the fixnum (statistics:uniform-between (- u-dither) u-dither))) (+ v (the fixnum (statistics:uniform-between (- v-dither) v-dither))) datum))))))) (defmethod display-data :around ((self graph-data-dither-mixin) stream graph) ;; Always use the same seed to get the same dithering. (with-seed (dither-seed self) (call-next-method self stream graph))) ;;; Actually each symbology should provide this, but this is more ;;; consistant with the way graphs used to do it. In fact, ;;; symbologies should be objects that you can ask for a display datum ;;; function that you map to display your data. (defclass graphics-style-mixin () ((pattern :initform nil :initarg :pattern :accessor pattern) ; in clim, NIL == FILLED (thickness :initform 0 :initarg :thickness :accessor thickness) (line-end-shape :initform :round :initarg :line-end-shape :accessor line-end-shape)) (:documentation "Fancy graphics style.")) (defvar *SCI-GRAPH-AVAILABLE-STIPPLES* (nconc '(("None" :value nil) ("Filled" :value t)) #+(and (not clim) broken) (loop for STIP in graphics:*STIPPLE-ARRAYS* collecting (list (graphics:stipple-array-name STIP) :value STIP)))) ;;; SYMBOLOGIES ;;; :scatter - plot datum as individual centered symbols. ;;; :line - draw continuous line through data. ;;; :step - draw stair step line between data points. ;;; :bar - draw a bar graph. ;;; Symbologies are organized into classes that share attributes in common. (defmacro symbology-classes (symbology) `(get ,symbology 'symbology-classes)) (setf (symbology-classes :scatter) '(:scatter)) (setf (symbology-classes :line) '(:line)) (setf (symbology-classes :bar) '(:bar :line)) (setf (symbology-classes :step) '(:step :line)) (setf (symbology-classes :line-symbol) '(:line-symbol :line :scatter)) (defun symbology-class-p (symbology class) (member class (symbology-classes symbology) :test #'eq)) (defun contains-symbology-class (symbologies class) (loop for symbology in symbologies thereis (symbology-class-p symbology class))) (defclass BASIC-GRAPH-DATUM-SYMBOLOGY-MIXIN (graphics-style-mixin) ;; Each datum is plotted in each symbology. ((symbologies :initform () :initarg :symbologies :accessor symbologies)) (:documentation "Any mixin providing a DATUM-STYLE-DISPLAYER should use 1 or more DATUM to extract the information it needs from the datum. See ESSENTIAL-DATUM-MIXIN.")) (defgeneric symbology-choices (self) (:method-combination append) (:documentation "Returns an alist acceptable for use with the ALIST-MEMBER presentation type")) (defclass GRAPH-DATUM-LINE-SYMBOLOGY-MIXIN (basic-graph-datum-symbology-mixin basic-graph-data) ((line-style :initform 0 :initarg :line-style :accessor line-style) (min-symbol-spacing :initform 20 ; pixels :initarg :min-symbol-spacing :accessor min-symbol-spacing)) (:documentation "Draw a line in dotted line style LINE-STYLE.")) (defmethod symbology-choices append ((self graph-datum-line-symbology-mixin)) ;; Lucid seems to do nconc instead of append, and makes circular lists, ;; hence the consing here. (list '("Line" :value :line) '("Line-Symbol" :value :line-symbol))) #+(and clim-0.9 xlib) (DEFMETHOD get-drawing-guts ((MEDIUM ON-X::CLG-MEDIUM)) (WITH-SLOTS (on-x::DRAWABLE on-x::GCONTEXT on-x::PORT on-x::DEVICE-TRANSFORMATION) MEDIUM (LET ((GCONTEXT on-x::GCONTEXT)) (ON-X::UPDATE-GCONTEXT-INK (MEDIUM-INK MEDIUM) GCONTEXT on-x::PORT MEDIUM) (SETF (XLIB:GCONTEXT-LINE-WIDTH GCONTEXT) (values (ROUND (OR (LINE-STYLE-THICKNESS (MEDIUM-LINE-STYLE MEDIUM)) 0)))) (SETF (XLIB:GCONTEXT-LINE-STYLE GCONTEXT) (IF (LINE-STYLE-DASHED (MEDIUM-LINE-STYLE MEDIUM)) :DASH :SOLID)) (values on-x::drawable gcontext on-x::device-transformation)))) ;;; first very crude cut, since I don't really understand what the ;;; previous one does !! #+(and clim-1.0 xlib) (defmethod get-drawing-guts ((w clim::clx-window)) (with-slots (clim::window ;drawable clim::foreground-gc ;gcontext ) w ;; do we need any others here? ;; (break) (values clim::window clim::foreground-gc t))) #+(and clim-0.9 xlib) (defmethod transformation-offsets ((tr silica::st-transformation)) (with-slots (silica::m20 silica::m21) tr ;; why are these floats? (values (values (round silica::m20)) (values (round silica::m21))))) #+(and clim xlib) (defmethod transformation-offsets ((any t)) (values 0 0)) (defmethod dont-record-output-history ((dataset t)) "If true, then we have permission to optimize the hell out of the line displayer." (let ((line-style (line-style dataset)) (thickness (thickness dataset)) (data (data dataset))) ;; Returns T for a vanilla line style and a relatively large data set. (and (zerop line-style) (< thickness 2) (not (present-self-p dataset)) (typep data 'sequence) (> (length data) 2500)))) (defmethod compute-line-displayer ((dataset t)) ;; Returns a function of (stream x1 y1 x2 y2) that draws a line without clipping. (make-optimized-line-displayer (alu dataset) (thickness dataset) (not (dont-record-output-history dataset)))) (defmethod datum-style-displayer ((self graph-datum-line-symbology-mixin) graph (type (eql :LINE))) "Draws a line between points." (declare (ignore graph)) (let* ((line-style (line-style self)) (thickness (thickness self)) (alu (alu self)) (pattern (pattern self)) (line-end-shape (line-end-shape self)) (clip-rectangle *clip-rectangle*) (left (pop clip-rectangle)) (right (pop clip-rectangle)) (bottom (pop clip-rectangle)) (top (pop clip-rectangle)) (dash-ds 0.0) (last-in nil) (last-u NIL) (last-v NIL)) (declare (fixnum bottom top left right line-style thickness)) (if (< bottom top) (psetq top bottom bottom top)) (if (zerop line-style) (let ((displayer (compute-line-displayer self))) #'(lambda (stream u v datum) (declare (fixnum u v) (ignore datum)) ;; This is the most common case. (let ((this-in (and u (< left u right) (< top v bottom)))) (cond ((null last-u)) ((null u)) ((and (= u last-u) (= v last-v))) ((and last-in this-in) ;; dont bother to clip. (funcall displayer stream last-u last-v u v)) (t ;; do it the slow way (rarely) (device-draw-line stream last-u last-v u v :thickness thickness :transform nil :alu alu))) (setq last-in this-in) (setq last-u u last-v v)))) #'(lambda (stream u v datum) (declare (fixnum u v) (ignore datum)) (when (and u last-u) (setq dash-ds (device-draw-line stream last-u last-v u v :alu alu :dash-pattern line-style :pattern pattern :thickness thickness :line-end-shape line-end-shape :dash-ds dash-ds :transform nil))) (setq last-u u last-v v))))) (defmethod datum-style-displayer ((self graph-datum-line-symbology-mixin) graph (type (eql :LINE-SYMBOL))) "Draws a line, with a symbol every min-symbol-spacing pixels." (let* ((line-style (line-style self)) (alu (alu self)) (pattern (pattern self)) (thickness (thickness self)) (line-end-shape (line-end-shape self)) (min-symbol-spacing (min-symbol-spacing self)) (dash-ds 0.0) (last-distance -1) (last-u NIL) (last-v NIL) (symbol-displayer (datum-style-displayer self graph :scatter))) (declare (fixnum last-distance min-symbol-spacing thickness) (compiled-function symbol-displayer)) (flet ((distance (x1 y1 x2 y2) (declare (fixnum x1 y1 x2 y2)) ;;; This needs to return an integer (actually it is a fixnum, assuming x&y are.) (values (ROUND (sqrt (+ (expt (- x2 x1) 2) (expt (- y2 y1) 2))))))) #'(lambda (stream u v datum) (declare (fixnum u v)) (when (not (minusp last-distance)) (incf last-distance (the fixnum (distance u v last-u last-v)))) (when (or (minusp last-distance) (> last-distance min-symbol-spacing)) (funcall symbol-displayer stream u v datum) (setq last-distance 0)) (cond ((not last-u)) ((not u)) (t (setq dash-ds (device-draw-line stream last-u last-v u v :alu alu :dash-pattern line-style :pattern pattern :thickness thickness :line-end-shape line-end-shape :dash-ds dash-ds :transform nil)))) (setq last-u u last-v v))))) (defclass GRAPH-DATUM-BAR-SYMBOLOGY-MIXIN (graph-datum-line-symbology-mixin basic-graph-datum-symbology-mixin basic-graph-data) ; Default bar width (Xu) ((bar-width :initform nil :initarg :bar-width :accessor bar-width)) (:documentation "Provides a vertical bar symbology.")) (defmethod symbology-choices append ((self GRAPH-DATUM-BAR-SYMBOLOGY-MIXIN)) (list '("Bar" :value :bar))) (defmethod make-legend-datum ((self graph-datum-bar-symbology-mixin) x y &rest args) (declare (ignore args)) (list x y) ;(list x y 0.75) ; Provide a width to look nicer. ) ;;; ---- ---- ;;; | | | ;;; MThome has pointed out that when bars are drawn like | | rather than | ;;; the dotted patterns overlap and look ugly. ;;; (defmethod datum-style-displayer ((self GRAPH-DATUM-BAR-SYMBOLOGY-MIXIN) graph (style (eql :bar))) "Draws a bar centered at datum. If WIDTH is not provided BAR-WIDTH is used. If neither WIDTH nor BAR-WIDTH are provided, the width of the bar is determined from point spacing and points are assume ordered in X." (multiple-value-bind (x0 y0) (xy-to-uv graph 0.0 0.0) ; baseline position. (let* ((pattern (pattern self)) (line-style (line-style self)) (thickness (thickness self)) (line-end-shape (line-end-shape self)) (dash-ds 0.0) (bar-width (bar-width self)) (default-width (and bar-width (values (round (* bar-width (x-u-scale graph)))))) (alu (alu self)) (transform-baseline t) x-last y-last) ;;; KRA: Factor pattern out of lambda. #'(lambda (stream x y datum) (declare (ignore datum)) (when transform-baseline ;; have to wait to do this till we have a stream. (multiple-value-setq (x0 y0) (uv-to-screen stream x0 y0)) (setq transform-baseline nil)) (let* ((width default-width)) (if width (let* ((half (values (truncate width 2))) (x- (- x half)) (x+ (+ x half))) ;; center of bar corresponds to x,y position (if pattern (device-draw-rectangle stream x- x+ y0 y :alu alu :filled t :pattern pattern) (setq dash-ds (with-stack-list (points x- y0 x- y x+ y x+ y0) (device-draw-lines stream points :alu alu :dash-ds dash-ds :dash-pattern line-style :pattern pattern :thickness thickness :line-end-shape line-end-shape :transform nil))))) ;; No width case: end of bar corresponds to x,y position. ;; This is pretty much like :step is drawn, so that variable sampling ;; rates look right. (when x-last (let* ((width (values (truncate (- x x-last) 2))) (x++ (+ x-last width))) (if pattern (device-draw-rectangle stream (- x width) (+ x width) y0 y :filled t :alu alu :pattern pattern) (setq dash-ds (with-stack-list (points x-last y-last x++ y-last x++ y0 x++ y x y) (device-draw-lines stream points :alu alu :dash-ds dash-ds :dash-pattern line-style :pattern pattern :thickness thickness :line-end-shape line-end-shape :transform nil))))))) (setq x-last x y-last y)))))) (defclass GRAPH-DATUM-STEP-SYMBOLOGY-MIXIN (graph-datum-line-symbology-mixin basic-graph-datum-symbology-mixin basic-graph-data) ()) (defmethod symbology-choices append ((self graph-datum-step-symbology-mixin)) (list '("Step" :value :step))) ;;; This style isn't on menu. (defmethod datum-style-displayer ((self graph-datum-line-symbology-mixin) graph (type (eql :CENTERED-STEP))) "Draws a line between points." (declare (ignore graph)) (let ((line-style (line-style self)) (alu (alu self)) (pattern (pattern self)) (thickness (thickness self)) (line-end-shape (line-end-shape self)) (dash-ds 0.0) (last-u NIL) (last-v NIL)) #'(lambda (stream u v datum) (declare (ignore datum)) dash-ds (cond ((not last-u)) ((not u)) (t (let ((u+ (+ last-u (values (truncate (- u last-u) 2))))) (setq dash-ds (with-stack-list (points last-u last-v u+ last-v u+ v u v) (device-draw-lines STREAM points :alu alu :dash-pattern line-style :pattern pattern :thickness thickness :line-end-shape line-end-shape :transform nil)))))) (setq last-u u last-v v)))) (defmethod datum-style-displayer ((self graph-datum-line-symbology-mixin) graph (type (eql :STEP))) "Draws a line between points." (declare (ignore graph)) (let* ((line-style (line-style self)) (alu (alu self)) (pattern (pattern self)) (thickness (thickness self)) (line-end-shape (line-end-shape self)) (clip-rectangle *clip-rectangle*) (left (pop clip-rectangle)) (right (pop clip-rectangle)) (bottom (pop clip-rectangle)) (top (pop clip-rectangle)) (dash-ds 0.0) (last-in nil) (last-u NIL) (last-v NIL)) (declare (fixnum thickness)) (if (< bottom top) (psetq top bottom bottom top)) (if (zerop line-style) (let ((displayer (compute-line-displayer self))) #'(lambda (stream u v datum) (declare (fixnum u v) (ignore datum)) ;; This is the most common case. (let ((this-in (and u (< left u right) (< top v bottom)))) (cond ((null last-u)) ((null u)) ((and (= u last-u) (= v last-v))) ((and last-in this-in) ;; dont bother to clip. (funcall displayer stream last-u last-v u last-v) (funcall displayer stream u last-v u v)) (t ;; do it the slow way (rarely) (with-stack-list (points last-u last-v u last-v u v) (device-draw-lines STREAM points :alu alu :transform nil)))) (setq last-in this-in) (setq last-u u last-v v)))) #'(lambda (stream u v datum) (declare (fixnum u v) (ignore datum)) dash-ds (cond ((not last-u)) ((not u)) (t (setq dash-ds (with-stack-list (points last-u last-v u last-v u v) (device-draw-lines STREAM points :alu alu :dash-pattern line-style :pattern pattern :thickness thickness :line-end-shape line-end-shape :transform nil))))) (setq last-u u last-v v))))) (defclass GRAPH-DATUM-SCATTER-SYMBOLOGY-MIXIN (basic-graph-datum-symbology-mixin basic-graph-data) ((data-symbol :initform :+ :initarg :data-symbol :accessor data-symbol) (symbol-height :initform 10 :initarg :symbol-height :accessor symbol-height)) (:documentation "Provides a datum-style-displayer method that allows data to be displayed in several different symbologies.")) (defmethod symbology-choices append ((self graph-datum-scatter-symbology-mixin)) (list '("Scatter" :value :scatter))) (defmethod datum-style-displayer ((self graph-datum-scatter-symbology-mixin) graph (style (eql :SCATTER))) (declare (ignore graph)) (let* ((data-symbol (data-symbol self)) (symbol-height (values (truncate (symbol-height self) 2))) (pattern (pattern self)) (alu (alu self)) (thickness (thickness self)) (clip-rectangle *clip-rectangle*) (left (pop clip-rectangle)) (right (pop clip-rectangle)) (bottom (pop clip-rectangle)) (top (pop clip-rectangle)) (displayer (symbol-displayer data-symbol alu thickness pattern))) (declare (fixnum left right bottom top) (compiled-function displayer)) (if (< bottom top) (psetq top bottom bottom top)) #'(lambda (stream u v datum) (declare (fixnum u v) (ignore datum)) (when (and u v (<= left u right) (<= top v bottom)) (funcall displayer stream u v symbol-height))))) (defclass dataset-datum-size-mixin () () (:documentation "Produces scatter graphs where each datum could be a different size.")) ;;; Stub. (defmethod datum-size ((dataset dataset-datum-size-mixin) (datum t)) nil) (defmethod datum-style-displayer ((self dataset-datum-size-mixin) graph (style (eql :SCATTER))) (declare (ignore graph)) (let* ((data-symbol (data-symbol self)) (symbol-height (symbol-height self)) (pattern (pattern self)) (alu (alu self)) (thickness (thickness self)) (clip-rectangle *clip-rectangle*) (left (pop clip-rectangle)) (right (pop clip-rectangle)) (bottom (pop clip-rectangle)) (top (pop clip-rectangle)) (displayer (symbol-displayer data-symbol alu thickness pattern))) (declare (fixnum left right bottom top) (compiled-function displayer)) (if (< bottom top) (psetq top bottom bottom top)) #'(lambda (stream u v datum) (declare (fixnum u v)) (when (and u v (<= left u right) (<= top v bottom)) (funcall displayer stream u v (values (truncate (or (datum-size self datum) symbol-height) 2))))))) (defclass GRAPH-DATA-SYMBOLOGY-MIXIN (graph-datum-bar-symbology-mixin graph-datum-step-symbology-mixin graph-datum-line-symbology-mixin graph-datum-scatter-symbology-mixin basic-graph-datum-symbology-mixin) () (:documentation "Provides :SCATTER :LINE :STEP and :BAR symbologies for plotting data.")) (defclass GRAPH-DATA-COLOR-MIXIN () ((color :initform :gold :initarg :color :accessor color))) (defmethod update-alu-for-stream ((self graph-data-color-mixin) (stream t)) "Match the alu to the stream." ;; Don't forget that encapsulation may occur, and the stream may not ;; be a window at all. (continuation-output-size, hardcopy streams, etc.) ;; Therefore specializing the stream argument may be a temptation worth avoiding. (setf (alu self) (alu-for-stream stream (color self)))) (defmethod display-data :before ((self graph-data-color-mixin) (stream t) (graph t)) (update-alu-for-stream self stream)) (defmethod display-legend-dataset :before ((self graph-data-color-mixin) STREAM graph left bottom width height) (declare (ignore graph left bottom width height)) (update-alu-for-stream self stream)) #| HOW AUTO-SCALING WORKS. Auto scaling of a graph can be either :X, :Y, :BOTH, or NIL. For each axis that should be scaled, the graph asks each dataset what limits it wants to contribute. Each dataset can compute its limits in its own way. The graph takes the union of the limits returned. |# (defclass GRAPH-DATA-AUTO-SCALE-MIXIN (basic-graph-data) ; Can this dataset provide auto-scaling info? ((auto-scale? :initform nil :initarg :auto-scale? :accessor auto-scale?)) (:documentation "Allows a dataset to provide auto scale limits")) (defmethod auto-scale-limits ((self t) auto-scale-type xll xur yll yur) ;; Default method (declare (ignore auto-scale-type xll xur yll yur)) (list nil nil nil nil)) (defmethod auto-scale-limits ((self graph-data-auto-scale-mixin) auto-scale-type xll xur yll yur) "Scale graph to minimum and maximum of x axis, y axis or both. If :BOTH the x and y limits will be set to the min or max values in data. If :X the min and max value of x for data with y values between yll and yur will be used. Similarly for :Y. The LIST (xmin xmax ymin ymax) describing the limits is returned." (cond ((not (auto-scale? self)) nil) (auto-scale-type (auto-scale-limits-internal self auto-scale-type xll xur yll yur (data self))))) (defmethod auto-scale-limits-internal ((self graph-data-auto-scale-mixin) type x-left x-right y-bottom y-top the-data) ;; This is called once for the graph and once for each legend dataset. (macrolet ((collect-range (relation min value max) `(progn (when (or (null ,min) (,relation ,value ,min)) (setq ,min ,value)) (when (or (null ,max) (,relation ,max ,value)) (setq ,max ,value))))) (let ((xmin nil) (xmax nil) (ymin nil) (ymax nil)) (map-data-xy self #'(lambda (x y) (declare (downward-function)) (when (or (eq type :both) (and (eq type :x) (<= y-bottom y y-top))) (collect-range < xmin x xmax)) (when (or (eq type :both) (and (eq type :y) (<= x-left x x-right))) (collect-range < ymin y ymax))) the-data) (list xmin xmax ymin ymax)))) (defclass GRAPH-DATA-LIMITS-MIXIN () () (:documentation "Lets a dataset provide :limit-specs when auto scaling. See GRAPH-LIMITS-MIXIN.")) (defmethod limit-specs ((self GRAPH-DATA-LIMITS-MIXIN)) ()) (defmethod AUTO-SCALE-LIMITS :around ((self graph-data-limits-mixin) auto-scale-type xll xur yll yur) "Constrain graph edges to be within limits." (let ((the-limits (limit-specs self)) (stuff (call-next-method SELF auto-scale-type xll xur yll yur))) (let ((xmin (first stuff)) (xmax (second stuff)) (ymin (third stuff)) (ymax (fourth stuff))) (when the-limits (multiple-value-bind (left right bottom top) (apply #'values the-limits) (when xmin (setq xmin (limit-value xmin left))) (when xmax (setq xmax (limit-value xmax right))) (when ymin (setq ymin (limit-value ymin bottom))) (when ymax (setq ymax (limit-value ymax top)))) (when (and xmin xmax (< xmax xmin)) ; When limit spec is ; really inappropriate (psetq xmin xmax xmax xmin)) ; for the data, min max ; gets trashed. (when (and ymin ymax (< ymax ymin)) (psetq ymin ymax ymax ymin))) (list xmin xmax ymin ymax)))) (defclass GRAPH-DATA-ADD-DATUM-MIXIN (basic-graph-data) () (:Documentation "Provides a protocol for adding a individual datum to the dataset.")) (defmethod add-datum ((self graph-data-add-datum-mixin) datum) "Add a datum to the end of the data." (vector-push-extend datum (data self))) (defmethod display-datum ((self GRAPH-DATA-ADD-DATUM-MIXIN) graph STREAM datum displayer) (let ((H (sheet-inside-height stream))) (multiple-value-bind (x y) (datum-position self datum) (multiple-value-setq (x y) (xy-to-uv graph x y)) (funcall (the compiled-function displayer) stream x (- H (the fixnum y)) datum)))) (defmethod prepare-graph-for-datum ((self GRAPH-DATA-ADD-DATUM-MIXIN) graph stream datum displayer) "Here is your chance to scroll the graph, if necessary, before displaying." (when (and graph (not (multiple-value-bind (x y) (datum-position self datum) (is-inside graph x y)))) ;; see method AUTO-SCALE-EXTENSIONS (setf (auto-scale-needed graph) t) (refresh graph STREAM) ;; Cached clip rectangle is now invalid, need to make a new displayer (setq displayer (datum-displayer self graph)) ;; This initializes the displayer: (display-datum self graph stream datum displayer)) displayer) (defmethod add-and-display-datum ((self GRAPH-DATA-ADD-DATUM-MIXIN) graph STREAM datum displayer) "Add and display DATUM." ;; displayer is the function you get from the DATUM-DISPLAYER method. (add-datum self datum) (when (and graph (displayed? graph)) (setq displayer (prepare-graph-for-datum self graph stream datum displayer)) (display-datum self graph STREAM datum displayer)) displayer) (defclass simple-data-statistics-mixin () () (:documentation "Provide some commonly used statistical metrics.")) (defmethod x-mean ((dataset simple-data-statistics-mixin)) (let ((sumx 0) (count 0)) (map-data-xy dataset #'(lambda (x y) (declare (downward-function) (ignore y)) (incf sumx x) (incf count)) (data dataset)) (if (zerop count) (values nil 0) (values (/ sumx (float count)) count)))) (defmethod y-mean ((dataset simple-data-statistics-mixin)) (let ((sumy 0) (count 0)) (declare (fixnum count)) (map-data-xy dataset #'(lambda (x y) (declare (downward-function) (ignore x)) (incf sumy y) (incf count)) (data dataset)) (if (zerop count) (values nil 0) (values (/ sumy (float count)) count)))) (defmethod x-mean-and-stdev ((dataset simple-data-statistics-mixin)) (multiple-value-bind (meanx count) (x-mean dataset) (let ((sumsqx 0)) (if (= count 1) (values meanx 0) (progn (map-data-xy dataset #'(lambda (x y) (declare (downward-function) (ignore y)) (incf sumsqx (expt (- x meanx) 2))) (data dataset)) (values meanx (sqrt (/ sumsqx (float (1- count)))))))))) (defmethod y-mean-and-stdev ((dataset simple-data-statistics-mixin)) (multiple-value-bind (meany count) (y-mean dataset) (let ((sumsqy 0)) (if (= count 1) (values meany 0) (progn (map-data-xy dataset #'(lambda (x y) (declare (downward-function) (ignore x)) (incf sumsqy (expt (- y meany) 2))) (data dataset)) (values meany (sqrt (/ sumsqy (float (1- count)))))))))) (defmethod x-min-and-max ((dataset simple-data-statistics-mixin)) (let (minx maxx) (map-data-xy dataset #'(lambda (x y) (declare (downward-function) (ignore y)) (when (or (not minx) (> minx x)) (setq minx x)) (when (or (not maxx) (< maxx x)) (setq maxx x))) (data dataset)) (values minx maxx))) (defmethod y-min-and-max ((dataset simple-data-statistics-mixin)) (let (miny maxy) (map-data-xy dataset #'(lambda (x y) (declare (downward-function) (ignore x)) (when (or (not miny) (> miny y)) (setq miny y)) (when (or (not maxy) (< maxy y)) (setq maxy y))) (data dataset)) (values miny maxy))) (defclass gated-data (graph-data) ((corners :initform nil :initarg :corners :accessor corners)) (:documentation "A type of dataset that 'gates' or filters a source dataset. A point from the source dataset passes through gate if it is contained within a region in xy space. A region is defined by an arbitrary list of xy pairs, defining a closed polygon that need not be convex. [Used by region annotations.]")) (defun point-in-polygon (x y map-polygon polygon) "Returns T if point X,Y is inside a closed boundary. Points on the boundary edge are ambiguously either inside or outside. The algorithm counts the number of line segements that intersect the semi-infinite line from (x,y) to (+infinity,y). If there is an odd number of such segements, the point is inside the polygon. The function MAP-POLYGON maps a function over consecutive line segments (X1 Y1 X2 Y2) of the polygon, such that the first point is the same as the last. (The polygon need not be convex.) See: Shimrat, M., 1962, Algorithm 112: position of point relative to polygon, CACM,5,434. Hall, J.H., 1975, PTLOC - A FORTRAN subroutine for determining the position of a point relative to a closed boundary, Math. Geol., 7, 75-79. Anderson, K.R., 1975, Letter to the editor of Math. Geol. The final version of this algorithm followed from discussions with David Fitterman of the US Geological Survey, Jan 1975." (let ((point-in NIL)) (funcall map-polygon #'(lambda (x1 y1 x2 y2) (if (eq (<= y y1) (> y y2)) ; Segement crosses ray. (when (and (not (= y1 y2)) ; Ignore horizontal segement. (< (- x x1 (/ (* (- y y1) (- x2 x1)) (- y2 y1))) ; Point is to left. 0)) ;; (print (list x1 y1 x2 y2)) (setq point-in (not point-in))))) polygon) point-in)) (defmethod surrounded-p ((object gated-data) x y) (point-in-polygon x y #'map-polygon-edges (corners object))) (defmethod map-data ((dataset gated-data) function (data t)) ;; assumes DATA argument is itself a dataset. (declare (compiled-function function)) (map-data data #'(lambda (datum) (declare (downward-function)) (multiple-value-bind (x y) (datum-position data datum) (if (surrounded-p dataset x y) (funcall function datum)))) (data data))) (defmethod map-data-xy ((dataset gated-data) function (data t)) ;; assumes DATA argument is itself a dataset. (declare (compiled-function function)) (map-data data #'(lambda (datum) (declare (downward-function)) (multiple-value-bind (x y) (datum-position data datum) (if (surrounded-p dataset x y) (funcall function x y)))) (data data))) (defmethod datum-position ((dataset gated-data) datum) (datum-position (data dataset) datum)) (defmethod create-gated-dataset (graph dataset stream &optional (type 'gated-data) corners) (or corners (and graph (setq corners (select-xy-polygon graph stream)))) (when corners (make-instance type :data dataset :symbologies (symbologies dataset) :corners corners))) ;;; Where should this be? (defmethod select-xy-polygon (graph stream) (let ((points (select-screen-polygon stream)) (xy nil)) (if points (dolist (point points xy) (let ((x (car point)) (y (second point))) (multiple-value-setq (x y) (screen-to-uv stream x y)) (multiple-value-setq (x y) (uv-to-xy graph x y)) (push (list x y) xy)))))) ;;; Clim 1.0 requires this be defined before any presentation type ;;; that depends on it. Hence moved here from present.lisp. #+clim-1.0 (defclass dataset-record-element (clim::displayed-output-record-element-mixin) ((dataset :initarg :dataset :accessor dataset) (graph :initarg :graph :accessor graph)) (:documentation "Knows how to replay the output history when the output history wasn't recorded.")) (defvar *repainting-dataset* nil) #+clim-1.0 (defmethod replay-1 ((self dataset-record-element) stream &optional region x-off y-off) (declare (ignore region x-off y-off)) (let ((*repainting-dataset* t)) (display-data (dataset self) stream (graph self)))) #+clim-1.0 (defun record-dataset-record-element (dataset stream graph) ;; This hack puts an instance of dataset-record-element into the ;; output history. The element is supposed to handle ;; repaint events (via replay-1) when we aren't recording ;; output history. (unless *repainting-dataset* (with-new-output-record (stream 'dataset-record-element record :dataset dataset :graph graph) (declare (ignore record)) :done))) (defclass presentable-mixin () ((present-self-p :initform t :initarg :present-self-p :accessor present-self-p) (graph-present-inferiors-p :initform t :initarg :graph-present-inferiors-p :accessor graph-present-inferiors-p))) (defclass presentable-data-mixin (presentable-mixin) ()) (defmethod graph-presentation-type ((self presentable-data-mixin)) 'graph-data) (defmethod display-data :around ((self presentable-data-mixin) STREAM graph) (if (present-self-p self) (with-output-as-presentation (:stream stream :single-box nil :object self :type (graph-presentation-type self) :allow-sensitive-inferiors t) (call-next-method SELF stream graph) #+clim-1.0 (when (dont-record-output-history self) (record-dataset-record-element self STREAM graph))) (progn (call-next-method SELF stream graph) #+clim-1.0 (when (dont-record-output-history self) (record-dataset-record-element self STREAM graph))))) (defmethod display-legend-dataset :around ((self presentable-data-mixin) STREAM graph left bottom width height) ;; you always get the legend mouse-sensitive. (multiple-value-bind (sl st) (uv-to-screen stream left (+ bottom height)) ;; see comment above regarding cursor positioning (with-temporary-cursor-position (stream sl st) (with-output-as-presentation (:stream stream :single-box t :object self :type (graph-presentation-type self) :allow-sensitive-inferiors nil) (call-next-method SELF STREAM graph left bottom width height))))) (defmethod datum-presentation-type ((self presentable-data-mixin) (datum t)) 'expression) (defmethod datum-presentation ((self presentable-data-mixin) datum) ;; Just in case it isn't the datum itself. datum) (defmethod datum-displayer :around ((self presentable-data-mixin) graph) (let ((f (call-next-method self graph))) (if (graph-present-inferiors-p self) #'(lambda (stream u v datum) (with-output-as-presentation (:stream stream :object (datum-presentation self datum) :type (datum-presentation-type self datum)) (funcall f stream u v datum)) (values u v)) f))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/export.lisp0000644000175000017500000001115507750444412023466 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: GRAPH -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :graph) ;;; All the exports of graph in one place. ;;; Functions and methods (eval-when (compile load eval) (export '(make-demo-frame view-graphs display-graph save-postscript-graph display-graphs graph-presentation-type presentation graph-under-presentation present-self-p fill-window-with-graphs graphs-for-slider autoscale-graphs auto-scale-needed auto-scale graph-auto-scale-limits display-data display-datum displayed? datum-position device-draw-line line-style thickness symbologies graph-p graph-data-p map-data map-data-xy missing-data-threshold display erase move refresh zoom-stack copy dump-forms final-dump duplicator-methods duplicate-slots pop-accept-items pop-accept-label popup-accept-forms popup-accept popup-accept-standard-loop graph-under-mouse add-dataset datasets data define-graph-command duplicator-methods xy-inside set-xy-inside xy-to-uv xy-to-stream uv-to-xy screen-to-uv uv-to-screen name annotation point-annotation interval-annotation annotate annotate-graph annotate-interval annotate-point annotate-data-interval annotate-data-point description-choices default-text-style x-label y-label ) 'graph)) ;;; color stuff (eval-when (compile load eval) (export '(color color-presentation alu alu-for-color alu-for-stream *color-specifications* device-draw-aluf device-line-thickness device-line-end-shape device-line-joint-shape device-filled-p device-fill-pattern %draw %erase %flip initialize-color-system))) ;;; classes of data (eval-when (compile load eval) (export '(graph-data timeseries-data presentable-data-mixin graph-data-limits-mixin graph-data-auto-scale-mixin graph-data-color-mixin graph-data-symbology-mixin graph-data-add-datum-mixin presentable-graph-data-legend-mixin graph-data-legend-mixin basic-list-datum-mixin graph-data-list-map-mixin essential-graph-data-map-mixin basic-graph-data equation-data sample-data histogram-data MULTIDIMENSIONAL-DATA) 'graph)) ;;; classes of graphs (eval-when (compile load eval) (export '(graph annotated-graph presentable-graph-mixin graph-datasets-ob-mixin graph-datasets-mixin graph-legend-mixin graph-relative-size-mixin graph-zoom-mixin graph-slider-interaction-mixin graph-slider-mixin graph-handle-mouse-mixin graph-mouse-resolution-mixin graph-auto-scale-ob-mixin graph-auto-scale-extensions-ob-mixin graph-auto-scale-extensions-mixin graph-limits-mixin graph-auto-scale-mixin graph-grid-ob-mixin graph-grid-mixin horizontal-y-border-mixin vertical-y-border-mixin graph-border-ob-mixin graph-border-mixin basic-graph-ob-mixin basic-graph graph-with-reselectable-axes named-object named-mixin) 'graph)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/equation.lisp0000644000175000017500000003546607750444412024005 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: GRAPH -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :graph) #|| ;;; Example equations. (setq e (make-instance 'equation-data :equation '(* (sin (* a x)) (sin (* b x))) :variable 'x :min 0 :max 10 :increment .1 :parameters '((a 2) (b 3)))) (setq f (make-instance 'equation-data :equation '(+ (* a x) (* b (^ x 2)) (* c (^ x 3))) :variable 'x :min 0 :max 10 :increment .1 :parameters '((a 1) (b 5) (c -.5)))) ||# (defclass EQUATION-DATA (graph-data) ((equation :initform nil :initarg :equation :reader equation) (variable :initform 'x :initarg :variable :accessor variable) (min :initform 0 :initarg :min) (max :initform 100 :initarg :max) (increment :initform nil :initarg :increment) (parameters :initform nil :initarg :parameters) (data-function :initform nil :initarg :data-function)) (:default-initargs :symbologies '(:line) :line-style 0) (:documentation "Equations of a single variable.")) (defmethod make-name :around ((self equation-data)) (with-slots (name equation) self (if (not name) (if (not equation) (call-next-method) (setq name (format nil "~a" equation)))))) (defmethod initialize-instance :after ((self equation-data) &key &allow-other-keys) (with-slots (equation) self (when equation (setf (equation self) equation)))) (defmethod (setf equation) (new-equation (self equation-data)) (with-slots (equation parameters) self (setf equation new-equation) (merge-parameters self) (setf (name self) (format nil "~a" (subst-param parameters new-equation))))) (defmethod merge-parameters ((self equation-data)) "Merge the current parameters with any new parameters." (with-slots (parameters equation variable data-function) self (let ((found ())) (labels ((find-parameters (an-equation a-variable) "Given an EQUATION in some VARIABLE, extract a list of PARAMETERS." (cond ((null an-equation) found) ((symbolp an-equation) (if (eq an-equation a-variable) found (if (member an-equation found) found (progn (push an-equation found) found)))) ((listp an-equation) (dolist (arg (cdr an-equation)) (find-parameters arg a-variable)) found)))) (setq parameters (loop with parm-ass for parm in (find-parameters equation variable) when (setq parm-ass (assoc parm parameters :test #'eq)) collect parm-ass else collect (list parm 0)))) (setq data-function (let ((*terminal-io* #+lucid lcl::*initial-io* #-lucid *terminal-io*)) (compile nil `(lambda (,variable ,@(map 'list #'(lambda (p) (first p)) parameters)) ,equation))))))) (defmethod (setf variable) :after (new (self equation-data)) (declare (ignore new)) (merge-parameters self)) (defmethod map-data ((self equation-data) function the-data) (declare (ignore the-data)) (with-slots (parameters increment data-function max min) self (let ((p1 (list nil nil)) ; Needless consing avoided. (p2 (list nil nil)) (args (map 'list #'(lambda (p) (second p)) parameters))) (if (null increment) (setq increment (/ (- max min) 100))) (loop for x from min to max by increment do (setf (first p1) x (second p1) (apply data-function x args)) (funcall function p1) (psetq p1 p2 p2 p1))))) (defmethod datum-presentation ((self equation-data) datum) (multiple-value-bind (x y) (datum-position self datum) (list x y))) ; copy equation data (defun subst-param (alist form &aux car cdr) (cond ((symbolp form) (cond ((setq car (assoc form alist :test #'eq)) (cadr car)) (t form))) ((listp form) (setq car (subst-param alist (car form)) cdr (subst-param alist (cdr form))) (cond ((and (eq (car form) car) (eq (cdr form) cdr)) form) (t (cons car cdr)))) (t form))) (defclass equation-data-lisp-title-mixin () () (:documentation "Automatically generate a title which is a lisp expression for the equation.")) (defmethod title ((self equation-data-lisp-title-mixin)) (with-slots (parameters equation) self (format nil "~a" (subst-param parameters equation)))) (defclass z-transform-data (equation-data) () (:default-initargs :variable 'z :min 0 :max 0.5 :increment .01)) (defmethod map-data ((self z-transform-data) function the-data) (declare (ignore the-data)) (with-slots (parameters data-function min max increment) self (let ((p1 (list nil nil)) ; Needless consing avoided. (p2 (list nil nil)) (args (map 'list #'(lambda (p) (second p)) parameters))) (loop for x from min to max by increment do (setf (first p1) x (second p1) (abs (apply data-function (cis (* x #.(coerce pi 'single-float))) args))) (funcall function p1) (psetq p1 p2 p2 p1))))) (defclass GRAPH-SAMPLE-DATA-MIXIN () ((sample-data :initform () :initarg :sample-data :accessor sample-data)) ) (declare-required-method compute (SELF)) (defmethod initialize-instance :after ((self graph-sample-data-mixin) &key) (when (sample-data self) (compute self))) ;;; BW: this was removed because it was computing twice... (defmethod (setf sample-data) :after (new (self graph-sample-data-mixin)) (when new (compute self))) (defclass histogram-data (graph-sample-data-mixin graph-data) ; KRA: Replace with ST:ESSENTIAL-SAMPLE ((min :initform nil :initarg :min) (max :initform nil :initarg :max) (bin-count :initform nil :initarg :bin-count) (bin-size :initform nil :initarg :bin-size) (bins :initform () :initarg :bins)) (:default-initargs :symbologies '(:bar)) (:documentation "A Histogram of a sample of data.")) (defmethod sample-limits ((self histogram-data)) (with-slots (sample-data) self (loop for datum in sample-data minimize datum into sample-min maximize datum into sample-max finally (return (values sample-min sample-max))))) (defmethod compute ((self histogram-data)) "Compute the histogram." (with-slots (min max bin-count bin-size bins sample-data) self (unless (and min max) (multiple-value-bind (sample-min sample-max) (sample-limits self) (setq min (or min sample-min)) (setq max (or max sample-max)))) (setq bin-count (or bin-count (values (truncate (max 20 (sqrt (length sample-data)))))) bin-size (or bin-size (float (/ (- max min) bin-count)))) ;; Force bar-width to be the "right" size, regardless of what the user wants. (setf (bar-width self) bin-size) (if (or (null bins) (< (length bins) bin-count)) ; !KRA: Should return old array. (setq bins (make-array bin-count :initial-element 0)) (fill bins 0)) (loop with bin for value in sample-data do (setq bin (values (truncate (- value min) bin-size))) ;; pile all data outside min and max into the first and last bins: (incf (aref bins (max 0 (min (1- bin-count) bin))))))) (defmethod data ((self histogram-data)) (with-slots (sample-data bin-count bin-size bins min) self (when sample-data (loop for bin from 0 to (1- bin-count) collect `(,(+ min (* bin bin-size)) ,(aref bins bin)))))) (defun gaussian-random-sample (n) ;; Random sample of size n from a Gaussian (0 1) population. (loop repeat n collect (gaussian-random 0 1))) ;;; The following dataset (MULTIDIMENSIONAL-DATA) and graph class ;;; (GRAPH-WITH-RESELECTABLE-AXES) go together. They are for the case where ;;; individual datums are not really xy pairs but more like feature vectors with many ;;; dimensions. You provide two accessor functions, one each for the x and y axes, ;;; using the SET-AXES function. Those two axes will then be displayed. SET-AXES ;;; may then be used to change the dimensions being displayed without having to make ;;; a new graph. (defclass MULTIDIMENSIONAL-DATA (graph-data-dither-mixin accessor-datum-mixin graph-data) () (:default-initargs :symbologies '(:scatter)) (:documentation "Useful if your datums have several dimensions. Use X and Y accessor functions to control which ones you get on a graph.")) (defmethod set-axes ((self MULTIDIMENSIONAL-DATA) x-accessor y-accessor) (setf (x-accessor self) x-accessor (y-accessor self) y-accessor)) (defclass reselectable-axes-mixin () ((x-accessor :initform nil :initarg :x-accessor :accessor x-accessor) (y-accessor :initform nil :initarg :y-accessor :accessor y-accessor))) (defmethod set-axes ((self reselectable-axes-mixin) x-accessor y-accessor) (setf (x-accessor self) x-accessor (y-accessor self) y-accessor)) (defclass graph-with-reselectable-axes (reselectable-axes-mixin annotated-graph) () (:default-initargs :auto-scale :both :show-legend nil) (:documentation "Useful if your datums have several dimensions. Use X and Y accessor functions to control which ones you get on a graph. Datasets must handle the SET-AXES method.")) (defmethod label-this-accessor ((self graph-with-reselectable-axes) accessor) (present-to-string accessor)) (defmethod set-axes :after ((self graph-with-reselectable-axes) x-accessor y-accessor) (dolist (d (datasets self)) (set-axes d x-accessor y-accessor)) (setf (x-label self) (label-this-accessor self x-accessor) (y-label self) (label-this-accessor self y-accessor)) ;; flush old annotations... ;; (setf (annotations self) nil) #-genera (setf (auto-scale self) :both) #+genera (funcall #'(setf auto-scale) self :both)) ; +++ Unresolved genera problem? (defmethod initialize-instance :after ((self graph-with-reselectable-axes) &key) (when (and (x-accessor self) (y-accessor self)) (set-axes self (x-accessor self) (y-accessor self)))) ;; EQUATIONS FOR A LINE: ;; ;; 1. y = m*x + b ;; Parameters: m, b. ;; blows up when m ~ 1/0; therefore looser. ;; ;; Redundent represtentations are safer: ;; 2. c*y - s*x = r; m = s/c ; sqrt (c^2 + s^2) = 1; r = c*b ;; ;; 3. A*x + B*y = C; A = -s; B = c; C = r = c*b = B*b. ;; Where [a,b] is a unit vector and c is the distance from the origin ;; to the line. ;; m = s/c = -A/B ; b = C/B. ;; (defun line-between-points (x1 y1 x2 y2 &aux c s l) ;; Returns values A B C s.t. A*x + b*y = C is the equation of the line between points ;; (X1 Y1), (X2 Y2). (setq s (- (- y2 y1)) c (- x2 x1) l (sqrt (+ (expt c 2) (expt s 2))) s (/ s l) c (/ c l)) (values s c (+ (* s x1) (* c y1)))) (defun line-slope-intercept (a b c) ;; Returns values of equivalent Slope and intercept given the line A*x + By = C. (if (zerop b) (values nil nil) (values (/ (- a) b) (/ c b)))) (defun line-y-internal (x a b c) ;; Returns NIL when Y cannot be determined. (unless (zerop b) (/ (- c (* a x)) b))) (defun line-x-internal (y a b c) ;; Returns NIL when X cannot be determined. (unless (zerop a) (/ (- c (* b y)) a))) (defclass LINE-MIXIN () ((line-a :initform nil :initarg :line-a) (line-b :initform nil :initarg :line-b) (line-c :initform nil :initarg :line-c)) ) (defmethod line ((self line-mixin)) (with-slots (line-a line-b line-c) self (values line-a line-b line-c))) (defmethod set-line-between-points ((self line-mixin) x1 y1 x2 y2) (with-slots (line-a line-b line-c) self (multiple-value-setq (line-a line-b line-c) (line-between-points x1 y1 x2 y2)))) (defmethod set-line ((self line-mixin) a b c) (with-slots (line-a line-b line-c) self (setq line-a a line-b b line-c c))) (defmethod line-y ((self line-mixin) x) (with-slots (line-a line-b line-c) self (line-y-internal x line-a line-b line-c))) (defmethod line-x ((self line-mixin) y) (with-slots (line-a line-b line-c) self (line-x-internal y line-a line-b line-c))) (defmethod slope-intercept ((self line-mixin)) (with-slots (line-a line-b line-c) self (line-slope-intercept line-a line-b line-c))) (defmethod set-slope-intercept ((self line-mixin) slope intercept) (with-slots (line-a line-b line-c) self (multiple-value-setq (line-a line-b line-c) (line-between-points 0.0 intercept 1.0 (+ slope intercept))))) (defclass LINE-DATA (line-mixin ;; A simplified version for GRAPH-DATA graph-data-color-mixin graph-datum-line-symbology-mixin basic-graph-datum-symbology-mixin basic-graph-data) ()) #+broken (defmethod display-data ((self line-data) ignore) (declare (ignore ignore)) (with-slots (line-a line-b line-c graph line-style alu) self (multiple-value-bind (left right bottom top) (xy-edges graph) (cond ((> (abs line-a) (abs line-b)) (move graph (line-x self bottom) bottom) (draw graph STREAM (line-x self top) top line-style alu)) (t (move graph left (line-y self left)) (draw graph STREAM right (line-y self right) line-style alu)))))) ;;; Specialize this by providing a :COMPUTE method. (defclass BASIC-LINE-FIT (graph-sample-data-mixin line-data) ()) #|| ;;; Following is probably incomplete. (defclass l2-fit () (basic-line-fit)) (defmethod fit ((self l2-fit)) (loop with x-mean = 0 and y-mean = 0 and points = (data dataset) do x-mean) ) ;;; m = xy-mean // xx-mean; b = y-mean - m * x-mean (defmethod fit-x-mean ((self l2-fit)) (setq slope 0) (setq intercept (loop for data-pair in (data dataset) with x-sum = 0 and x-count = 0 do (setq x-count (1+ x-count)) (setq x-sum (+ x-sum (car data-pair))) finally (return (fixr (// x-sum x-count)))))) (defmethod fit-y-mean ((self l2-fit)) (setq slope 10.e16) (setq intercept (loop for data-pair in (data dataset) with y-sum = 0 and y-count = 0 do (setq y-count (1+ y-count)) (setq y-sum (+ y-sum (cadr data-pair))) finally (return (fixr (// y-sum y-count)))))) ||# cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Scigraph/scigraph/draw.lisp0000600000175000017500000006102210423413302023051 0ustar pdmpdm;;; -*- Syntax: Common-lisp; Package: GRAPH -*- #| Copyright (c) 1987-1993 by BBN Systems and Technologies, A Division of Bolt, Beranek and Newman Inc. All rights reserved. Permission to use, copy, modify and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice of BBN Systems and Technologies, this paragraph and the one following appear in all copies and in supporting documentation, and that the name Bolt Beranek and Newman Inc. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Any distribution of this software or derivative works must comply with all applicable United States export control laws. BBN makes no representation about the suitability of this software for any purposes. It is provided "AS IS", without express or implied warranties including (but not limited to) all implied warranties of merchantability and fitness for a particular purpose, and notwithstanding any other provision contained herein. In no event shall BBN be liable for any special, indirect or consequential damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software, even if BBN Systems and Technologies is advised of the possiblity of such damages. |# (in-package :graph) #| GRAPHICS DEVICE PRIMITIVES This defines a simple, easy to port (?), interface to many graphics devices. DEVICE-DRAW-POINT DEVICE-DRAW-LINE DEVICE-DRAW-LINES DEVICE-DRAW-RECTANGLE DEVICE-DRAW-TRIANGLE DEVICE-TEXT COORDINATE SYSTEMS: SCREEN The coordinates used to draw on the graphics stream. This is perhaps a misnomer, it should have been called STREAM coordinates. These are the coordinates that the underlying GUI functions use (e.g. DRAW-LINE, STREAM-POINTER-POSITION*, etc.). Origin is at upper left, x increases to right, y increases downward. UV The coordinate system used by DEVICE-DRAW-* routines to draw on the stream. Origin is in the lower left, x increase to right, y increase upward. [Actually, the UV origin is not at the lower left of the stream, but the lower left of the first viewport. For streams that scroll, graphs that are not placed in the first viewport get a negative V. It would seem that UV coordinates serve the same role as screen coordinates, and UV could probably be phased out without a loss of functionality or convenience. JPM] XY The coordinate system seen on the x and y axes of a graph, as well as the coordinate system used by the datasets. [Historically, mouse coordinates have also been used. However, this coordinate system is highly unportable, and it always ended up being an intermediate stage to some other coordinate system. Thus this coordinate system has been exorcised and should be avoided in the future. JPM 1-29-91.] |# (defmacro uv-to-screen (screen u v) `(values ,u (- (the fixnum (sheet-inside-height ,screen)) (the fixnum ,v)))) (defmacro screen-to-uv (screen u v) `(values ,u (- (the fixnum (sheet-inside-height ,screen)) (the fixnum ,v)))) ;;; Clipping: It is assumed that the underlying graphics system can do real ;;; clipping. We clip lines, and if something will overlap the clip rectangle, we ;;; let the underlying system handle the details. ;;; In General we are constantly fighting with clipping which tends to ;;; grow huge bitmaps (football field sized) if your aren't careful. ;;; So, clip as much as possible ourselves, relying on Genera as ;;; little as possible. So there are macros for specifying the ;;; clip region that the DEVICE- routines and another macro to let ;;; Genera do the clipping after we are sure we don't get a football field. (defvar *CLIP-RECTANGLE* '(0 2000 0 2000) "Screen coordinates of clipping rectangle, left right bottom top. (and (< left right) (< bottom top)) so bottom is above top if you look at screen!!") (defmacro WITH-CLIPPING-SCREEN-RECTANGLE ((stream le re be te) &body body) `(with-stack-list (*clip-rectangle* ,le ,re ,be ,te) ,stream ; Ignored ,@body)) (defmacro WITH-CLIPPING-UV-RECTANGLE ((stream le re be te) &body body) `(multiple-value-bind (.le. .be.) (uv-to-screen ,stream ,le ,be) (multiple-value-bind (.re. .te.) (uv-to-screen ,stream ,re ,te) (with-clipping-screen-rectangle (,stream .le. .re. .te. .be.) ; -y ,@body)))) #+clim (defvar *clim-clip-rectangle* #-clim-2 (make-rectangle* 0 0 1 1) #+clim-2 (make-bounding-rectangle 0 0 1 1) "Reused by with-clipping-internal to reduce consing.") (defmacro WITH-CLIPPING-INTERNAL ((stream) &body body) ;; This does the final clipping details. `(let* ((r *clip-rectangle*) (le (pop r)) (re (pop r)) (be (pop r)) (te (pop r))) #FEATURE-CASE (((not :clim) (graphics:with-clipping-from-output (,stream (draw-rectangle le te re be :stream ,stream )) ,@body)) (:clim-0.9 (with-drawing-options (,stream :clipping-region (make-rectangle* le te re be :reuse *clim-clip-rectangle*)) ,@body)) (:clim-1.0 (let ((.x. *clim-clip-rectangle*)) (setf (slot-value .x. 'clim-utils::min-x) le (slot-value .x. 'clim-utils::min-y) te (slot-value .x. 'clim-utils::max-x) re (slot-value .x. 'clim-utils::max-y) be) (with-drawing-options (,stream :clipping-region .x.) ,@body))) (:clim-2 (let ((.x. *clim-clip-rectangle*)) (setf (bounding-rectangle-min-x .x.) le (bounding-rectangle-min-y .x.) te (bounding-rectangle-max-x .x.) re (bounding-rectangle-max-y .x.) be) (with-drawing-options (,stream :clipping-region .x.) ,@body)))))) (eval-when (compile load eval) (proclaim '(inline device-draw-point)) (proclaim '(inline POINT-IN-RECTANGLE-P)) (proclaim '(inline POINT-IN-CLIP-RECTANGLE-P))) (defun POINT-IN-RECTANGLE-P (x y left right bottom top) (declare (fixnum x y left right bottom top)) (and (< left x right) (< bottom y top))) (defun POINT-IN-CLIP-RECTANGLE-P (x y &optional (region *clip-rectangle*)) (point-in-rectangle-p x y (pop region) (pop region) (pop region) (pop region))) #+unused (defun ANY-POINT-IN-CLIP-RECTANGLE-P (xy-pairs &optional (region *clip-rectangle*)) (do ((xy xy-pairs (cddr xy))) ((null xy) nil) (when (point-in-clip-rectangle-p (first xy) (second xy) region) (return t)))) (defun RECTANGLES-OVERLAP-P (l1 r1 b1 t1 l2 r2 b2 t2) ;; clim does this sort of thing already (assert (and (<= l1 r1) (<= b1 t1) (<= l2 r2) (<= b2 t2))) (macrolet ((intervals-overlap-p (l1 r1 l2 r2) `(not (or (> ,l2 ,r1) (> ,l1 ,r2))))) (and (intervals-overlap-p l1 r1 l2 r2) (intervals-overlap-p b1 t1 b2 t2)))) (defun rectangle-overlaps-clip-rectangle-p (l2 r2 b2 t2) (apply #'rectangles-overlap-p l2 r2 b2 t2 *clip-rectangle*)) #| code: xl xr 9 I 8 I 10 yt ---------------- 1 I 0 I 2 yb ---------------- 5 I 4 I 6 |# (defun %clip-line (x1 y1 x2 y2 xl xr yb yt) ;; After W.M. Newman, and R.F. Sproull, Principles of Interactive Computer ;; Graphics, McGraw-hill, 1973, p. 124 (declare (type (integer -1000000 1000000) x1 y1 x2 y2 xl xr yb yt)) ;; Declaring the range of these integers helps inline more of the functions. JPM. (macrolet ((code (x y) `(logior (if (< ,x xl) 1 (if (> ,x xr) 2 0)) (if (< ,y yb) 4 (if (> ,y yt) 8 0)))) (clip (y1 y2 xl x1 x2) `(setq ,y1 (let ((d (- ,x2 ,x1))) (declare (fixnum d)) (if (zerop d) ,y1 (+ ,y1 (values (truncate (the (integer -1000000 1000000) (* (the (integer -1000000 1000000) (- ,y2 ,y1)) (the (integer -1000000 1000000) (- ,xl ,x1)))) d))))) ,x1 ,xl)) (clip-point (c1 x1 y1 x2 y2) #+original `(unless (zerop ,c1) (if (ldb-test (byte 1 0) ,c1) (clip ,y1 ,y2 xl ,x1 ,x2) (if (ldb-test (byte 1 1) ,c1) (clip ,y1 ,y2 xr ,x1 ,x2))) (if (ldb-test (byte 1 2) ,c1) (clip ,x1 ,x2 yb ,y1 ,y2) (if (ldb-test (byte 1 3) ,c1) (clip ,x1 ,x2 yt ,y1 ,y2)))) `(unless (zerop ,c1) (if (zerop (ldb (byte 1 0) ,c1)) (if (not (zerop (ldb (byte 1 1) ,c1))) (clip ,y1 ,y2 xr ,x1 ,x2)) (clip ,y1 ,y2 xl ,x1 ,x2)) (if (zerop (ldb (byte 1 2) ,c1)) (if (not (zerop (ldb (byte 1 3) ,c1))) (clip ,x1 ,x2 yt ,y1 ,y2)) (clip ,x1 ,x2 yb ,y1 ,y2))))) (let ((c1 (code x1 y1)) (c2 (code x2 y2))) (declare (type (integer 0 9) c1 c2)) (loop (and (zerop c1) (zerop c2) (return (values x1 y1 x2 y2))) (or (zerop (logand c1 c2)) (return nil)) (clip-point c1 x1 y1 x2 y2) (clip-point c2 x2 y2 x1 y1) (setq c1 (code x1 y1) c2 (code x2 y2)))))) (defmacro clip-line-to-clip-rectangle (x1 y1 x2 y2) `(apply #'%clip-line ,x1 ,y1 ,x2 ,y2 *clip-rectangle*)) #+debug (defun clip-test (e length &optional (size 500)) (let ((w size) (h size)) (let ((cx (/ w 2)) (cy (/ h 2))) (scl:send e :expose) (graphics:with-room-for-graphics (e h) (setq w (/ w 4) h (/ h 4)) (draw-rectangle (- cx w) (+ cy h) (+ cx w) (- cy h) :stream e :filled nil) ; Outline clipping region (decf w 1) (decf h 1) (dotimes (i length) (multiple-value-bind (x1 y1 x2 y2) (values (random size) (random size) (random size) (random size)) (draw-line x1 y1 x2 y2 :stream e) (multiple-value-setq (x1 y1 x2 y2) (%clip-line x1 y1 x2 y2 (- cx w) (+ cx w) (- cy h) (+ cy h))) (if x1 (draw-line x1 y1 x2 y2 :stream e :thickness 3)))))))) #+debug (defun clip-test-2 (e length &optional (size 500)) (let ((w size) (h size)) (let ((cx (/ w 2)) (cy (/ h 2))) (scl:send e :expose) (setq w (/ w 4) h (/ h 4)) (device-draw-rectangle e (- cx w) (+ cx w) (- cy h) (+ cy h) :filled nil) ; Outline clipping region (decf w 1) (decf h 1) (with-clipping-uv-rectangle (e (- cx w) (+ cx w) (- cy h) (+ cy h)) (dotimes (i length) (multiple-value-bind (x1 y1 x2 y2) (values (random size) (random size) (random size) (random size)) ;; (device-draw-circle e x1 y1 20) (device-draw-rectangle e x1 x2 y1 y2) (device-draw-line e x1 y1 x2 y2))))))) ;;; "PORTABLE" GRAPHICS DEVICE INTERFACE FOR GRAPHS. #| WITH-GRAPHICS-STYLE lets you set default values of things as if they are keywords. Actually, they are generic functions that may produce side effects. For example a :COLOR may actually change an ALU too. So, we must have WITH-GRAPHICS-STYLE-SAVED save all the state that could be side effected. Actually, the above was just a plan, that didn't work out because you can't make draw on a bitmap. So, although i don't like this, the defaults are currently special variables. Alternatively, i could modify the graphics::drawing-state of the window. Really actually, this plan failed too. We just give you the basic Symbolics defaults without any way to override them. So this is commented out. |# (defvar %dash-pattern 0) (defvar %thickness 0) (defvar %line-end-shape :round) (defvar %line-joint-shape :miter) (defvar %pattern nil) (defmacro WITH-GRAPHICS-STYLE ((stream &rest plist) &body body) (declare (ignore stream)) (flet ((%f (keyword) (intern (format nil "%~A" (string keyword)) 'graph))) `(let ,(loop for p on plist by #'cddr collect `(,(%f (first p)) ,(second p))) ,@body))) (defun DEVICE-DRAW-POINT (stream u v &key (alu %alu) &allow-other-keys) (multiple-value-setq (u v) (uv-to-screen stream u v)) (when (point-in-clip-rectangle-p u v) (draw-point u v :stream stream :alu alu))) #+unused (defun %DEVICE-DRAW-LINE (stream u1 v1 u2 v2 alu) ;; Optimized (hopefully) version of draw-line (multiple-value-setq (u1 v1) (uv-to-screen stream u1 v1)) (multiple-value-setq (u2 v2) (uv-to-screen stream u2 v2)) (draw-line u1 v1 u2 v2 :stream stream :alu alu)) (defconstant *DASH-PATTERN-SIZE* 64 "Length of dashed pattern in pixels.") (defconstant *DASH-STEP-SIZE* (/ *dash-pattern-size* 8)) (defvar *DASH-PATTERNS* #2A((8 7 6 5 4 3 2 1) (7 6 5 4 3 2 1 -1) (5 4 3 2 1 -1 1 -1) (4 3 2 1 -1 2 1 -1) (3 2 1 -1 3 2 1 -1) (3 2 1 -1 1 -1 1 -1) (2 1 -1 2 1 -1 1 -1) (1 -1 1 -1 1 -1 1 -1)) "Dashed line patterns. -1 -> lift pen.") (defvar *dash-pattern-alist* '(("----------------" :value 0) ("------- ------- " :value 1) ("----- - ----- - " :value 2) ("---- -- ---- -- " :value 3) ("--- --- --- --- " :value 4) ("--- - - --- - - " :value 5) ("-- -- - -- -- - " :value 6) ("- - - - - - - - " :value 7)) "Dashed line patterns for menu choosing.") (defun dash-line (style x1 y1 x2 y2 ds &key (stream *standard-output*) (alu %alu) (thickness %thickness) (pattern %pattern)) "Draw a dashed-line between (x1 y1) and (x2 y2) in the given style 0 <= style <= 7." ;;(declare (values ds)) (assert (numberp ds)) (let ((dash-patterns *dash-patterns*) (dash-step-size *dash-step-size*) (dash-pattern-size *dash-pattern-size*)) (setq style (mod style 8)) (flet ((draw-line-piece (a b c d) (draw-line a b c d :stream stream :alu alu :thickness thickness :line-end-shape :butt :pattern pattern))) (if (= 0 style) (progn (draw-line-piece x1 y1 x2 y2) 0.0) (let ((x-last x1) (y-last y1)) (macrolet ((n-steps (i-step) `(abs (aref dash-patterns style ,i-step))) (plot (x y) `(if (< (aref dash-patterns style i-step) 0) ; Pen up? (setq x-last ,x y-last ,y) (progn (draw-line-piece x-last y-last ,x ,y) (setq x-last ,x y-last ,y))))) (let* ((dx (- x2 x1)) ; Motion along line. (dy (- y2 y1)) (length (sqrt (+ (* dx dx) (* dy dy)))) ; Length of line segement. (step-left ; Fraction of step remaining from before. (/ (mod ds dash-step-size) dash-step-size)) (steps-init ; Initial step to take. (n-steps (values (truncate (- (/ ds dash-step-size) step-left)))))) (when (not (zerop length)) (let ((S (/ dash-step-size length))) (setq dx (* dx S) ; DX pixels / step. dy (* dy S))) ; DY pixels / step. (loop for i-step = (values (truncate (- (/ ds dash-step-size) step-left))) then (mod (+ i-step steps) 8) as steps = (n-steps i-step) ; Steps to to take this iteration. for length-so-far ; Length of line drawn so far. = (- (* steps-init dash-step-size) step-left) then (+ length-so-far (* steps dash-step-size)) for x = (+ (- x1 (* step-left dx)) (* dx steps-init)) then (+ x (* dx steps)) for y = (+ (- y1 (* step-left dy)) (* dy steps-init)) then (+ y (* dy steps)) while (< length-so-far length) do (plot x y) finally (plot x2 y2))) (mod (+ ds length) dash-pattern-size)))))))) (defun flip-alu-p (alu) "Determine if this alu represents XOR drawing." #+clim (eq alu :flipping) #-clim (not (cond ((numberp alu) (= alu tv:alu-xor)) ; Black and white. ((symbolp alu) (eq alu :flip)) ((scl:instancep alu) (= (scl:send alu :alu) tv:alu-xor))))) ; Color (defun DEVICE-DRAW-LINE (stream x1 y1 x2 y2 &key (alu %alu) (dash-pattern %dash-pattern) (dash-ds 0) (thickness %thickness) (line-end-shape %line-end-shape) (pattern %pattern) (transform t) &allow-other-keys) "Draw a dashed-line between (x1 y1) and (x2 y2) in the given dash-pattern 0 <= dash-pattern <= 7. Alters instance variables dash-ds and last-style." ;; KRA: Currently, we do not use with-clipping-internal here though for thick lines, ;; we should. We also don't draw caps on thick dashed lines yet. (declare (fixnum x1 y1 x2 y2 dash-pattern)) (let ((end-point-p (flip-alu-p alu))) (when transform (multiple-value-setq (x1 y1) (uv-to-screen stream x1 y1)) (multiple-value-setq (x2 y2) (uv-to-screen stream x2 y2))) (multiple-value-setq (x1 y1 x2 y2) (clip-line-to-clip-rectangle x1 y1 x2 y2)) (if x1 (if (zerop dash-pattern) (progn (draw-line x1 y1 x2 y2 :stream stream :alu alu :thickness thickness :line-end-shape (if end-point-p line-end-shape :no-end-point)) 0.0) (progn (dash-line dash-pattern x1 y1 x2 y2 dash-ds :stream stream :alu alu :thickness thickness :pattern pattern) ;; draw end caps here. )) dash-ds))) ; Don't change ds. (defun device-draw-lines (stream points &rest keys &key &allow-other-keys) (let ((ds (or (getf keys :dash-ds) 0.0))) (do ((points points (cddr points))) ((null (cddr points)) ds) (setq ds (apply #'device-draw-line stream (first points) (second points) (third points) (fourth points) keys))))) ;;; The value of this depends on the lisp implementation. (defconstant *return* #.(elt (format nil "~%") 0)) (defun draw-text-internal (stream u v text &rest keys &key (rotation 0) &allow-other-keys) "Draw text with (left,top) as given, but do the right thing with return characters." (let* ((line-height (stream-line-height stream)) (text-v v) (text-u u) (start 0) (count 0) end (length (length text)) (COS-FACTOR (values (truncate (* line-height (cos rotation))))) (SIN-FACTOR (values (truncate (* line-height (sin rotation)))))) (when (plusp length) (loop (setq END (or (position *return* text :test #'char= :start start) length)) (when (> (- end start) 1) (apply #'draw-string-image (if (or (plusp start) (< end length)) (subseq text start end) ; Gross CONSING! text) (values (truncate text-u)) (values (truncate text-v)) :attachment-y :top :stream stream keys)) (incf count) (incf text-v COS-FACTOR) (incf text-u SIN-FACTOR) (if (= end length) (return)) (setq start (1+ end)))))) (defun device-text (stream x y label &rest keys &key (attachment-y :baseline) &allow-other-keys) ;; Use draw-string-image rather than draw-string so that some callers can ;; provide :rotation. (apply #'draw-string-image label (values (truncate x)) (values (truncate y)) :stream stream :attachment-y attachment-y keys)) (defun symbol-inside-rectangle-p (x y size/2 left right bottom top) (and (< left (- x size/2)) (< (+ x size/2) right) (< bottom (- y size/2)) (< (+ y size/2) top))) (defun symbol-outside-rectangle-p (x y size/2 left right bottom top) (or (< right (- x size/2)) (< (+ x size/2) left) (< top (- y size/2)) (< (+ y size/2) bottom))) (defmacro with-symbol-clipping ((stream u v size/2) &body body) `(if (apply #'symbol-inside-rectangle-p ,u ,v ,size/2 *clip-rectangle*) (progn ,@body) (if (not (apply #'symbol-outside-rectangle-p ,u ,v ,size/2 *clip-rectangle*)) (with-clipping-internal (,stream) ,@body)))) (defun device-draw-diamond (stream u v size &rest keys) "Given screen coordinates, clip and draw a diamond." (declare (fixnum u v size)) (setq size (values (truncate size 2))) (with-symbol-clipping (stream u v size) (let ((points (list u (+ v size) (- u size) v u (- v size) (+ u size) v u (+ v size)))) ;; No stack allocation, please, redisplay needs the list permanently. (apply #'draw-polygon points :stream stream keys)))) (defun device-draw-equilateral-triangle (stream u v side &rest keys) "Given screen coordinates, clip and draw a triangle centered on the given point." (declare (fixnum u v side)) (let* ((x (values (truncate side 2))) (y (values (round (the fixnum x) #.(sqrt 3.0))))) (declare (fixnum x y)) (with-symbol-clipping (stream u v x) (apply #'draw-triangle (- u x) (+ v y) u (- v (the fixnum (* y 2))) (+ u x) (+ v y) :stream stream keys)))) (defun DEVICE-DRAW-CIRCLE (stream u v radius &rest keys) "Given screen coordinates, clip and draw a circle." (declare (fixnum u v radius)) (let ((r (values (truncate radius 2)))) (with-symbol-clipping (stream u v r) (apply #'draw-circle u v radius :stream stream keys)))) (defun DEVICE-DRAW-TRIANGLE (stream u1 v1 u2 v2 u3 v3 &rest keys &key &allow-other-keys) "Given screen coordinates, clip and draw a triangle." (declare (fixnum u1 v1 u2 v2 u3 v3)) (if (or (clip-line-to-clip-rectangle u1 v1 u2 v2) ; Is triangle in clipping region? (clip-line-to-clip-rectangle u2 v2 u3 v3)) (with-clipping-internal (stream) (apply #'draw-triangle u1 v1 u2 v2 u3 v3 :stream stream keys)))) (defun DEVICE-DRAW-RECTANGLE (stream left right bottom top &rest keys &key &allow-other-keys) "Given screen coordinates, clip and draw a rectangle." (declare (fixnum left right bottom top)) (if (< right left) (psetq left right right left)) (if (< bottom top) (psetq top bottom bottom top)) (let ((r *clip-rectangle*)) (setq left (max left (pop r)) right (min right (pop r)) top (max top (pop r)) ; -y bottom (min bottom (pop r))) (when (and (< left right) (< top bottom)) ; Rectangles overlap. (apply #'draw-rectangle left right top bottom :stream stream keys)))) ;;;************************************************** ;;; ;;; MAKE-OPTIMIZED-LINE-DISPLAYER ;;; ;;; Returns a closure capable of drawing a line. The arguments to the closure ;;; are (stream x1 y1 x2 y2). Here we put all our smarts about how to draw lines ;;; as fast as possible. #+clim-0.9 (defun make-optimized-line-displayer (alu thickness record-output-history) (declare (ignore record-output-history)) #'(lambda (stream from-x from-y to-x to-y) (with-drawing-options (stream :line-thickness thickness :ink alu) (w::draw-line*-internal stream from-x from-y to-x to-y)))) #-clim-0.9 (defun make-optimized-line-displayer (alu thickness record-output-history) (let (#+clim (line-style nil)) (cond (record-output-history #'(lambda (stream from-x from-y to-x to-y) #FEATURE-CASE (((not clim) (scl:send stream :draw-line from-x from-y to-x to-y alu)) (clim-1.0 (progn ;; 152 bytes (unless line-style (setq line-style (make-line-style :thickness thickness))) (clim::draw-line-internal stream 0 0 from-x from-y to-x to-y alu line-style))) (clim-2 (progn ;; 192 bytes (unless line-style (setq line-style (make-line-style :thickness thickness))) (with-drawing-options (stream :ink alu :line-style line-style) (medium-draw-line* stream from-x from-y to-x to-y))))))) (t #FEATURE-CASE ((:clim-2 #'(lambda (stream from-x from-y to-x to-y) (unless line-style (setq line-style (make-line-style :thickness thickness))) (clim-internals::draw-line-internal stream 0 0 from-x from-y to-x to-y alu line-style))) ((AND :CLIM-0.9 :XLIB (NOT :GENERA)) (let (drawable gcontext device-transformation xoff yoff) #'(lambda (stream from-x from-y to-x to-y) (unless drawable (multiple-value-setq (drawable gcontext device-transformation) (get-drawing-guts (sheet-medium stream))) (SETF (XLIB:GCONTEXT-LINE-WIDTH GCONTEXT) (max 0 thickness)) (multiple-value-setq (xoff yoff) (transformation-offsets device-transformation))) (xlib:draw-line drawable gcontext (+ xoff from-x) (+ yoff from-y) (+ xoff to-x) (+ yoff to-y) nil)))) ((AND :CLIM-1.0 :XLIB (NOT :GENERA)) (let (drawable gcontext gc device-transformation (xoff 0) (yoff 0)) #'(lambda (stream from-x from-y to-x to-y) (unless drawable (clim::adjust-for-viewport-and-margins stream xoff yoff) (multiple-value-setq (drawable gcontext device-transformation) (get-drawing-guts stream)) (setf gc (xlib:create-gcontext :drawable drawable)) (xlib:copy-gcontext gcontext gc) (SETF (XLIB:GCONTEXT-LINE-WIDTH GCONTEXT) (max 0 thickness)) (setf (xlib:gcontext-foreground gc) (clim::clx-decode-color stream alu))) (xlib:draw-line drawable gc (+ xoff from-x) (+ yoff from-y) (+ xoff to-x) (+ yoff to-y) nil)))) ((not :CLIM) (let (screen carefully x-offset y-offset) #'(lambda (stream x1 y1 x2 y2) (unless (or screen carefully) (cond ((setq carefully (typep stream 'dw::encapsulating-output-stream))) (t (multiple-value-bind (left top) (scl:send stream :visible-cursorpos-limits) (declare (ignore left)) (setq screen (scl:send stream :screen) x-offset (tv:sheet-inside-left stream) y-offset (- (tv:sheet-inside-top stream) top)))))) (if carefully (scl:send stream :draw-line x1 y1 x2 y2 alu t) (tv:prepare-sheet (stream) (scl:send screen :%draw-line (+ x1 x-offset) (+ y1 y-offset) (+ x2 x-offset) (+ y2 y-offset) alu t stream))))))))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Inspector/0000755000175000017500000000000011347763412017660 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Inspector/disassembly.lisp0000644000175000017500000000253210213136525023060 0ustar pdmpdm(in-package :clouseau) ;; The DISASSEMBLE function will print out implementation-specific ;; things to *STANDARD-OUTPUT* in an implementation-specific way. This ;; is generally optimized for console output, and is therefore not the ;; most aesthetically pleasing way for CLIM to display it. This file ;; is where custom disassembly printers are defined. For each ;; implementation, you can define a pretty-printer for the disassembly ;; of a function. ;; With SBCL, we want to cut out the first two characters of every ;; line, which are always going to be "; ", and if anything is left ;; print it. #+sbcl (defun display-disassembly (object pane) (let ((disassembly-string (with-output-to-string (*standard-output*) (disassemble object)))) (with-input-from-string (stream disassembly-string) (with-text-family (pane :fix) (loop for line = (read-line stream nil nil) while line do (let ((shortened-line (subseq line 2))) (when (> (length shortened-line) 0) (fresh-line pane) (princ shortened-line pane)))))))) ;; For Lisps that don't have their own custom display function, we ;; just print the output of DISASSEMBLE and hope it looks decent. #-sbcl (defun display-disassembly (object pane) (let ((*standard-output* pane)) (with-text-family (pane :fix) (fresh-line pane) (disassemble object))))cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Inspector/package.lisp0000644000175000017500000000031210253767453022144 0ustar pdmpdm(defpackage :clouseau (:use :clim-lisp :clim) (:export #:inspector #:inspect-object #:inspect-object-briefly #:define-inspector-command #:inspector-table #:inspector-table-row)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Inspector/test.lisp0000640000175000017500000000702510705412614021520 0ustar pdmpdm;; This is a test file which doesn't properly test anything. It just ;; has a bunch of code which may occasionally be useful for testing ;; Clouseau, if you squint at it. All data dictated by wild whims. (in-package :clouseau) (defclass oddity () ((complex-number :initform #C(1 3) :documentation "Everybody should have a complex number to avoid being picked up for vagrancy." :type complex)) (:documentation "A thing which is odd in some way")) (defclass queer-oddity (oddity) ((spoons :initform "Rusty ones")) (:documentation "An unusually odd oddity")) (defclass salad-mixin () () (:documentation "Fear the salad. Seriously.")) (defstruct historical-event (severity 5 :type (integer 0 10)) (attribute "" :type string) (pirate "" :type string)) (defclass packrat (queer-oddity salad-mixin) ((name :initform "Willy the Packrat" :type (or string symbol) :reader ratname :writer set-ratname) (some-floats :initform '(1.2 2.3 3.4 4.5 5.6 42.0)) (fvector :initform #(67.0d0 3.8d3 2.983454d0 #.pi)) (an-array :initform #2A((1 0 0) (0 1 0) (0 0 1)) :documentation "An identity matrix") (global-fun :initform #'inspector) (reunion :initform (make-historical-event :severity 7 :attribute "Sephiroth!" :pirate "Sephiroth?")) (l :initform #'(lambda (x) (declare (number x)) (1+ x))) (str :initform "A 'tring") (pet :initform (make-instance 'oddity) :accessor pet) (doc-symbol :initform 'documentation) (inspect-o :initform #'inspect-object)) (:documentation "A thing with lots of other things for no good reason")) (inspector (make-instance 'packrat) :new-process t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun add-ages (x y) "Add together two ages in a fast but unsafe manner" (declare (type (integer 1 150) x y) (optimize (speed 3) (safety 0) (debug 1))) (+ x y)) (inspector 'add-ages :new-process t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod print-object ((obj salad-mixin) stream) (print-unreadable-object (obj stream :type t) (format stream "Everybody should have a complex number to avoid being picked up for vagrancy.Everybody should have a complex number to avoid being picked up for vagrancy.Everybody should have a complex number to avoid being picked up for vagrancy.Everybody should have a complex number to avoid being picked up for vagrancy.Everybody should have a complex number to avoid being picked up for vagrancy.Everybody should have a complex number to avoid being picked up for vagrancy.Everybody should have a complex number to avoid being picked up for vagrancy.Everybody should have a complex number to avoid being picked up for vagrancy.Everybody should have a complex number to avoid being picked up for vagrancy.Everybody should have a complex number to avoid being picked up for vagrancy.Everybody should have a complex number to avoid being picked up for vagrancy.Everybody should have a complex number to avoid being picked up for vagrancy."))) (inspector (cons (make-instance 'salad-mixin) 42)) (let ((*print-length* 10) (*print-level* 10) inspected-inspector) (setf inspected-inspector (make-application-frame 'inspector :obj (clim:make-application-frame 'clouseau::inspector :obj 20))) (clim-sys:make-process #'(lambda () (run-frame-top-level inspected-inspector)) :name "Inspector Clouseau (being inspected)") (inspector inspected-inspector :new-process t)) (let ((ht (make-hash-table))) (setf (gethash 'foo ht) 42 (gethash 'bar ht) 666) (inspector ht))cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Inspector/inspector.lisp0000644000175000017500000010524611345155772022571 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLOUSEAU -*- ;;; (c) copyright 2005 by ;;; Robert Strandh (strandh@labri.fr) ;;; (c) copyright 2005 by ;;; Vincent Arkesteijn ;;; (c) copyright 2005 by ;;; Peter Scott (sketerpot@gmail.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; CLIM inspector application (in-package :clouseau) (define-modify-macro togglef () not) (define-application-frame inspector () ((dico :initform (make-hash-table) :reader dico) (cons-cell-dico :initform (make-hash-table) :reader cons-cell-dico) (disassembly-dico :initform (make-hash-table) :reader disassembly-dico :documentation "A hash table specifying which functions should display disassembly") (print-length :initform (make-hash-table) :reader print-length :documentation "A hash table mapping list objects to their specific print lengths, if they have one.") (obj :initarg :obj :reader obj :documentation "The object being inspected")) (:pointer-documentation t) (:panes (app :application :width 600 :height 500 :scroll-bars nil :text-style (make-text-style :sans-serif :roman :normal) :display-function 'display-app) (int :interactor :width 600 :height 100 :max-height 100)) (:layouts (default (vertically () (scrolling () app) int)))) (defmethod initialize-instance :after ((frame inspector) &rest args) (declare (ignore args)) (setf (gethash (obj frame) (dico frame)) t)) ;; Remember the scrolling state between redisplays. (defmethod redisplay-frame-panes :around ((frame inspector) &key force-p) (declare (ignore force-p)) ;; `Make-clim-stream-pane' creates bizarro object hierarchies, so ;; getting the actual scrollable is not obvious. (let* ((scrollable-pane (sheet-parent (find-pane-named frame 'app))) (viewport (pane-viewport scrollable-pane))) (multiple-value-bind (x-displacement y-displacement) (transform-position (sheet-transformation scrollable-pane) 0 0) (call-next-method) (scroll-extent scrollable-pane (min (- x-displacement) (- (bounding-rectangle-width scrollable-pane) (bounding-rectangle-width viewport))) (min (- y-displacement) (- (bounding-rectangle-height scrollable-pane) (bounding-rectangle-height viewport))))))) (defun inspector (obj &key (new-process nil)) (flet ((run () (let ((*print-length* 10) (*print-level* 10)) (run-frame-top-level (make-application-frame 'inspector :obj obj))))) (when (typep *application-frame* 'inspector) (restart-case (error "Clouseau called from inside Clouseau, possibly infinite recursion") (continue () :report "Continue by starting a new Clouseau instance") (abort-clouseau () :report "Abort this call to Clouseau" (return-from inspector)))) (if new-process (clim-sys:make-process #'run :name (format nil "Inspector Clouseau: ~S" obj)) (run)) obj)) (defparameter *inspected-objects* '() "A list of objects which are currently being inspected with INSPECT-OBJECT") (defgeneric inspect-object-briefly (object pane) (:documentation "Inspect an object in a short form, displaying this on PANE. For example, rather than displaying all the slots of a class, only the class name would be shown.")) (defgeneric inspect-object (object pane) (:documentation "Inspect an object, displaying it on PANE. This can be as verbose as you like; the important thing is that all the information is present.")) (defmethod inspect-object :around (object pane) (cond ((member object *inspected-objects*) (with-output-as-presentation (pane object (presentation-type-of object)) (princ "===" pane))) ; Prevent infinite loops ((not (gethash object (dico *application-frame*))) (inspect-object-briefly object pane)) (t (let ((*inspected-objects* (cons object *inspected-objects*)) (*print-length* (or (gethash object (print-length *application-frame*)) *print-length*))) (call-next-method))))) ;; This behavior should be overridden by methods for specific object ;; types that have a more informative short representation. For ;; example, the symbol FOO would be printed as "FOO" instead of "...", ;; since that's just as short and more informative. When it's clicked ;; on, it can then go to a more verbose view. (defmethod inspect-object-briefly (object pane) (with-output-as-presentation (pane object (presentation-type-of object)) (princ "..." pane))) (defmethod inspect-object (object pane) (with-output-as-presentation (pane object (presentation-type-of object)) (prin1 object pane))) (define-presentation-type settable-slot () :inherit-from t) (define-presentation-type cons () :inherit-from t) (define-presentation-type long-list-tail () :inherit-from t) (define-presentation-method present (object (type settable-slot) stream (view textual-view) &key acceptably for-context-type) (declare (ignore acceptably for-context-type)) (format stream "~s" (cdr object))) (defmacro with-heading-style ((stream) &body body) "Cause text output from BODY to be formatted in a heading font. This could be boldface, or a different style, or even another font." `(with-text-face (,stream :bold) ,@body)) (defmacro inspector-table ((object pane) header &body body) "Present OBJECT in tabular form on PANE, with HEADER evaluated to print a label in a box at the top. BODY should output the rows of the table, possibly using INSPECTOR-TABLE-ROW." (let ((evaluated-pane (gensym "pane")) (evaluated-object (gensym "object"))) `(let ((,evaluated-pane ,pane) (,evaluated-object ,object)) (with-output-as-presentation (pane ,evaluated-object (presentation-type-of ,evaluated-object) :single-box t) (formatting-table (,evaluated-pane) (formatting-column (,evaluated-pane) (formatting-cell (,evaluated-pane) (surrounding-output-with-border (,evaluated-pane) (with-heading-style (,evaluated-pane) ,header))) (formatting-cell (,evaluated-pane) (formatting-table (,evaluated-pane) ,@body)))) (print-documentation (if (eql (class-of ,evaluated-object) (find-class 'standard-class)) ,evaluated-object (class-of ,evaluated-object)) ,evaluated-pane))))) (defmacro inspector-table-row ((pane) left right) "Output a table row with two items, produced by evaluating LEFT and RIGHT, on PANE. This should be used only within INSPECTOR-TABLE." (let ((evaluated-pane (gensym "pane"))) `(let ((,evaluated-pane ,pane)) (formatting-row (,evaluated-pane) (formatting-cell (,evaluated-pane :align-x :right) (with-heading-style (,evaluated-pane) ,left)) (formatting-cell (,evaluated-pane) ,right))))) (defmacro inspector-table-rows ((pane) &body rows) "Output a bunch of rows with INSPECTOR-TABLE-ROW on PANE. Each row is a list of a label and a value." (let ((evaluated-pane (gensym "pane"))) `(let ((,evaluated-pane ,pane)) ,@(loop for row in rows collect (destructuring-bind (label value) row `(inspector-table-row (,evaluated-pane) (princ ,label ,evaluated-pane) (inspect-object ,value ,evaluated-pane))))))) ;; The error handler shouldn't be necessary, but it works around an ;; ACL bug and shouldn't mess anything up on other lisps. The warning ;; handler is there in case DOCUMENTATION raises a warning, to tell ;; lisp that we don't care and it shouldn't go alarming the user. (defun print-documentation (object pane) "Print OBJECT's documentation, if any, to PANE" (when (handler-case (documentation object t) (error ()) (warning ())) (with-heading-style (pane) (format pane "~&Documentation: ")) (princ (documentation object t) pane))) (defun display-class-superclasses (class pane) "Display the superclasses of CLASS with an INSPECTOR-TABLE-ROW" (when (clim-mop:class-direct-superclasses class) (inspector-table-row (pane) (princ "Superclasses" pane) (inspect-vertical-list (clim-mop:class-direct-superclasses class) pane)))) (defun display-class-subclasses (class pane) "Display the subclasses of CLASS with an INSPECTOR-TABLE-ROW" (when (clim-mop:class-direct-subclasses class) (inspector-table-row (pane) (princ "Subclasses" pane) (inspect-vertical-list (clim-mop:class-direct-subclasses class) pane)))) (defun display-object-slot (object slot pane &key display-lists-vertically) "Display a slot of OBJECT onto PANE in the way normally used when inspecting standard objects. SLOT must be a MOP SLOT-DEFINITION object. If DISPLAY-LISTS-VERTICALLY is t and the slot value is a list, it will be displayed with INSPECT-VERTICAL-LIST." (let ((slot-name (clim-mop:slot-definition-name slot))) (inspector-table-row (pane) (with-output-as-presentation (pane (cons object slot-name) 'settable-slot) (format pane "~a:" slot-name)) (if (slot-boundp object slot-name) (let ((slot-value (slot-value object slot-name))) (if (and display-lists-vertically (listp slot-value)) (inspect-vertical-list slot-value pane :honor-dico t) (inspect-object slot-value pane))) (format pane "#"))))) (defun inspect-structure-or-object (object pane) "Inspect a structure or an object. Since both can be inspected in roughly the same way, the common code is in this function, which is called by the INSPECT-OBJECT methods for both standard objects and structure objects." (let ((class (class-of object))) (inspector-table (object pane) (print (class-name class) pane) ;; Display superclasses and subclasses (display-class-superclasses class pane) (display-class-subclasses class pane) (dolist (slot (reverse (clim-mop:class-slots class))) (display-object-slot object slot pane))))) (defun inspect-standard-class (object pane) "Inspect a STANDARD-CLASS. This works almost the same way as inspecting a standard object, but with a few differences. This should also be used to inspect BUILD-IN-CLASSes." (let ((class (class-of object))) (inspector-table (object pane) (print (class-name class) pane) ;; Display superclasses and subclasses (display-class-superclasses class pane) (display-class-subclasses class pane) (dolist (slot (reverse (clim-mop:class-slots class))) (display-object-slot object slot pane :display-lists-vertically t))))) ;; Try to print the normal, textual representation of an object, but ;; if that's too long, make an abbreviated "instance of ~S" version. ;; FIXME: should this be removed? It's really ugly. (defparameter *object-representation-max-length* 300 "Maximum number of characters of an object's textual representation that are allowed before abbreviation kicks in") (defun inspect-structure-or-object-briefly (object pane) (with-output-as-presentation (pane object (presentation-type-of object)) (with-text-family (pane :fix) (handler-case (let ((representation (with-output-to-string (string) (prin1 object string)))) (if (< (length representation) *object-representation-max-length*) (princ representation pane) (format pane "#<~S ...>" (class-name (class-of object))))) (error () (format pane "#" (class-name (class-of object)))))))) (defmethod inspect-object-briefly ((object standard-object) pane) (inspect-structure-or-object-briefly object pane)) (defmethod inspect-object-briefly ((object structure-object) pane) (inspect-structure-or-object-briefly object pane)) (defmethod inspect-object-briefly ((object condition) pane) (inspect-structure-or-object-briefly object pane)) (defmethod inspect-object ((object standard-object) pane) (inspect-structure-or-object object pane)) (defmethod inspect-object ((object structure-object) pane) (inspect-structure-or-object object pane)) (defmethod inspect-object ((object standard-class) pane) (inspect-standard-class object pane)) (defmethod inspect-object ((object built-in-class) pane) (inspect-standard-class object pane)) (defmethod inspect-object ((object condition) pane) (inspect-structure-or-object object pane)) (defun inspect-cons-as-cells (object pane) "Inspect a cons cell in a fancy graphical way. The inconvenient part is that this necessarily involves quite a bit of clicking to show a moderately-sized list." (if (null (cdr object)) (formatting-table (pane) (formatting-column (pane) (formatting-cell (pane) (with-output-as-presentation (pane object 'cons) (draw-rectangle* pane 0 0 20 10 :filled nil)) (draw-line* pane 10 0 10 10) (draw-arrow* pane 5 5 5 30) (draw-line* pane 10 10 20 0)) (formatting-cell (pane) (inspect-object (car object) pane)))) (formatting-table (pane) (formatting-row (pane) (formatting-cell (pane) (formatting-table (pane) (formatting-column (pane) (formatting-cell (pane) (with-output-as-presentation (pane object 'cons) (draw-rectangle* pane 0 0 20 10 :filled nil)) (draw-line* pane 10 0 10 10) (draw-arrow* pane 5 5 5 30) (draw-arrow* pane 15 5 40 5)) (formatting-cell (pane) (inspect-object (car object) pane))))) (formatting-cell (pane) (inspect-object (cdr object) pane)))))) (defun inspect-vertical-list (object pane &key honor-dico) "Inspect a list without the parentheses, putting each element on a new line. This is useful for showing things like direct class subclasses, since displaying those as a plain list looks ugly and is inconvenient to use. If HONOR-DICO is t, this will respect DICO and display '...' if OBJECT is not in DICO." ;; Ordinarily this would be taken care of in the :around method for ;; INSPECT-OBJECT, but since this is not a normal inspection view, ;; we need to do it ourselves. Yes, it would be better if we could ;; find another way to do this. (let ((*print-length* (or (gethash object (print-length *application-frame*)) *print-length*))) (if (and honor-dico (not (gethash object (dico *application-frame*)))) (inspect-object-briefly object pane) (with-output-as-presentation (pane object 'cons) (formatting-table (pane) (formatting-column (pane) (do ((length 0 (1+ length)) (cdr (cdr object) (cdr cdr)) (car (car object) (car cdr))) ((cond ((eq nil cdr) (formatting-cell (pane) (inspect-object car pane)) t) ((not (consp cdr)) (formatting-cell (pane) (inspect-object car pane)) (formatting-cell (pane) (princ "." pane)) (formatting-cell (pane) (inspect-object cdr pane)) t) ((and *print-length* (>= length *print-length*)) (with-output-as-presentation (pane object 'long-list-tail) (formatting-cell (pane) (princ "..." pane))) t) (t nil))) (formatting-cell (pane) (inspect-object car pane))))))))) (defun inspect-cons-as-list (object pane) "Inspect a cons cell in a traditional, plain-text format. The only difference between this and simply using the Lisp printer is that this code takes advantage of CLIM's tables and presentations to make the list as interactive as you would expect." (with-output-as-presentation (pane object 'cons) (formatting-table (pane) (formatting-row (pane) (formatting-cell (pane) (princ "(" pane)) (do ((length 0 (1+ length)) (cdr (cdr object) (cdr cdr)) (car (car object) (car cdr))) ((cond ((eq nil cdr) (formatting-cell (pane) (inspect-object car pane)) (formatting-cell (pane) (princ ")" pane)) t) ((not (consp cdr)) (formatting-cell (pane) (inspect-object car pane)) (formatting-cell (pane) (princ "." pane)) (formatting-cell (pane) (inspect-object cdr pane)) (formatting-cell (pane) (princ ")" pane)) t) ((and *print-length* (>= length *print-length*)) (with-output-as-presentation (pane object 'long-list-tail) (formatting-cell (pane) (princ "...)" pane))) t) (t nil))) (formatting-cell (pane) (inspect-object car pane))))))) (defmethod inspect-object ((object cons) pane) ;; Decide how to display the cons by looking in cons-cell-dico (if (gethash object (cons-cell-dico *application-frame*)) (inspect-cons-as-cells object pane) (inspect-cons-as-list object pane))) (defun show-hash-table-status (hash pane &key (message "Usage Graph")) "Show a hash table's status graphically on a given pane. Display a given message, which defaults to 'Usage Graph'." (with-room-for-graphics (pane :height 20) (let* ((my-beige (make-rgb-color 0.9372549 0.8862745 0.8862745)) (used-color (make-rgb-color 0.43529412 0.7921569 0.87058824)) (text-color (make-rgb-color 0.7176471 0.29803923 0.2)) (pattern (make-rectangular-tile (make-pattern #2A((0 1 0 0 0) (1 0 0 0 0) (0 0 0 0 1) (0 0 0 1 0) (0 0 1 0 0)) (list my-beige +black+)) 5 5))) (draw-rectangle* pane 0 0 150 20 :filled t :ink my-beige) (draw-rectangle* pane 0 0 (* 150 (/ (hash-table-count hash) (hash-table-size hash))) 20 :filled t :ink used-color :line-thickness 0) (draw-rectangle* pane (* 150 (hash-table-rehash-threshold hash)) 0 150 20 :filled t :ink pattern :line-thickness 0) (draw-rectangle* pane 0 0 150 20 :filled nil :ink +black+) (draw-text* pane message 7 10 :align-y :center :align-x :left :text-size :small :ink text-color :text-face :italic)))) (defmethod inspect-object-briefly ((object hash-table) pane) (with-output-as-presentation (pane object (presentation-type-of object)) (show-hash-table-status object pane :message "Hash table"))) (defmethod inspect-object ((object hash-table) pane) (inspector-table (object pane) (progn (format pane "~A (test: ~A) " 'hash-table (hash-table-test object)) (show-hash-table-status object pane)) (loop for key being the hash-keys of object do (formatting-row (pane) (formatting-cell (pane :align-x :right) (inspect-object key pane)) (formatting-cell (pane) (princ "=" pane)) (formatting-cell (pane) (inspect-object (gethash key object) pane)))))) (defmethod inspect-object ((object generic-function) pane) (inspector-table (object pane) (format pane "Generic Function: ~s" (clim-mop:generic-function-name object)) (dolist (method (clim-mop:generic-function-methods object)) (with-output-as-presentation (pane method (presentation-type-of method)) (formatting-row (pane) (formatting-cell (pane) (with-text-family (pane :fix) (print (clim-mop:method-qualifiers method) pane))) (loop for specializer in (clim-mop:method-specializers method) do (formatting-cell (pane) (if (typep specializer 'clim-mop:eql-specializer) (progn (princ "(EQL " pane) (inspect-object (clim-mop:eql-specializer-object specializer) pane) (princ ")" pane)) (inspect-object (class-name specializer) pane))))))))) (defun pretty-print-function (fun) "Print a function in a readable way, returning a string. On most implementations this just uses the standard Lisp printer, but it can use implementation-specific functions to be more informative." (flet ((generic-print (fun) (with-output-to-string (string) (prin1 fun string)))) ;; If we have SBCL, try to do fancy formatting. If anything goes ;; wrong with that, fall back on ugly standard PRIN1. #+sbcl (unless (typep fun 'generic-function) (let ((fun (sb-kernel:%closure-fun fun))) (handler-case (format nil "~A ~S" (sb-kernel:%simple-fun-name fun) (sb-kernel:%simple-fun-arglist fun)) (error () (generic-print fun))))) ;; FIXME: Other Lisp implementations have ways of getting this ;; information. If you want a better inspector on a non-SBCL Lisp, ;; please add code for it and send patches. #-sbcl (generic-print fun))) ;; This is ugly. I think CLIM requires there to be a presentation type ;; for every class, so we should use FUNCTION---but I'm not sure how ;; well that will work. (define-presentation-type inspected-function () :inherit-from t) (defmethod inspect-object ((object function) pane) (with-output-as-presentation (pane object 'inspected-function) (with-heading-style (pane) (princ "Function: " pane)) (with-text-family (pane :fix) (princ (pretty-print-function object) pane)) #+sbcl (unless (typep object 'generic-function) (with-heading-style (pane) (format pane "~&Type: ")) (with-text-family (pane :fix) (princ (sb-kernel:%simple-fun-type (sb-kernel:%closure-fun object)) pane))) (print-documentation object pane) (when (gethash object (disassembly-dico *application-frame*)) (display-disassembly object pane)))) (defmethod inspect-object-briefly ((object package) pane) ;; Display as 'Package: "PACKAGE-NAME"'. We're doing something a ;; little unusual here by not bolding the "Package:" part. This may ;; be a tad inconsistent, but the other way looks very odd. (with-output-as-presentation (pane object (presentation-type-of object)) (princ "Package: " pane) (with-text-family (pane :fix) (princ (package-name object) pane)))) (defun package-exported-symbols (package) "Return a list of all symbols exported by PACKAGE" (let (symbols) (do-external-symbols (symbol package symbols) (push symbol symbols)))) (defmethod inspect-object ((object package) pane) (inspector-table (object pane) (format pane "Package: ~S" (package-name object)) (inspector-table-row (pane) (princ "Name:" pane) (inspect-object (package-name object) pane)) (inspector-table-row (pane) (princ "Nicknames:" pane) (inspect-vertical-list (package-nicknames object) pane)) (inspector-table-row (pane) (princ "Used by:") (inspect-vertical-list (package-used-by-list object) pane)) (inspector-table-row (pane) (princ "Uses:") (inspect-vertical-list (package-use-list object) pane)) (inspector-table-row (pane) (princ "Exports:") (inspect-vertical-list (package-exported-symbols object) pane)))) (defmethod inspect-object ((object vector) pane) (with-output-as-presentation (pane object (presentation-type-of object)) (formatting-table (pane) (formatting-row (pane) (formatting-cell (pane) (princ "#(" pane)) (dotimes (i (length object)) (formatting-cell (pane) (inspect-object (aref object i) pane))) (formatting-cell (pane) (princ ")" pane)))))) (defmethod inspect-object-briefly ((object string) pane) (with-output-as-presentation (pane object (presentation-type-of object)) (prin1 object))) (defmethod inspect-object-briefly ((object number) pane) (with-output-as-presentation (pane object (presentation-type-of object)) (prin1 object))) (defun inspect-complex (object pane) "Inspect a complex number. Since complex numbers should be inspected the same way briefly and fully, this function can be called by both of them." (with-output-as-presentation (pane object (presentation-type-of object)) (formatting-table (pane) (formatting-row (pane) (formatting-cell (pane) (princ "#C(" pane)) (formatting-cell (pane) (inspect-object (realpart object) pane)) (formatting-cell (pane) (inspect-object (imagpart object) pane)) (formatting-cell (pane) (princ ")" pane)))))) (defmethod inspect-object-briefly ((object complex) pane) (inspect-complex object pane)) (defmethod inspect-object ((object complex) pane) (inspect-complex object pane)) (defmethod inspect-object ((object float) pane) (inspector-table (object pane) (format pane "Float ~S" object) (multiple-value-bind (significand exponent sign) (decode-float object) (inspector-table-rows (pane) ("sign:" sign) ("significand:" significand) ("exponent:" exponent))) (inspector-table-rows (pane) ("radix:" (float-radix object))))) (defun iso-8601-format (time) "Return the given universal time in ISO 8601 format. This will raise an error if the given time is not a decodable universal time." (multiple-value-bind (sec min hour date month year) (decode-universal-time time 0) (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0DZ" year month date hour min sec))) (defmethod inspect-object ((object integer) pane) (flet ((present-in-base (base &key (radix t) (family :fix)) (with-text-family (pane family) (formatting-cell (pane) (with-output-as-presentation (pane object (presentation-type-of object)) (write object :radix radix :base base :stream pane))))) (print-equals-cell () (formatting-cell (pane) (princ "=" pane)))) (inspector-table (object pane) (format pane "Integer ~S" object) (inspector-table-row (pane) (princ "value:" pane) (formatting-table (pane) (formatting-row (pane) ;; Base 10 should be displayed normally, without the ;; fixed-width font and without the radix. (present-in-base 10 :radix nil :family :sans-serif) (print-equals-cell) ; = (present-in-base 16) ; Hexadecimal (print-equals-cell) ; = (present-in-base 8) ; Octal (print-equals-cell) ; = (present-in-base 2)))) ; Binary (when (<= 0 object 255) (inspector-table-row (pane) (princ "character:" pane) (inspect-object (code-char object) pane))) (inspector-table-row (pane) (princ "length:" pane) (inspect-object (integer-length object) pane)) ;; Sometimes we get numbers that can't be interpreted as a ;; time. Those throw an error, and this just isn't printed. (ignore-errors (inspector-table-row (pane) (princ "as time:" pane) (with-text-family (pane :fix) (with-output-as-presentation (pane object (presentation-type-of object)) (princ (iso-8601-format object) pane)))))))) (defmethod inspect-object-briefly ((object symbol) pane) (with-output-as-presentation (pane object (presentation-type-of object)) (with-text-family (pane :fix) (prin1 object)))) (defmethod inspect-object ((object symbol) pane) (inspector-table (object pane) (format pane "Symbol ~S" (symbol-name object)) (inspector-table-row (pane) (princ "value:" pane) (if (boundp object) (inspect-object (symbol-value object) pane) (princ "unbound" pane))) (inspector-table-row (pane) (princ "function:" pane) (if (fboundp object) (inspect-object (symbol-function object) pane) (princ "unbound" pane))) ;; This is not, strictly speaking, a property of the ;; symbol. However, this is useful enough that I think it's worth ;; including here, since it can eliminate some minor annoyances. (inspector-table-row (pane) (princ "class:" pane) (if (find-class object nil) (inspect-object (find-class object) pane) (princ "unbound" pane))) (inspector-table-row (pane) (princ "package:" pane) (inspect-object (symbol-package object) pane)) (inspector-table-row (pane) (princ "propery list:" pane) (dolist (property (symbol-plist object)) (inspect-object property pane))))) ;; Characters are so short that displaying them as "..." takes almost ;; as much space as just showing them, and this way is more ;; informative. (defmethod inspect-object-briefly ((object character) pane) (with-output-as-presentation (pane object (presentation-type-of object)) (print object pane))) (defmethod inspect-object ((object character) pane) (inspector-table (object pane) (format pane "Character ~S" object) (inspector-table-rows (pane) ("code:" (char-code object)) ("int:" (char-int object)) ("name:" (char-name object))))) (defmethod inspect-object ((object pathname) pane) (inspector-table (object pane) (princ (if (wild-pathname-p object) "Wild pathname" "Pathname")) (inspector-table-rows (pane) ("namestring:" (namestring object)) ("host:" (pathname-host object)) ("device:" (pathname-device object)) ("directory:" (pathname-directory object)) ("name:" (pathname-name object)) ("type:" (pathname-type object)) ("version:" (pathname-version object))) (unless (or (wild-pathname-p object) (not (probe-file object))) (inspector-table-row (pane) (princ "truename:" pane) (inspect-object (truename object) pane))))) (defun display-app (frame pane) "Display the APP frame of the inspector" (inspect-object (obj frame) pane)) (define-inspector-command (com-quit :name t) () (frame-exit *application-frame*)) (define-inspector-command (com-inspect :name t) () (let ((obj (accept t :prompt "Select an object")) (*application-frame* nil)) ; To get around security. (inspector obj :new-process t))) (define-inspector-command (com-toggle-show-list-cells :name t) ((obj 'cons :gesture :select :prompt "Select a cons or list")) (togglef (gethash obj (cons-cell-dico *application-frame*)))) (define-inspector-command (com-show-10-more-items :name t) ((obj 'long-list-tail :gesture :select :prompt "Select a truncated list")) (if (gethash obj (print-length *application-frame*)) (incf (gethash obj (print-length *application-frame*)) 10) (setf (gethash obj (print-length *application-frame*)) (+ 10 *print-length*)))) (define-inspector-command (com-toggle-inspect :name t) ((obj t :gesture :select :prompt "Select an object")) (unless (or (eq obj (obj *application-frame*)) (null obj)) (togglef (gethash obj (dico *application-frame*))))) (define-inspector-command (com-remove-method :name t) ((obj 'method :gesture :delete :prompt "Remove method")) (remove-method (clim-mop:method-generic-function obj) obj)) (define-inspector-command (com-set-slot :name t) ((slot 'settable-slot :gesture :select :prompt "Set slot")) (handler-case (setf (slot-value (car slot) (cdr slot)) (accept t :prompt "New slot value")) (simple-parse-error () (format (get-frame-pane *application-frame* 'int) "~&Command canceled; slot value not set~%")))) (defun slot-documentation (class slot) "Returns the documentation of a slot of a class, or nil. There is, unfortunately, no portable way to do this, but the MOP is semi-portable and we can use it. To complicate things even more, some implementations have unpleasant oddities in the way they store slot documentation. For example, in SBCL slot documentation is only available in direct slots." (let ((slot-object (find slot (clim-mop:class-direct-slots class) :key #'clim-mop:slot-definition-name))) (if slot-object (documentation slot-object t) (when (clim-mop:class-direct-superclasses class) (find-if #'identity (mapcar #'(lambda (class) (slot-documentation class slot)) (clim-mop:class-direct-superclasses class))))))) (define-inspector-command (com-describe-slot :name t) ((slot 'settable-slot :gesture :describe :prompt "Describe slot")) (destructuring-bind (object . slot-name) slot (let* ((stream (get-frame-pane *application-frame* 'int)) (class (class-of object)) (documentation (handler-bind ((warning #'muffle-warning)) (slot-documentation class slot-name))) (slot-object (or (find slot-name (clim-mop:class-direct-slots class) :key #'clim-mop:slot-definition-name) (find slot-name (clim-mop:class-slots class) :key #'clim-mop:slot-definition-name)))) (when documentation (with-heading-style (stream) (format stream "~&Documentation: ")) (format stream "~A~%" documentation)) (with-heading-style (stream) (format stream "~&Type: ")) (format stream "~S~%" (clim-mop:slot-definition-type slot-object)) (with-heading-style (stream) (format stream "~&Allocation: ")) (format stream "~S~%" (clim-mop:slot-definition-allocation slot-object)) ;; slot-definition-{readers,writers} only works for direct slot ;; definitions (let ((readers (clim-mop:slot-definition-readers slot-object))) (when readers (with-heading-style (stream) (format stream "~&Readers: ")) (present readers (presentation-type-of readers) :stream stream))) (let ((writers (clim-mop:slot-definition-writers slot-object))) (when writers (with-heading-style (stream) (format stream "~&Writers: ")) (present writers (presentation-type-of writers) :stream stream)))))) (define-inspector-command (com-disassemble :name t) ((obj 'inspected-function :prompt "Select a function")) (when (typep obj 'function) (togglef (gethash obj (disassembly-dico *application-frame*))))) (define-presentation-to-command-translator disassemble-function (inspected-function com-disassemble inspector :documentation "Toggle Disassembly" :gesture :menu :menu t) (object) (list object)) (defun tracedp (symbol) "Is SYMBOL currently traced?" (member symbol (trace))) (define-inspector-command (com-trace :name t) ((obj 'symbol :prompt "Select an fbound symbol")) (when (fboundp obj) (eval `(trace ,obj)))) (define-inspector-command (com-untrace :name t) ((obj 'symbol :prompt "Select an fbound symbol")) (when (fboundp obj) (eval `(untrace ,obj)))) (define-presentation-to-command-translator trace-symbol (symbol com-trace inspector :documentation "Trace" :gesture :menu :menu t :tester ((object) (and object (fboundp object) (not (tracedp object))))) (object) (list object)) (define-presentation-to-command-translator untrace-symbol (symbol com-untrace inspector :documentation "Untrace" :gesture :menu :menu t :tester ((object) (and object (fboundp object) (tracedp object)))) (object) (list object)) ;; FIXME: This is a horrible hack to gloss over issues that I don't ;; properly understand. See ;; (defmethod clim:presentation-type-of ((object standard-generic-function)) 'clim:expression)cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Inspector/INSTALL0000644000175000017500000000263010257724406020711 0ustar pdmpdmQuick start =========== 1. Start your Lisp system and make sure you have ASDF loaded. 2. (asdf:operate 'asdf:load-op :clouseau) 3. Try something like: (clouseau:inspector (clim:make-application-frame 'clouseau:inspector :obj 20)) in order to inspect the inspector pane. 4. Left-click on occurrences of objects or of "...". Usage ===== The inspector is invoked like this: (clouseau:inspector object) To get a feel for what the inspector can do, try these: (clouseau:inspector #'write-string) (clouseau:inspector #'documentation) (clouseau:inspector 'documentation) (clouseau:inspector '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16)) Click on things. See what happens. Threading ========= If you have a multithreaded Lisp implementation, you can start an inspector in a new process like this: (clouseau:inspector object :new-process t) For example, if you want to get really fancy and inspect a running inspector, this ugly hack should do the job: (let ((*print-length* 10) (*print-level* 10) inspected-inspector) (setf inspected-inspector (clim:make-application-frame 'clouseau::inspector :obj (clim:make-application-frame 'clouseau::inspector :obj 20))) (clim-sys:make-process #'(lambda () (clim:run-frame-top-level inspected-inspector)) :name "Inspector Clouseau (being inspected)") (clouseau:inspector inspected-inspector :new-process t))cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Debugger/0000755000175000017500000000000011347763412017436 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Apps/Debugger/clim-debugger.lisp0000644000175000017500000003367111345155772023051 0ustar pdmpdm;;; (c) copyright 2004 by Peter Mechlenborg (metch@daimi.au.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; This is the beginning of a Common Lisp debugger implemented in ;;; McCLIM. It uses the portable debugger interface developed for the ;;; Slime project, and the graphical layout is also heavily inspired ;;; by Slime. Because of Slime I hope that this works on other ;;; implementations than SBCL. ;;; ;;; COMPILATION: ;;; ;;; At the moment I just use Slime to compile and load this file (with ;;; the command: C-c C-k) after I have loaded CLIM. Note: I have used ;;; the cvs version of Slime and McCLIM. ;;; ;;; ;;; Test: ;;; ;;; For at quick test, you can use this code snippet: ;;; ;;; (let ((*debugger-hook* #'clim-debugger:debugger)) ;;; (+ 3 'abc)) ;;; ;;; This is also nice :-) ;;; ;;; (let ((*debugger-hook* #'clim-debugger:debugger)) ;;; (clim-listener:run-listener :new-process t)) ;;; ;;; Problems/todo: ;;; ;;; - Elliott Johnson is to be thanked for the nice scroll-bars, but ;;; for some reason they don't remember their position when clicking ;;; on a stack-frame or "more". ;;; ;;; - The break function does not use the clim-debugger --> Christophe ;;; Rhodes was kind enough to inform me that on SBCL, ;;; SB-EXT:*INVOKE-DEBUGGER-HOOK* takes care off this problem. I ;;; still don't know if this is a problem with other compilers. ;;; ;;; - "Eval in frame" is not supported. I don't know of a good way to ;;; do this currently. ;;; ;;; - Goto source location is not supported, but I think this could be ;;; done through slime. ;;; ;;; - Currently the restart chosen by the clim-debugger is returned ;;; through the global variable *returned-restart*, this is not the ;;; best solution, but I do not know how of a better way to return a ;;; value from a clim frame, when it exits. ;;; ;;; - There need to added keyboard shortcuts. 'q' should exit the ;;; debugger with an abort. '0', '1' and so forth should activate ;;; the restarts, like Slime. Maybe is should be possible to use the ;;; arrow keys as well. Then we have to add a notion of the current ;;; frame. Would this be useful? ;;; (defpackage "CLIM-DEBUGGER" (:use "CL-USER" "CLIM" "CLIM-LISP") (:export :debugger)) (in-package :clim-debugger) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Misc ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Borrowed from Andy Hefner (defmacro bold ((stream) &body body) `(with-text-face (,stream :bold) ,@body)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Data model ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass debugger-info () ((the-condition :accessor the-condition :initarg :the-condition) (condition-message :accessor condition-message :initarg :condition-message) (type-of-condition :accessor type-of-condition :initarg :type-of-condition) (condition-extra :accessor condition-extra :initarg :condition-extra) (restarts :accessor restarts :initarg :restarts) (backtrace :accessor backtrace :initarg :backtrace))) (defclass minimized-stack-frame-view (textual-view)()) (defclass maximized-stack-frame-view (textual-view)()) (defparameter +minimized-stack-frame-view+ (make-instance 'minimized-stack-frame-view)) (defparameter +maximized-stack-frame-view+ (make-instance 'maximized-stack-frame-view)) (defclass stack-frame () ((clim-view :accessor view :initform +minimized-stack-frame-view+) (frame-string :accessor frame-string :initarg :frame-string) (frame-no :accessor frame-no :initarg :frame-no) (frame-variables :accessor frame-variables :initarg :frame-variables))) (defun compute-backtrace (start end) (loop for frame in (swank-backend::compute-backtrace start end) for frame-no from 0 collect (make-instance 'stack-frame :frame-string (let ((*print-pretty* nil)) (with-output-to-string (stream) (swank-backend::print-frame frame stream))) :frame-no frame-no :frame-variables (swank-backend::frame-locals frame-no)))) (defmethod expand-backtrace ((info debugger-info) (value integer)) (with-slots (backtrace) info (setf backtrace (compute-backtrace 0 (+ (length backtrace) 10))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; CLIM stuff ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass debugger-pane (application-pane) ((condition-info :reader condition-info :initarg :condition-info))) ;; FIXME - These two variables should be removed! ;; Used to return the chosen reatart in the debugger. (defparameter *returned-restart* nil) ;; Used to provide the clim frame with the condition info that ;; triggered the debugger. (defparameter *condition* nil) (defun make-debugger-pane () (with-look-and-feel-realization ((frame-manager *application-frame*) *application-frame*) (make-pane 'debugger-pane :condition-info *condition* :display-function #'display-debugger :end-of-line-action :allow :end-of-page-action :scroll))) (define-application-frame clim-debugger () () (:panes (debugger-pane (make-debugger-pane))) (:layouts (default (vertically () (scrolling () debugger-pane)))) (:geometry :height 600 :width 800)) (defun run-debugger-frame () (run-frame-top-level (make-application-frame 'clim-debugger))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Presentation types ;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-presentation-type stack-frame () :inherit-from 't) (define-presentation-type restart ()) (define-presentation-type more-type ()) (define-presentation-type inspect ()) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Commands ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-clim-debugger-command (com-more :name "More backtraces") ((pane 'more-type)) (expand-backtrace (condition-info pane) 10)) (define-clim-debugger-command (com-invoke-inspector :name "Invoke inspector") ((obj 'inspect)) (clouseau:inspector obj)) (define-clim-debugger-command (com-refresh :name "Refresh" :menu t) () (change-space-requirements (frame-panes *application-frame*))) (define-clim-debugger-command (com-quit :name "Quit" :menu t) () (frame-exit *application-frame*)) (define-clim-debugger-command (com-invoke-restart :name "Invoke restart") ((restart 'restart)) (setf *returned-restart* restart) (frame-exit *application-frame*)) (define-clim-debugger-command (com-toggle-stack-frame-view :name "Toggle stack frame view") ((stack-frame 'stack-frame)) (progn (if (eq +minimized-stack-frame-view+ (view stack-frame)) (setf (view stack-frame) +maximized-stack-frame-view+) (setf (view stack-frame) +minimized-stack-frame-view+)) (change-space-requirements (frame-panes *application-frame*)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Command translators ;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-presentation-to-command-translator more-backtraces (more-type com-more clim-debugger :gesture :select) (object) (list object)) (define-presentation-to-command-translator invoke-inspector (inspect com-invoke-inspector clim-debugger :gesture :select) (object) (list object)) (define-presentation-to-command-translator toggle-stack-frame-view (stack-frame com-toggle-stack-frame-view clim-debugger :gesture :select) (object) (list object)) (define-presentation-to-command-translator invoke-restart (restart com-invoke-restart clim-debugger :gesture :select) (object) (list object)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Display debugging info ;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun std-form (pane first second &key (family :sans-serif)) (formatting-row (pane) (with-text-family (pane :sans-serif) (formatting-cell (pane) (bold (pane) (format t "~A" first)))) (formatting-cell (pane) (with-text-family (pane family) (format t "~A" second))))) (defun display-debugger (frame pane) (let ((*standard-output* pane)) (formatting-table (pane) (std-form pane "Condition type:" (type-of-condition (condition-info pane))) (std-form pane "Description:" (condition-message (condition-info pane))) (when (condition-extra (condition-info pane)) (std-form pane "Extra:" (condition-extra (condition-info pane)) :family :fix))) (fresh-line) (with-text-family (pane :sans-serif) (bold (pane) (format t "Restarts:"))) (fresh-line) (format t " ") (formatting-table (pane) (loop for r in (restarts (condition-info pane)) do (formatting-row (pane) (with-output-as-presentation (pane r 'restart) (formatting-cell (pane) (format pane "~A" (restart-name r))) (formatting-cell (pane) (with-text-family (pane :sans-serif) (format pane "~A" r))))))) (fresh-line) (display-backtrace frame pane) (change-space-requirements pane :width (bounding-rectangle-width (stream-output-history pane)) :height (bounding-rectangle-height (stream-output-history pane))))) (defun display-backtrace (frame pane) (declare (ignore frame)) (with-text-family (pane :sans-serif) (bold (pane) (format t "Backtrace:"))) (fresh-line) (format t " ") (formatting-table (pane) (loop for stack-frame in (backtrace (condition-info pane)) for i from 0 do (formatting-row (pane) (with-output-as-presentation (pane stack-frame 'stack-frame) (bold (pane) (formatting-cell (pane) (format t "~A: " i))) (formatting-cell (pane) (present stack-frame 'stack-frame :view (view stack-frame)))))) (when (>= (length (backtrace (condition-info pane))) 20) (formatting-row (pane) (formatting-cell (pane)) (formatting-cell (pane) (bold (pane) (present pane 'more-type))))))) (define-presentation-method present (object (type stack-frame) stream (view minimized-stack-frame-view) &key acceptably for-context-type) (declare (ignore acceptably for-context-type)) (format t "~A " (frame-string object))) (define-presentation-method present (object (type stack-frame) stream (view maximized-stack-frame-view) &key acceptably for-context-type) (declare (ignore acceptably for-context-type)) (progn (princ (frame-string object) stream) (fresh-line) (with-text-family (stream :sans-serif) (bold (stream) (format t " Locals:"))) (fresh-line) (format t " ") (formatting-table (stream) (loop for (name n identifier id value val) in (frame-variables object) do (formatting-row (stream) (formatting-cell (stream) (format t "~A" n)) (formatting-cell (stream) (format t "=")) (formatting-cell (stream) (present val 'inspect))))) (fresh-line))) (define-presentation-method present (object (type restart) stream (view textual-view) &key acceptably for-context-type) (declare (ignore acceptably for-context-type)) (bold (stream) (format t "~A" (restart-name object)))) (define-presentation-method present (object (type more-type) stream (view textual-view) &key acceptably for-context-type) (declare (ignore acceptably for-context-type)) (bold (stream) (format t "--- MORE ---"))) (define-presentation-method present (object (type inspect) stream (view textual-view) &key acceptably for-context-type) (declare (ignore acceptably for-context-type)) (format t "~A" object)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Starting the debugger ;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun debugger (condition me-or-my-encapsulation) (swank-backend::call-with-debugging-environment (lambda () (unwind-protect (progn (setf *condition* (make-instance 'debugger-info :the-condition condition :type-of-condition (type-of condition) :condition-message (swank::safe-condition-message condition) :condition-extra (swank::condition-extras condition) :restarts (compute-restarts) :backtrace (compute-backtrace 0 20))) (run-debugger-frame)) (let ((restart *returned-restart*)) (setf *returned-restart* nil) (setf *condition* nil) (if restart (let ((*debugger-hook* me-or-my-encapsulation)) (invoke-restart-interactively restart)) (abort))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; For testing ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun simple-break () (with-simple-restart (continue "Continue from interrupt.") (let ((*debugger-hook* #'debugger)) (invoke-debugger (make-condition 'simple-error :format-control "Debugger test"))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Extensions/0000700000175000017500000000000011347764046017140 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Extensions/rgb-image.lisp0000640000175000017500000001114210741375214021660 0ustar pdmpdm;;; (c) copyright 1998 by Gilbert Baumann ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this software and associated documentation files (the ;;; "Software"), to deal in the Software without restriction, including ;;; without limitation the rights to use, copy, modify, merge, publish, ;;; distribute, sublicense, and/or sell copies of the Software, and to ;;; permit persons to whom the Software is furnished to do so, subject to ;;; the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. ;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY ;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, ;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;;; ;;; (Hacked for inclusion into McCLIM by David Lichteblau.) (in-package :climi) ;;; ARGB image data represented as an (unsigned-byte 32) array (defclass rgb-image () ((width :initarg :width :accessor image-width) (height :initarg :height :accessor image-height) (data :initarg :data :accessor image-data :type (or null (simple-array (unsigned-byte 32) (* *)))) (alphap :initarg :alphap :initform nil :accessor image-alpha-p))) ;;; Applications (closure in particular) might want to cache any ;;; backend-specific data required to draw an RGB-IMAGE. ;;; ;;; To implement this caching, designs must be created separately for each ;;; medium, so that mediums can put their own data into them. (defclass rgb-image-design (design) ((medium :initform nil :initarg :medium) (image :reader image :initarg :image) (medium-data :initform nil))) (defun make-rgb-image-design (image) (make-instance 'rgb-image-design :image image)) ;;; Protocol to free cached data (defgeneric medium-free-image-design (medium design)) (defmethod medium-free-image-design ((sheet sheet-with-medium-mixin) design) (medium-free-image-design (sheet-medium sheet) design)) (defun free-image-design (design) (medium-free-image-design (slot-value design 'medium) design)) ;;; Drawing protocol (defgeneric medium-draw-image-design* (medium design x y)) (defmethod medium-draw-image-design* :before (current-medium design x y) (with-slots (medium medium-data) design (unless (eq medium current-medium) (when medium (medium-free-image-design medium design)) (setf medium current-medium) (setf medium-data nil)))) (defmethod medium-draw-image-design* ((medium sheet-with-medium-mixin) design x y) (medium-draw-image-design* (sheet-medium medium) design x y)) ;;; Output recording stuff, this was copied from the pattern code. (def-grecording draw-image-design (() image-design x y) () (let ((width (image-width (image image-design))) (height (image-height (image image-design))) (transform (medium-transformation medium))) (setf (values x y) (transform-position transform x y)) (values x y (+ x width) (+ y height)))) (defmethod* (setf output-record-position) :around (nx ny (record draw-image-design-output-record)) (with-standard-rectangle* (:x1 x1 :y1 y1) record (with-slots (x y) record (let ((dx (- nx x1)) (dy (- ny y1))) (multiple-value-prog1 (call-next-method) (incf x dx) (incf y dy)))))) (defrecord-predicate draw-image-design-output-record (x y image-design) (and (if-supplied (x coordinate) (coordinate= (slot-value record 'x) x)) (if-supplied (y coordinate) (coordinate= (slot-value record 'y) y)) (if-supplied (image-design rgb-image-design) (eq (slot-value record 'image-design) image-design)))) ;;; Fetching protocol (defun sheet-rgb-image (sheet &key x y width height) (multiple-value-bind (data alphap) (sheet-rgb-data (port sheet) sheet :x x :y y :width width :height height) (destructuring-bind (height width) (array-dimensions data) (make-instance 'rgb-image :width width :height height :data data :alphap alphap)))) (defgeneric sheet-rgb-data (port sheet &key x y width height)) (defmethod draw-design (medium (design rgb-image-design) &rest options &key (x 0) (y 0) &allow-other-keys) (with-medium-options (medium options) (medium-draw-image-design* medium design x y))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Extensions/tab-layout.lisp0000640000175000017500000004325310705412617022116 0ustar pdmpdm;;; -*- Mode: Lisp; show-trailing-whitespace: t; indent-tabs: nil; -*- ;;; Based on the tab-layout by: ;;; --------------------------------------------------------------------------- ;;; Title: A Tab Layout Pane ;;; Created: 2005/09/16-19 ;;; Author: Max-Gerd Retzlaff , http://bl0rg.net/~mgr ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2005 by Max-Gerd Retzlaff ;;; ;;; Available from: ;;; http://bl0rg.net/~mgr/flux/tab-layout_2005-09-19_02-52+0200.tar.bz2 ;;; ;;; License given on IRC: ;;; http://tunes.org/~nef/logs/lisp/07.01.15 ;;; 04:04:49 _8work: the license will not be a problem. not with me, not ;;; with Gilbert. BSD or LGPL, or both. but I'm on the move.. see you later ;;; 04:05:22 _8work: in fact, I wanted to commit it to mcclim long time ;;; ago, but I have not yet because there seemed to be a lack of interest. ;;; Based on the stack layout by: ;;; --------------------------------------------------------------------------- ;;; Title: Embryo Stack Layout Pane Class ;;; Created: 2003-06-01 ;;; Author: Gilbert Baumann ;;; License: As public domain as it can get. ;;; --------------------------------------------------------------------------- ;;; Available from: ;;; http://bauhh.dyndns.org:8000/mcclim/cookbook/ ;;; --------------------------------------------------------------------------- ;;; Adapted for inclusion into McCLIM: ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2006 David Lichteblau (in-package :clim-tab-layout) ;;; abstract TAB-LAYOUT superclass (climi::define-abstract-pane-mapping 'tab-layout 'tab-layout-pane) (defclass tab-layout (climi::composite-pane) ((pages :initform nil :reader tab-layout-pages :initarg :pages) (enabled-page :initform nil :accessor tab-layout-enabled-page)) (:documentation "The abstract tab layout pane is a composite pane arranging its children so that exactly one child is visible at any time, with a row of buttons allowing the user to choose between them. Use WITH-TAB-LAYOUT to define a tab layout and its children, or use the :PAGES argument to specify its contents when creating it dynamically using MAKE-PANE.")) (defmethod initialize-instance :after ((instance tab-layout) &key pages) (when (eq (class-of instance) (find-class 'tab-layout)) (error "tab-layout is an abstract class, you cannot instantiate it!")) (dolist (page pages) (setf (tab-page-tab-layout page) instance) (sheet-adopt-child instance (tab-page-pane page))) (setf (tab-layout-enabled-page instance) (car pages))) (defclass tab-page () ((tab-layout :initform nil :accessor tab-page-tab-layout) (title :initform nil :accessor tab-page-title :initarg :title) (pane :initform nil :accessor tab-page-pane :initarg :pane) (presentation-type :initform 'tab-page :accessor tab-page-presentation-type :initarg :presentation-type) (enabled-callback :initform nil :accessor tab-page-enabled-callback :initarg :enabled-callback) ;; fixme: drawing-options in this generality are a feature of the old ;; concrete tab pane. Gtkairo will only look for the :INK in this list. (drawing-options :initform nil :accessor tab-page-drawing-options :initarg :drawing-options)) (:documentation "Instances of TAB-PAGE represent the pages in a TAB-LAYOUT. For each child pane, there is a TAB-PAGE providing the page's title and additional information about the child. Valid initialization arguments are :TITLE, :PANE (required) and :PRESENTATION-TYPE,:DRAWING-OPTIONS (optional).")) (defmethod print-object ((object tab-page) stream) (print-unreadable-object (object stream :identity t :type t) (princ (tab-page-title object) stream))) (defgeneric tab-layout-pages (tab-layout) (:documentation "Return all TAB-PAGEs in this tab layout, in order from left to right. Do not modify the resulting list destructively. Use the SETF function of the same name to assign a new list of pages. The SETF function will automatically add tabs for new page objects, remove old pages, and reorder the pages to conform to the new list.")) (defgeneric tab-layout-enabled-page (tab-layout) (:documentation "The currently visible tab page of this tab-layout, or NIL if the tab layout does not have any pages currently. Use the SETF function of the name to change focus to another tab page.")) (defgeneric tab-page-tab-layout (tab-page) (:documentation "Return the TAB-LAYOUT this page belongs to.")) (defgeneric tab-page-pane (tab-page) (:documentation "Return the CLIM pane this page displays. See also SHEET-TO-PAGE, the reverse operation.")) (defgeneric tab-page-title (tab-page) (:documentation "Return the title displayed in the tab for this PAGE. Use the SETF function of the same name to set the title dynamically.")) (defgeneric tab-page-presentation-type (tab-page) (:documentation "Return the type of the presentation used when this page's header gets clicked. Use the SETF function of the same name to set the presentation type dynamically. The default is TAB-PAGE.")) (defgeneric tab-page-drawing-options (tab-page) (:documentation "Return the drawing options of this page's header. Use the SETF function of the same name to set the drawing options dynamically. Note: Not all implementations of the tab layout will understand all drawing options. In particular, the Gtkairo backends understands only the :INK option at this time.")) (defgeneric (setf tab-layout-enabled-page) (newval tab-layout)) (defgeneric note-tab-page-changed (layout page) (:documentation "This internal function is called by the SETF methods for TAB-PAGE-TITLE and -DRAWING-OPTIONS to inform the page's tab-layout about the changes, allowing it to update its display. Only called by the TAB-LAYOUT implementation and specialized by its subclasses.")) (defmethod (setf tab-layout-enabled-page) :around (page (parent tab-layout)) ;; As a rule, we always want exactly one enabled page -- unless we ;; don't have any pages at all. (assert (or page (null (tab-layout-pages parent)))) ;; This must be an around method, so that we can see the old value, yet ;; do the call only after the change has been done: (let ((old-page (tab-layout-enabled-page parent))) (prog1 (call-next-method) (when (and page (not (equal page old-page))) (note-tab-page-enabled page))))) (defmethod (setf tab-layout-pages) (newval (parent tab-layout)) (unless (equal newval (remove-duplicates newval)) (error "page list must not contain duplicates: ~A" newval)) (let* ((oldval (tab-layout-pages parent)) (add (set-difference newval oldval)) (remove (set-difference oldval newval))) ;; check for errors (dolist (page add) (unless (null (tab-page-tab-layout page)) (error "~A has already been added to a different tab layout" page))) ;; remove old pages first, because sheet-disown-child still needs access ;; to the original page list: (dolist (page remove) (sheet-disown-child parent (tab-page-pane page))) ;; install the pages before adding their sheets (matters for gtkairo) (setf (slot-value parent 'pages) newval) ;; add new pages: (dolist (page add) (setf (tab-page-tab-layout page) parent) (sheet-adopt-child parent (tab-page-pane page))))) (defmethod sheet-disown-child :before ((parent tab-layout) child &key errorp) (declare (ignore errorp)) (unless (internal-child-p child parent) (let* ((page (sheet-to-page child)) (current-page (tab-layout-enabled-page parent)) (currentp (equal child (tab-page-pane current-page))) (successor (when currentp (page-successor current-page)))) (setf (slot-value parent 'pages) (remove page (tab-layout-pages parent))) (when currentp (setf (tab-layout-enabled-page parent) successor)) (setf (tab-page-tab-layout page) nil)))) (defun sheet-to-page (sheet) "For a SHEET that is a child of a tab layout, return the page corresponding to this sheet. See also TAB-PAGE-PANE, the reverse operation." (find sheet (tab-layout-pages (sheet-parent sheet)) :key #'tab-page-pane)) (defun find-tab-page-named (name tab-layout) "Find the tab page with the specified TITLE in TAB-LAYOUT. Note that uniqueness of titles is not enforced; the first page found will be returned." (find name (tab-layout-pages tab-layout) :key #'tab-page-title ;; fixme: don't we want the case-sensitive STRING= here? :test #'string-equal)) (defmethod (setf tab-page-title) :after (newval (page tab-page)) (declare (ignore newval)) (let ((layout (tab-page-tab-layout page))) (when layout (note-tab-page-changed layout page)))) (defmethod (setf tab-page-drawing-options) :after (newval (page tab-page)) (declare (ignore newval)) (let ((layout (tab-page-tab-layout page))) (when layout (note-tab-page-changed layout page)))) (defmethod note-tab-page-changed ((layout tab-layout) page) nil) ;;; GTK+ distinguishes between children user code creates and wants to ;;; see, and "internal" children the container creates and mostly hides ;;; from the user. Let's steal that concept to ignore the header pane. (defgeneric internal-child-p (child parent)) (defmethod internal-child-p (child (parent tab-layout)) nil) (defun page-successor (page) "The page we should enable when PAGE is currently enabled but gets removed." (loop for (a b c) on (tab-layout-pages (tab-page-tab-layout page)) do (cond ((eq a page) (return b)) ((eq b page) (return (or c a)))))) (defun note-tab-page-enabled (page) (let ((callback (tab-page-enabled-callback page))) (when callback (funcall callback page)))) ;;; convenience functions: (defun add-page (page tab-layout &optional enable) "Add PAGE at the left side of TAB-LAYOUT. When ENABLE is true, move focus to the new page. This function is a convenience wrapper; you can also push page objects directly into TAB-LAYOUT-PAGES and enable them using (SETF TAB-LAYOUT-ENABLED-PAGE)." (push page (tab-layout-pages tab-layout)) (when enable (setf (tab-layout-enabled-page tab-layout) page))) (defun switch-to-page (page) "Move the focus in page's tab layout to this page. This function is a one-argument convenience version of (SETF TAB-LAYOUT-ENABLED-PAGE), which can also be called directly." (setf (tab-layout-enabled-page (tab-page-tab-layout page)) page)) (defun remove-page (page) "Remove PAGE from its tab layout. This is a convenience wrapper around SHEET-DISOWN-CHILD, which can also be used directly to remove the page's pane with the same effect." (sheet-disown-child (tab-page-tab-layout page) (tab-page-pane page))) (defun remove-page-named (title tab-layout) "Remove the tab page with the specified TITLE from TAB-LAYOUT. Note that uniqueness of titles is not enforced; the first page found will be removed. This is a convenience wrapper, you can also use FIND-TAB-PAGE-NAMED to find and the remove a page yourself." (remove-page (find-tab-page-named title tab-layout))) ;;; creation macro (defmacro with-tab-layout ((default-presentation-type &rest initargs &key name &allow-other-keys) &body body) "Return a TAB-LAYOUT. Any keyword arguments, including its name, will be passed to MAKE-PANE. Child pages of the TAB-LAYOUT can be specified using BODY, using lists of the form (TITLE PANE &KEY PRESENTATION-TYPE DRAWING-OPTIONS ENABLED-CALLBACK). DEFAULT-PRESENTATION-TYPE will be passed as :PRESENTATION-TYPE to pane creation forms that specify no type themselves." (let ((ptypevar (gensym))) `(let ((,ptypevar ,default-presentation-type)) (make-pane 'tab-layout :name ,(or name `',(gensym "tab-layout-")) :pages (list ,@(mapcar (lambda (spec) `(make-tab-page ,@spec :presentation-type ,ptypevar)) body)) ,@initargs)))) (defun make-tab-page (title pane &key presentation-type drawing-options enabled-callback) (make-instance 'tab-page :title title :pane pane :presentation-type presentation-type :drawing-options drawing-options :enabled-callback enabled-callback)) ;;; presentation/command system integration (define-command (com-switch-to-tab-page :command-table clim:global-command-table) ((page 'tab-page :prompt "Tab page")) (switch-to-page page)) (define-presentation-to-command-translator switch-via-tab-button (tab-page com-switch-to-tab-page clim:global-command-table :gesture :select :documentation "Switch to this page" :pointer-documentation "Switch to this page") (object) (list object)) (define-command (com-remove-tab-page :command-table clim:global-command-table) ((page 'tab-page :prompt "Tab page")) (remove-page page)) ;;; generic TAB-LAYOUT-PANE implementation (defclass tab-bar-view (gadget-view) ()) (defparameter +tab-bar-view+ (make-instance 'tab-bar-view)) (define-presentation-method present (tab-page (type tab-page) stream (view tab-bar-view) &key) (stream-increment-cursor-position stream 5 0) (multiple-value-bind (x y) (stream-cursor-position stream) (let* ((length-top-line (+ x 6 (text-size stream (tab-page-title tab-page)) 3)) (tab-button-polygon (list x (+ y 14) (+ x 6) y (+ x 6) y length-top-line y length-top-line y (+ length-top-line 6) (+ y 14)))) ;; grey-filled polygone for the disabled panes (unless (sheet-enabled-p (tab-page-pane tab-page)) (draw-polygon* stream tab-button-polygon :ink +grey+)) ;; black non-filled polygon (draw-polygon* stream tab-button-polygon :ink +black+ :filled nil) ;; "breach" the underline for the enabled pane (when (sheet-enabled-p (tab-page-pane tab-page)) (draw-line stream (apply #'make-point (subseq tab-button-polygon 0 2)) (apply #'make-point (subseq tab-button-polygon (- (length tab-button-polygon) 2))) :ink +background-ink+)))) (stream-increment-cursor-position stream 8 0) (apply #'invoke-with-drawing-options stream (lambda (rest) (declare (ignore rest)) (write-string (tab-page-title tab-page) stream)) (tab-page-drawing-options tab-page)) (stream-increment-cursor-position stream 10 0)) (defclass tab-layout-pane (tab-layout) ((header-pane :accessor tab-layout-header-pane :initarg :header-pane) (header-display-function :accessor header-display-function :initarg :header-display-function :initform 'default-display-tab-header)) (:documentation "A pure-lisp implementation of the tab-layout, this is the generic implementation chosen by the CLX frame manager automatically. Users should create panes for type TAB-LAYOUT, not TAB-LAYOUT-PANE, so that the frame manager can customize the implementation.")) (defmethod (setf tab-layout-enabled-page) (page (parent tab-layout-pane)) (let ((old-page (tab-layout-enabled-page parent))) (unless (equal page old-page) (when old-page (setf (sheet-enabled-p (tab-page-pane old-page)) nil)) (when page (setf (sheet-enabled-p (tab-page-pane page)) t))) (when page (setf (sheet-enabled-p (tab-page-pane page)) t))) (call-next-method)) (defun default-display-tab-header (tab-layout pane) (stream-increment-cursor-position pane 0 3) (draw-line* pane 0 17 (slot-value pane 'climi::current-width) 17 :ink +black+) (mapc (lambda (page) (with-output-as-presentation (pane (tab-page-pane page) (tab-page-presentation-type page)) (present page 'tab-page :stream pane))) (tab-layout-pages tab-layout))) (defclass tab-bar-pane (application-pane) () (:default-initargs :default-view +tab-bar-view+)) (defmethod compose-space ((pane tab-bar-pane) &key width height) (declare (ignore width height)) (make-space-requirement :min-height 22 :height 22 :max-height 22)) (defmethod initialize-instance :after ((instance tab-layout-pane) &key pages) (let ((current (tab-layout-enabled-page instance))) (dolist (page pages) (setf (sheet-enabled-p (tab-page-pane page)) (eq page current)))) (let ((header (make-pane 'tab-bar-pane :display-time :command-loop :display-function (lambda (frame pane) (declare (ignore frame)) (funcall (header-display-function instance) instance pane))))) (setf (tab-layout-header-pane instance) header) (sheet-adopt-child instance header) (setf (sheet-enabled-p header) t))) (defmethod compose-space ((pane tab-layout-pane) &key width height) (declare (ignore width height)) (let ((q (compose-space (tab-layout-header-pane pane)))) (space-requirement+* (reduce (lambda (x y) (space-requirement-combine #'max x y)) (mapcar #'compose-space (sheet-children pane)) :initial-value (make-space-requirement :width 0 :min-width 0 :max-width 0 :height 0 :min-height 0 :max-height 0)) :height (space-requirement-height q) :min-height (space-requirement-min-height q) :max-height (space-requirement-max-height q)))) (defmethod allocate-space ((pane tab-layout-pane) width height) (let* ((header (tab-layout-header-pane pane)) (y (space-requirement-height (compose-space header)))) (move-and-resize-sheet header 0 0 width y) (allocate-space header width y) (dolist (page (tab-layout-pages pane)) (let ((child (tab-page-pane page))) (move-and-resize-sheet child 0 y width (- height y)) (allocate-space child width (- height y)))))) (defmethod internal-child-p (child (parent tab-layout-pane)) (eq child (tab-layout-header-pane parent))) (defmethod clim-tab-layout:note-tab-page-changed ((layout tab-layout-pane) page) (redisplay-frame-pane (pane-frame layout) (tab-layout-header-pane layout) #+NIL (car (sheet-children (car (sheet-children (tab-layout-header-pane layout))))) :force-p t)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Extensions/Bitmap-formats/0000755000175000017500000000000011347763412022033 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Extensions/Bitmap-formats/gif.lisp0000644000175000017500000000416511000705146023461 0ustar pdmpdm;;; -*- Mode: Lisp; Package: MCCLIM-IMAGES -*- ;;; (c) copyright 2008 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) (define-bitmap-file-reader :gif (image-pathname) (let* ((data-stream (skippy:load-data-stream image-pathname)) (first-image (aref (skippy:images data-stream) 0)) (image-height (skippy:height first-image)) (image-width (skippy:width first-image)) (pattern-array (make-array (list image-height image-width))) (designs (coerce (loop with color-table = (skippy:color-table data-stream) with transparency-index = (skippy:transparency-index first-image) for i below (skippy:color-table-size color-table) when (and transparency-index (= i transparency-index)) collect +transparent-ink+ else collect (multiple-value-bind (r g b) (skippy:color-rgb (skippy:color-table-entry color-table i)) (make-rgb-color (/ r 255) (/ g 255) (/ b 255)))) 'vector))) (dotimes (y image-height) (dotimes (x image-width) (setf (aref pattern-array y x) (skippy:pixel-ref first-image x y)))) (values pattern-array designs))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Extensions/Bitmap-formats/jpeg.lisp0000644000175000017500000000426511212662261023647 0ustar pdmpdm;;; -*- Mode: Lisp; Package: MCCLIM-IMAGES -*- ;;; (c) copyright 2008 ;;; Eric Marsden ;;; (c) copyright 2008 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) (define-bitmap-file-reader :jpeg (pathname) (multiple-value-bind (rgb height width ncomp) (jpeg:decode-image pathname) (let* ((array (make-array (list height width) :element-type '(unsigned-byte 32)))) (case ncomp (3 (dotimes (x width) (dotimes (y height) (let ((blue (aref rgb (+ (* x 3) (* y width 3)))) (green (aref rgb (+ (* x 3) (* y width 3) 1))) (red (aref rgb (+ (* x 3) (* y width 3) 2)))) (setf (aref array y x) (dpb red (byte 8 0) (dpb green (byte 8 8) (dpb blue (byte 8 16) (dpb (- 255 0) (byte 8 24) 0))))))))) (1 (dotimes (x width) (dotimes (y height) (let ((gray (aref rgb (+ x (* y width))))) (setf (aref array y x) (dpb gray (byte 8 0) (dpb gray (byte 8 8) (dpb gray (byte 8 16) (dpb (- 255 0) (byte 8 24) 0)))))))))) array))) (define-bitmap-file-reader :jpg (pathname) (read-bitmap-file pathname :format :jpeg)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Extensions/Bitmap-formats/png.lisp0000644000175000017500000000362311247400250023477 0ustar pdmpdm;;; -*- Mode: Lisp; Package: MCCLIM-IMAGES -*- ;;; (c) copyright 2009 by ;;; Samium Gromoff (_deepfire@feelingofgreen.ru) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) (define-bitmap-file-reader :png (image-pathname) (let* ((png-state (png-read:read-png-file image-pathname)) (data (png-read:image-data png-state)) (depth (png-read:bit-depth png-state)) (height (png-read:height png-state)) (width (png-read:width png-state)) (array (make-array (list height width) :element-type '(unsigned-byte 32)))) (unless (member depth '(8 32)) (error "~@" depth)) (dotimes (y height) (dotimes (x width) (case depth ((8 32) (let ((red (aref data x y 0)) (green (aref data x y 1)) (blue (aref data x y 2))) (setf (aref array y x) (dpb red (byte 8 0) (dpb green (byte 8 8) (dpb blue (byte 8 16) (dpb (- 255 0) (byte 8 24) 0)))))))))) array)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Extensions/Bitmap-formats/tiff.lisp0000644000175000017500000000461211213221275023643 0ustar pdmpdm;;; -*- Mode: Lisp; Package: MCCLIM-IMAGES -*- ;;; (c) copyright 2009 by ;;; Cyrus Harmon (ch-lisp@bobobeach.com) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) (define-bitmap-file-reader :tiff (pathname) (let ((tiff-image (tiff:read-tiff-file pathname))) (with-accessors ((height tiff:tiff-image-length) (width tiff:tiff-image-width) (ncomp tiff:tiff-image-samples-per-pixel) (data tiff:tiff-image-data)) tiff-image (let* ((array (make-array (list height width) :element-type '(unsigned-byte 32)))) (case ncomp (3 (dotimes (x width) (dotimes (y height) (let ((red (aref data (+ (* x 3) (* y width 3)))) (green (aref data (+ (* x 3) (* y width 3) 1))) (blue (aref data (+ (* x 3) (* y width 3) 2)))) (setf (aref array y x) (dpb red (byte 8 0) (dpb green (byte 8 8) (dpb blue (byte 8 16) (dpb (- 255 0) (byte 8 24) 0))))))))) (1 (dotimes (x width) (dotimes (y height) (let ((gray (aref data (+ x (* y width))))) (setf (aref array y x) (dpb gray (byte 8 0) (dpb gray (byte 8 8) (dpb gray (byte 8 16) (dpb (- 255 0) (byte 8 24) 0)))))))))) array)))) (define-bitmap-file-reader :tif (pathname) (read-bitmap-file pathname :format :tiff)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/package.lisp0000644000175000017500000032632411345155771017306 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- (in-package :common-lisp-user) ;;; ;;; CLIM-LISP ;;; ;; Our CLIM-LISP also contains gray streams, as I consider them part ;; of Common Lisp. ;; If you want to patch a CL symbol, you define it in CLIM-LISP-PATCH ;; and export it. #.(let ((all-ansi-symbols '(#:&allow-other-keys #:&aux #:&body #:&environment #:&key #:&optional #:&rest #:&whole #:* #:** #:*** #:*break-on-signals* #:*compile-file-pathname* #:*compile-file-truename* #:*compile-print* #:*compile-verbose* #:*debug-io* #:*debugger-hook* #:*default-pathname-defaults* #:*error-output* #:*features* #:*gensym-counter* #:*load-pathname* #:*load-print* #:*load-truename* #:*load-verbose* #:*macroexpand-hook* #:*modules* #:*package* #:*print-array* #:*print-base* #:*print-case* #:*print-circle* #:*print-escape* #:*print-gensym* #:*print-length* #:*print-level* #:*print-lines* #:*print-miser-width* #:*print-pprint-dispatch* #:*print-pretty* #:*print-radix* #:*print-readably* #:*print-right-margin* #:*query-io* #:*random-state* #:*read-base* #:*read-default-float-format* #:*read-eval* #:*read-suppress* #:*readtable* #:*standard-input* #:*standard-output* #:*terminal-io* #:*trace-output* #:+ #:++ #:+++ #:- #:/ #:// #:/// #:/= #:1+ #:1- #:< #:<= #:= #:> #:>= #:abort #:abs #:acons #:acos #:acosh #:add-method #:adjoin #:adjust-array #:adjustable-array-p #:allocate-instance #:alpha-char-p #:alphanumericp #:and #:append #:apply #:apropos #:apropos-list #:aref #:arithmetic-error #:arithmetic-error-operands #:arithmetic-error-operation #:array #:array-dimension #:array-dimension-limit #:array-dimensions #:array-displacement #:array-element-type #:array-has-fill-pointer-p #:array-in-bounds-p #:array-rank #:array-rank-limit #:array-row-major-index #:array-total-size #:array-total-size-limit #:arrayp #:ash #:asin #:asinh #:assert #:assoc #:assoc-if #:assoc-if-not #:atan #:atanh #:atom #:base-char #:base-string #:bignum #:bit #:bit-and #:bit-andc1 #:bit-andc2 #:bit-eqv #:bit-ior #:bit-nand #:bit-nor #:bit-not #:bit-orc1 #:bit-orc2 #:bit-vector #:bit-vector-p #:bit-xor #:block #:boole #:boole-1 #:boole-2 #:boole-and #:boole-andc1 #:boole-andc2 #:boole-c1 #:boole-c2 #:boole-clr #:boole-eqv #:boole-ior #:boole-nand #:boole-nor #:boole-orc1 #:boole-orc2 #:boole-set #:boole-xor #:boolean #:both-case-p #:boundp #:break #:broadcast-stream #:broadcast-stream-streams #:built-in-class #:butlast #:byte #:byte-position #:byte-size #:caaaar #:caaadr #:caaar #:caadar #:caaddr #:caadr #:caar #:cadaar #:cadadr #:cadar #:caddar #:cadddr #:caddr #:cadr #:call-arguments-limit #:call-method #:call-next-method #:car #:case #:catch #:ccase #:cdaaar #:cdaadr #:cdaar #:cdadar #:cdaddr #:cdadr #:cdar #:cddaar #:cddadr #:cddar #:cdddar #:cddddr #:cdddr #:cddr #:cdr #:ceiling #:cell-error #:cell-error-name #:cerror #:change-class #:char #:char-code #:char-code-limit #:char-downcase #:char-equal #:char-greaterp #:char-int #:char-lessp #:char-name #:char-not-equal #:char-not-greaterp #:char-not-lessp #:char-upcase #:char/= #:char< #:char<= #:char= #:char> #:char>= #:character #:characterp #:check-type #:cis #:class #:class-name #:class-of #:clear-input #:clear-output #:close #:clrhash #:code-char #:coerce #:compilation-speed #:compile #:compile-file #:compile-file-pathname #:compiled-function #:compiled-function-p #:compiler-macro #:compiler-macro-function #:complement #:complex #:complexp #:compute-applicable-methods #:compute-restarts #:concatenate #:concatenated-stream #:concatenated-stream-streams #:cond #:condition #:conjugate #:cons #:consp #:constantly #:constantp #:continue #:control-error #:copy-alist #:copy-list #:copy-pprint-dispatch #:copy-readtable #:copy-seq #:copy-structure #:copy-symbol #:copy-tree #:cos #:cosh #:count #:count-if #:count-if-not #:ctypecase #:debug #:decf #:declaim #:declaration #:declare #:decode-float #:decode-universal-time #:defclass #:defconstant #:defgeneric #:define-compiler-macro #:define-condition #:define-method-combination #:define-modify-macro #:define-setf-expander #:define-symbol-macro #:defmacro #:defmethod #:defpackage #:defparameter #:defsetf #:defstruct #:deftype #:defun #:defvar #:delete #:delete-duplicates #:delete-file #:delete-if #:delete-if-not #:delete-package #:denominator #:deposit-field #:describe #:describe-object #:destructuring-bind #:digit-char #:digit-char-p #:directory #:directory-namestring #:disassemble #:division-by-zero #:do #:do* #:do-all-symbols #:do-external-symbols #:do-symbols #:documentation #:dolist #:dotimes #:double-float #:double-float-epsilon #:double-float-negative-epsilon #:dpb #:dribble #:dynamic-extent #:ecase #:echo-stream #:echo-stream-input-stream #:echo-stream-output-stream #:ed #:eighth #:elt #:encode-universal-time #:end-of-file #:endp #:enough-namestring #:ensure-directories-exist #:ensure-generic-function #:eq #:eql #:equal #:equalp #:error #:etypecase #:eval #:eval-when #:evenp #:every #:exp #:export #:expt #:extended-char #:fboundp #:fceiling #:fdefinition #:ffloor #:fifth #:file-author #:file-error #:file-error-pathname #:file-length #:file-namestring #:file-position #:file-stream #:file-string-length #:file-write-date #:fill #:fill-pointer #:find #:find-all-symbols #:find-class #:find-if #:find-if-not #:find-method #:find-package #:find-restart #:find-symbol #:finish-output #:first #:fixnum #:flet #:float #:float-digits #:float-precision #:float-radix #:float-sign #:floating-point-inexact #:floating-point-invalid-operation #:floating-point-overflow #:floating-point-underflow #:floatp #:floor #:fmakunbound #:force-output #:format #:formatter #:fourth #:fresh-line #:fround #:ftruncate #:ftype #:funcall #:function #:function-keywords #:function-lambda-expression #:functionp #:gcd #:generic-function #:gensym #:gentemp #:get #:get-decoded-time #:get-dispatch-macro-character #:get-internal-real-time #:get-internal-run-time #:get-macro-character #:get-output-stream-string #:get-properties #:get-setf-expansion #:get-universal-time #:getf #:gethash #:go #:graphic-char-p #:handler-bind #:handler-case #:hash-table #:hash-table-count #:hash-table-p #:hash-table-rehash-size #:hash-table-rehash-threshold #:hash-table-size #:hash-table-test #:host-namestring #:identity #:if #:ignorable #:ignore #:ignore-errors #:imagpart #:import #:in-package #:incf #:initialize-instance #:inline #:input-stream-p #:inspect #:integer #:integer-decode-float #:integer-length #:integerp #:interactive-stream-p #:intern #:internal-time-units-per-second #:intersection #:invalid-method-error #:invoke-debugger #:invoke-restart #:invoke-restart-interactively #:isqrt #:keyword #:keywordp #:labels #:lambda #:lambda-list-keywords #:lambda-parameters-limit #:last #:lcm #:ldb #:ldb-test #:ldiff #:least-negative-double-float #:least-negative-long-float #:least-negative-normalized-double-float #:least-negative-normalized-long-float #:least-negative-normalized-short-float #:least-negative-normalized-single-float #:least-negative-short-float #:least-negative-single-float #:least-positive-double-float #:least-positive-long-float #:least-positive-normalized-double-float #:least-positive-normalized-long-float #:least-positive-normalized-short-float #:least-positive-normalized-single-float #:least-positive-short-float #:least-positive-single-float #:length #:let #:let* #:lisp-implementation-type #:lisp-implementation-version #:list #:list* #:list-all-packages #:list-length #:listen #:listp #:load #:load-logical-pathname-translations #:load-time-value #:locally #:log #:logand #:logandc1 #:logandc2 #:logbitp #:logcount #:logeqv #:logical-pathname #:logical-pathname-translations #:logior #:lognand #:lognor #:lognot #:logorc1 #:logorc2 #:logtest #:logxor #:long-float #:long-float-epsilon #:long-float-negative-epsilon #:long-site-name #:loop #:loop-finish #:lower-case-p #:machine-instance #:machine-type #:machine-version #:macro-function #:macroexpand #:macroexpand-1 #:macrolet #:make-array #:make-broadcast-stream #:make-concatenated-stream #:make-condition #:make-dispatch-macro-character #:make-echo-stream #:make-hash-table #:make-instance #:make-instances-obsolete #:make-list #:make-load-form #:make-load-form-saving-slots #:make-method #:make-package #:make-pathname #:make-random-state #:make-sequence #:make-string #:make-string-input-stream #:make-string-output-stream #:make-symbol #:make-synonym-stream #:make-two-way-stream #:makunbound #:map #:map-into #:mapc #:mapcan #:mapcar #:mapcon #:maphash #:mapl #:maplist #:mask-field #:max #:member #:member-if #:member-if-not #:merge #:merge-pathnames #:method #:method-combination #:method-combination-error #:method-qualifiers #:min #:minusp #:mismatch #:mod #:most-negative-double-float #:most-negative-fixnum #:most-negative-long-float #:most-negative-short-float #:most-negative-single-float #:most-positive-double-float #:most-positive-fixnum #:most-positive-long-float #:most-positive-short-float #:most-positive-single-float #:muffle-warning #:multiple-value-bind #:multiple-value-call #:multiple-value-list #:multiple-value-prog1 #:multiple-value-setq #:multiple-values-limit #:name-char #:namestring #:nbutlast #:nconc #:next-method-p #:nil #:nintersection #:ninth #:no-applicable-method #:no-next-method #:not #:notany #:notevery #:notinline #:nreconc #:nreverse #:nset-difference #:nset-exclusive-or #:nstring-capitalize #:nstring-downcase #:nstring-upcase #:nsublis #:nsubst #:nsubst-if #:nsubst-if-not #:nsubstitute #:nsubstitute-if #:nsubstitute-if-not #:nth #:nth-value #:nthcdr #:null #:number #:numberp #:numerator #:nunion #:oddp #:open #:open-stream-p #:optimize #:or #:otherwise #:output-stream-p #:package #:package-error #:package-error-package #:package-name #:package-nicknames #:package-shadowing-symbols #:package-use-list #:package-used-by-list #:packagep #:pairlis #:parse-error #:parse-integer #:parse-namestring #:pathname #:pathname-device #:pathname-directory #:pathname-host #:pathname-match-p #:pathname-name #:pathname-type #:pathname-version #:pathnamep #:peek-char #:phase #:pi #:plusp #:pop #:position #:position-if #:position-if-not #:pprint #:pprint-dispatch #:pprint-exit-if-list-exhausted #:pprint-fill #:pprint-indent #:pprint-linear #:pprint-logical-block #:pprint-newline #:pprint-pop #:pprint-tab #:pprint-tabular #:prin1 #:prin1-to-string #:princ #:princ-to-string #:print #:print-not-readable #:print-not-readable-object #:print-object #:print-unreadable-object #:probe-file #:proclaim #:prog #:prog* #:prog1 #:prog2 #:progn #:program-error #:progv #:provide #:psetf #:psetq #:push #:pushnew #:quote #:random #:random-state #:random-state-p #:rassoc #:rassoc-if #:rassoc-if-not #:ratio #:rational #:rationalize #:rationalp #:read #:read-byte #:read-char #:read-char-no-hang #:read-delimited-list #:read-from-string #:read-line #:read-preserving-whitespace #:read-sequence #:reader-error #:readtable #:readtable-case #:readtablep #:real #:realp #:realpart #:reduce #:reinitialize-instance #:rem #:remf #:remhash #:remove #:remove-duplicates #:remove-if #:remove-if-not #:remove-method #:remprop #:rename-file #:rename-package #:replace #:require #:rest #:restart #:restart-bind #:restart-case #:restart-name #:return #:return-from #:revappend #:reverse #:room #:rotatef #:round #:row-major-aref #:rplaca #:rplacd #:safety #:satisfies #:sbit #:scale-float #:schar #:search #:second #:sequence #:serious-condition #:set #:set-difference #:set-dispatch-macro-character #:set-exclusive-or #:set-macro-character #:set-pprint-dispatch #:set-syntax-from-char #:setf #:setq #:seventh #:shadow #:shadowing-import #:shared-initialize #:shiftf #:short-float #:short-float-epsilon #:short-float-negative-epsilon #:short-site-name #:signal #:signed-byte #:signum #:simple-array #:simple-base-string #:simple-bit-vector #:simple-bit-vector-p #:simple-condition #:simple-condition-format-arguments #:simple-condition-format-control #:simple-error #:simple-string #:simple-string-p #:simple-type-error #:simple-vector #:simple-vector-p #:simple-warning #:sin #:single-float #:single-float-epsilon #:single-float-negative-epsilon #:sinh #:sixth #:sleep #:slot-boundp #:slot-exists-p #:slot-makunbound #:slot-missing #:slot-unbound #:slot-value #:software-type #:software-version #:some #:sort #:space #:special #:special-operator-p #:speed #:sqrt #:stable-sort #:standard #:standard-char #:standard-char-p #:standard-class #:standard-generic-function #:standard-method #:standard-object #:step #:storage-condition #:store-value #:stream #:stream-element-type #:stream-error #:stream-error-stream #:stream-external-format #:streamp #:string #:string-capitalize #:string-downcase #:string-equal #:string-greaterp #:string-left-trim #:string-lessp #:string-not-equal #:string-not-greaterp #:string-not-lessp #:string-right-trim #:string-stream #:string-trim #:string-upcase #:string/= #:string< #:string<= #:string= #:string> #:string>= #:stringp #:structure #:structure-class #:structure-object #:style-warning #:sublis #:subseq #:subsetp #:subst #:subst-if #:subst-if-not #:substitute #:substitute-if #:substitute-if-not #:subtypep #:svref #:sxhash #:symbol #:symbol-function #:symbol-macrolet #:symbol-name #:symbol-package #:symbol-plist #:symbol-value #:symbolp #:synonym-stream #:synonym-stream-symbol #:t #:tagbody #:tailp #:tan #:tanh #:tenth #:terpri #:the #:third #:throw #:time #:trace #:translate-logical-pathname #:translate-pathname #:tree-equal #:truename #:truncate #:two-way-stream #:two-way-stream-input-stream #:two-way-stream-output-stream #:type #:type-error #:type-error-datum #:type-error-expected-type #:type-of #:typecase #:typep #:unbound-slot #:unbound-slot-instance #:unbound-variable #:undefined-function #:unexport #:unintern #:union #:unless #:unread-char #:unsigned-byte #:untrace #:unuse-package #:unwind-protect #:update-instance-for-different-class #:update-instance-for-redefined-class #:upgraded-array-element-type #:upgraded-complex-part-type #:upper-case-p #:use-package #:use-value #:user-homedir-pathname #:values #:values-list #:variable #:vector #:vector-pop #:vector-push #:vector-push-extend #:vectorp #:warn #:warning #:when #:wild-pathname-p #:with-accessors #:with-compilation-unit #:with-condition-restarts #:with-hash-table-iterator #:with-input-from-string #:with-open-file #:with-open-stream #:with-output-to-string #:with-package-iterator #:with-simple-restart #:with-slots #:with-standard-io-syntax #:write #:write-byte #:write-char #:write-line #:write-sequence #:write-string #:write-to-string #:y-or-n-p #:yes-or-no-p #:zerop)) (packages #+gcl '(:lisp :pcl) #-(or gcl) '(:common-lisp)) (gray-symbols '(#:fundamental-stream #:fundamental-input-stream #:fundamental-output-stream #:fundamental-character-stream #:fundamental-binary-stream #:fundamental-character-input-stream #:fundamental-character-output-stream #:fundamental-binary-input-stream #:fundamental-binary-output-stream #:stream-read-char #:stream-unread-char #:stream-read-char-no-hang #:stream-peek-char #:stream-listen #:stream-read-line #:stream-clear-input #:stream-write-char #:stream-line-column #:stream-start-line-p #:stream-write-string #:stream-terpri #:stream-fresh-line #:stream-finish-output #:stream-force-output #:stream-advance-to-column #:stream-clear-output #:stream-read-byte #:stream-write-byte )) (gray-packages `(#+clisp ,@'(:gray) #+cmu ,@'(:ext) #+scl ,@'(:ext) #+(or mcl openmcl) ,@'(:ccl) #+allegro ,@'(:common-lisp :excl :stream) #+harlequin-common-lisp ,@'(:stream) #+sbcl ,@'(:sb-gray))) ) ;; (labels ((seek-symbol (name packages) ;; seek the a symbol named 'name' in `packages' (or (some #'(lambda (p) (multiple-value-bind (sym res) (find-symbol (symbol-name name) p) (if (eql res :external) (list sym) nil))) packages) (progn (format t "~&there is no ~A." name) (force-output) nil))) (dump-defpackage (&aux imports export-ansi export-gray) (labels ((push-import-from (symbol package) (let ((pair (assoc package imports))) (if pair (push symbol (cdr pair)) (push `(,package . (,symbol)) imports)))) (grok (symbols packages) (let ((res nil)) (dolist (nam symbols) (let ((sym (seek-symbol nam packages))) (when sym (push (car sym) res) (cond ((and (find-package :clim-lisp-patch) (multiple-value-bind (sym2 res) (find-symbol (symbol-name nam) :clim-lisp-patch) (and sym2 (eq res :external)))) ;; (format t "~&;; ~S is patched." sym) (force-output) (push-import-from nam :clim-lisp-patch)) (t (setf sym (car sym)) ;; clisp has no (:import ..) arg! (push-import-from (symbol-name sym) (package-name (symbol-package sym)))))))) res))) ;; ;; Don't redefine a perfectly working CL:DESCRIBE, ;; which more often than not has special knowledge ;; about objects you can't possibly gain though some ;; portable implementation. ;; --GB 2004-11-20 (setf all-ansi-symbols (remove '#:describe all-ansi-symbols :test #'string-equal)) (setf all-ansi-symbols (remove '#:describe-object all-ansi-symbols :test #'string-equal)) ;; (setf export-ansi (grok all-ansi-symbols packages)) (setf export-gray (grok gray-symbols gray-packages)) `(progn (defpackage :clim-lisp (:use) ,@(mapcar (lambda (spec) (destructuring-bind (package . syms) spec `(:import-from ,package ,@syms))) imports) (:shadow #:describe #:describe-object) (:export #:describe #:describe-object) (:export ,@(mapcar #'symbol-name export-ansi) ,@(mapcar #'symbol-name export-gray) )) )))) (dump-defpackage) )) (defpackage :clim (:use) ;; (:import-from :clim-lisp #:and #:boolean #:character #:close #:complex #:float #:fundamental-binary-input-stream #:fundamental-binary-output-stream #:fundamental-binary-stream #:fundamental-character-input-stream #:fundamental-character-output-stream #:fundamental-character-stream #:fundamental-input-stream #:fundamental-output-stream #:fundamental-stream #:input-stream-p #:integer #:interactive-stream-p #:keyword #:member #:nil #:null #:number #:open-stream-p #:or #:output-stream-p #:pathname #:ratio #:rational #:real #:sequence #:stream-advance-to-column #:stream-clear-input #:stream-clear-output #:stream-element-type #:stream-finish-output #:stream-force-output #:stream-fresh-line #:stream-line-column #:stream-listen #:stream-peek-char #:stream-read-byte #:stream-read-char #:stream-read-char-no-hang #:stream-read-line #:stream-start-line-p #:stream-terpri #:stream-unread-char #:stream-write-byte #:stream-write-char #:stream-write-string #:streamp #:string #:symbol #:t) ;; (:export ;; this list of exported symbols was automatically generated from the ;; specification as of version 1.17 of this very file, please think twice ;; before fiddling with it. thanks! --gb 2002-11-10 #:*abort-gestures* ;variable #:*accelerator-gestures* ;variable #:*activation-gestures* ;variable #:*application-frame* ;variable #:*command-argument-delimiters* ;variable #:*command-dispatchers* ;variable #:*command-name-delimiters* ;variable #:*command-parser* ;variable #:*command-unparser* ;variable #:*completion-gestures* ;variable #:*default-frame-manager* ;variable #:*default-server-path* ;variable #:*default-text-style* ;constant #:*delimiter-gestures* ;variable #:*help-gestures* ;variable #:*input-context* ;variable #:*input-wait-handler* ;variable #:*input-wait-test* ;variable #:*null-presentation* ;constant #:*numeric-argument-marker* ;variable #:*original-stream* ;variable #:*partial-command-parser* ;variable #:*pointer-button-press-handler* ;variable #:*pointer-documentation-output* ;variable #:*possibilities-gestures* ;variable #:*standard-activation-gestures* ;variable #:*undefined-text-style* ;constant #:*unsupplied-argument-marker* ;variable #:+background-ink+ ;constant #:+black+ ;constant #:+blue+ ;constant #:+control-key+ ;constant #:+cyan+ ;constant #:+everywhere+ ;constant #:+fill+ ;constant #:+flipping-ink+ ;constant #:+foreground-ink+ ;constant #:+gadget-dialog-view+ ;constant #:+gadget-menu-view+ ;constant #:+gadget-view+ ;constant #:+green+ ;constant #:+hyper-key+ ;constant #:+identity-transformation+ ;constant #:+magenta+ ;constant #:+meta-key+ ;constant #:+nowhere+ ;constant #:+pointer-documentation-view+ ;constant #:+pointer-left-button+ ;constant #:+pointer-middle-button+ ;constant #:+pointer-right-button+ ;constant #:+red+ ;constant #:+shift-key+ ;constant #:+super-key+ ;constant #:+textual-dialog-view+ ;constant #:+textual-menu-view+ ;constant #:+textual-view+ ;constant #:+transparent-ink+ ;constant #:+white+ ;constant #:+yellow+ ;constant #:abort-gesture ;condition #:abort-gesture-event ;generic function #:accelerator-gesture ;condition #:accelerator-gesture-event ;generic function #:accelerator-gesture-numeric-argument ;generic function #:accept ;presentation method #:accept ;function #:accept-1 ;function #:accept-from-string ;function #:accept-present-default ;presentation method #:accept-values ;frame #:accept-values-command-button ;macro #:accept-values-resynchronize ;generic function #:accepting-values ;macro #:action-gadget ;class #:activate-callback ;callback #:activate-gadget ;generic function #:activation-gesture-p ;function #:add-character-output-to-text-record ;generic function #:add-command-to-command-table ;function #:add-gesture-name ;function #:add-input-editor-command ;function #:add-keystroke-to-command-table ;function #:add-menu-item-to-command-table ;function #:add-output-record ;generic function #:add-presentation-translator-to-command-table ;function #:add-string-output-to-text-record ;generic function #:adjust-item-list-cells ;generic function #:adjust-multiple-columns ;generic function #:adjust-table-cells ;generic function #:adopt-frame ;generic function #:allocate-medium ;generic function #:allocate-pixmap ;generic function #:allocate-space ;generic function #:and ;presentation type #:application-frame ;protocol class #:application-frame-p ;predicate #:application-pane ;pane #:apply-presentation-generic-function ;macro #:area ;protocol class #:areap ;predicate #:armed-callback ;callback #:augment-draw-set ;generic function #:basic-gadget ;class #:basic-medium ;class #:basic-pane ;class #:basic-port ;class #:basic-sheet ;class #:bboard-pane ;pane #:beep ;generic function #:blank-area ;presentation type #:boolean ;presentation type #:bounding-rectangle ;protocol class #:bounding-rectangle ;generic function #:bounding-rectangle* ;generic function #:bounding-rectangle-height ;generic function #:bounding-rectangle-max-x ;generic function #:bounding-rectangle-max-y ;generic function #:bounding-rectangle-min-x ;generic function #:bounding-rectangle-min-y ;generic function #:bounding-rectangle-p ;predicate #:bounding-rectangle-position ;generic function #:bounding-rectangle-size ;generic function #:bounding-rectangle-width ;generic function #:bury-frame ;generic function #:bury-mirror ;generic function #:bury-sheet ;generic function #:cache-output-record ;generic function #:call-presentation-menu ;function #:call-presentation-translator ;function #:cell-align-x ;generic function #:cell-align-y ;generic function #:cell-min-height ;generic function #:cell-min-width ;generic function #:cell-output-record ;protocol class #:cell-output-record-p ;predicate #:change-space-requirements ;generic function #:changing-space-requirements ;macro #:character ;presentation type #:check-box ;class #:check-box-current-selection ;generic function #:check-box-pane ;class #:check-box-selections ;generic function #:child-containing-position ;generic function #:children-overlapping-rectangle* ;generic function #:children-overlapping-region ;generic function #:class-presentation-type-name ;function #:clear-output-record ;generic function #:client-setting ;setf method (through no reader) #:clim-stream-pane ;pane #:close ;generic function #:color ;protocol class #:color-ihs ;generic function #:color-rgb ;generic function #:colorp ;predicate #:column-output-record ;protocol class #:column-output-record-p ;predicate #:command ;presentation type #:command-accessible-in-command-table-p ;function #:command-already-present ;error #:command-arguments ;function #:command-enabled ;generic function #:command-line-command-parser ;function #:command-line-command-unparser ;function #:command-line-name-for-command ;function #:command-line-read-remaining-arguments-for-partial-command ;function #:command-menu-item-options ;function #:command-menu-item-type ;function #:command-menu-item-value ;function #:command-menu-pane ;pane #:command-name ;presentation type #:command-name ;function #:command-name-from-symbol ;function #:command-not-accessible ;error #:command-not-present ;error #:command-or-form ;presentation type #:command-present-in-command-table-p ;function #:command-table ;protocol class #:command-table-already-exists ;error #:command-table-complete-input ;function #:command-table-error ;error #:command-table-inherit-from ;generic function #:command-table-name ;generic function #:command-table-not-found ;error #:command-table-p ;predicate #:complete-from-generator ;function #:complete-from-possibilities ;function #:complete-input ;function #:completing-from-suggestions ;macro #:completion ;presentation type #:complex ;presentation type #:compose-in ;generic function #:compose-out ;generic function #:compose-over ;generic function #:compose-rotation-with-transformation ;function #:compose-scaling-with-transformation ;function #:compose-space ;generic function #:compose-transformation-with-rotation ;function #:compose-transformation-with-scaling ;function #:compose-transformation-with-translation ;function #:compose-transformations ;generic function #:compose-translation-with-transformation ;function #:compute-difference-set ;generic function #:compute-new-output-records ;generic function #:contrasting-dash-pattern-limit ;generic function #:contrasting-inks-limit ;generic function #:coordinate ;type #:coordinate ;function #:copy-area ;generic function #:copy-from-pixmap ;function #:copy-textual-output-history ;function #:copy-to-pixmap ;function #:cursor ;protocol class #:cursor-active ;generic function #:cursor-focus ;generic function #:cursor-position ;generic function #:cursor-sheet ;generic function #:cursor-state ;generic function #:cursor-visibility ;generic function #:cursorp ;predicate #:deactivate-gadget ;generic function #:deallocate-medium ;generic function #:deallocate-pixmap ;generic function #:decache-child-output-record ;generic function #:default-describe-presentation-type ;function #:default-frame-top-level ;generic function #:define-application-frame ;macro #:define-border-type ;macro #:define-command ;macro #:define-command-table ;macro #:define-default-presentation-method ;macro #:define-drag-and-drop-translator ;macro #:define-gesture-name ;macro #:define-graph-type ;macro #:define-presentation-action ;macro #:define-presentation-generic-function ;macro #:define-presentation-method ;macro #:define-presentation-to-command-translator ;macro #:define-presentation-translator ;macro #:define-presentation-type ;macro #:define-presentation-type-abbreviation ;macro #:degraft-medium ;generic function #:delegate-sheet-delegate ;generic function #:delegate-sheet-input-mixin ;class #:delete-gesture-name ;function #:delete-output-record ;generic function #:delimiter-gesture-p ;function #:describe-presentation-type ;presentation method #:describe-presentation-type ;function #:design ;protocol class #:designp ;predicate #:destroy-frame ;generic function #:destroy-mirror ;generic function #:destroy-port ;generic function #:device-event ;class #:disable-frame ;generic function #:disarmed-callback ;callback #:disown-frame ;generic function #:dispatch-event ;generic function #:display-command-menu ;generic function #:display-command-table-menu ;generic function #:display-exit-boxes ;generic function #:displayed-output-record ;protocol class #:displayed-output-record-ink ;generic function #:displayed-output-record-p ;predicate #:distribute-event ;generic function #:do-command-table-inheritance ;macro #:document-presentation-translator ;function #:drag-callback ;callback #:drag-callback ;callback #:drag-output-record ;generic function #:dragging-output ;macro #:draw-arrow ;function #:draw-arrow* ;function #:draw-circle ;function #:draw-circle* ;function #:draw-design ;generic function #:draw-ellipse ;function #:draw-ellipse* ;function #:draw-line ;function #:draw-line* ;function #:draw-lines ;function #:draw-lines* ;function #:draw-oval ;function #:draw-oval* ;function #:draw-pattern* ;function #:draw-point ;function #:draw-point* ;function #:draw-points ;function #:draw-points* ;function #:draw-polygon ;function #:draw-polygon* ;function #:draw-rectangle ;function #:draw-rectangle* ;function #:draw-rectangles ;function #:draw-rectangles* ;function #:draw-standard-menu ;function #:draw-text ;function #:draw-text* ;function #:ellipse ;protocol class #:ellipse-center-point ;generic function #:ellipse-center-point* ;generic function #:ellipse-end-angle ;generic function #:ellipse-radii ;generic function #:ellipse-start-angle ;generic function #:ellipsep ;predicate #:elliptical-arc ;protocol class #:elliptical-arc-p ;predicate #:enable-frame ;generic function #:encapsulating-stream ;protocol class #:encapsulating-stream-p ;predicate #:encapsulating-stream-stream ;generic function #:engraft-medium ;generic function #:erase-input-buffer ;generic function #:erase-output-record ;generic function #:even-scaling-transformation-p ;generic function #:event ;protocol class #:event-listen ;generic function #:event-matches-gesture-name-p ;function #:event-modifier-state ;generic function #:event-peek ;generic function #:event-read ;generic function #:event-read-no-hang ;generic function #:event-sheet ;generic function #:event-timestamp ;generic function #:event-type ;generic function #:event-unread ;generic function #:eventp ;predicate #:execute-frame-command ;generic function #:expand-presentation-type-abbreviation ;function #:expand-presentation-type-abbreviation-1 ;function #:expression ;presentation type #:extended-input-stream ;protocol class #:extended-input-stream-p ;predicate #:extended-output-stream ;protocol class #:extended-output-stream-p ;predicate #:filling-output ;macro #:find-applicable-translators ;function #:find-cached-output-record ;generic function #:find-child-output-record ;generic function #:find-command-from-command-line-name ;function #:find-command-table ;function #:find-frame-manager ;function #:find-graft ;function #:find-innermost-applicable-presentation ;function #:find-keystroke-item ;function #:find-menu-item ;function #:find-pane-for-frame ;generic function #:find-pane-named ;generic function #:find-port ;function #:find-presentation-translator ;function #:find-presentation-translators ;function #:find-presentation-type-class ;function #:float ;presentation type #:form ;presentation type #:format-graph-from-roots ;function #:format-items ;function #:format-textual-list ;function #:formatting-cell ;macro #:formatting-column ;macro #:formatting-item-list ;macro #:formatting-row ;macro #:formatting-table ;macro #:frame-all-layouts ;generic function #:frame-calling-frame ;generic function #:frame-command-table ;generic function #:frame-current-layout ;generic function #:frame-current-panes ;generic function #:frame-document-highlighted-presentation ;generic function #:frame-drag-and-drop-feedback ;generic function #:frame-drag-and-drop-highlighting ;generic function #:frame-error-output ;generic function #:frame-exit ;condition #:frame-exit ;generic function #:frame-exit-frame ;generic function #:frame-find-innermost-applicable-presentation ;generic function #:frame-input-context-button-press-handler ;generic function #:frame-maintain-presentation-histories ;generic function #:frame-manager ;protocol class #:frame-manager ;generic function #:frame-manager-frames ;generic function #:frame-manager-menu-choose ;generic function #:frame-manager-notify-user ;generic function #:frame-mananger-p ;predicate #:frame-name ;generic function #:frame-panes ;generic function #:frame-parent ;generic function #:frame-pointer-documentation-output ;generic function #:frame-pretty-name ;generic function #:frame-properties ;generic function #:frame-query-io ;generic function #:frame-replay ;generic function #:frame-standard-input ;generic function #:frame-standard-output ;generic function #:frame-state ;generic function #:frame-top-level-sheet ;generic function #:funcall-presentation-generic-function ;macro #:fundamental-binary-input-stream ;class #:fundamental-binary-output-stream ;class #:fundamental-binary-stream ;class #:fundamental-character-input-stream ;class #:fundamental-character-output-stream ;class #:fundamental-character-stream ;class #:fundamental-input-stream ;class #:fundamental-output-stream ;class #:fundamental-stream ;class #:gadget ;protocol class #:gadget-activate-callback ;generic function #:gadget-active-p ;generic function #:gadget-armed-callback ;generic function #:gadget-client ;generic function #:gadget-dialog-view ;class #:gadget-disarmed-callback ;generic function #:gadget-id ;generic function #:gadget-label ;generic function #:gadget-label-align-x ;generic function #:gadget-label-align-y ;generic function #:gadget-max-value ;generic function #:gadget-menu-view ;class #:gadget-min-value ;generic function #:gadget-orientation ;generic function #:gadget-output-record ;class #:gadget-range ;generic function #:gadget-range* ;generic function #:gadget-show-value-p ;generic function #:gadget-value ;generic function #:gadget-value-changed-callback ;generic function #:gadget-view ;class #:gadgetp ;predicate #:generate-graph-nodes ;generic function #:generate-panes ;generic function #:generic-list-pane ;class #:generic-option-pane ;class #:get-frame-pane ;generic function #:global-command-table ;command table #:graft ;generic function #:graft-height ;generic function #:graft-orientation ;generic function #:graft-pixels-per-inch ;function #:graft-pixels-per-millimeter ;function #:graft-units ;generic function #:graft-width ;generic function #:graph-node-children ;generic function #:graph-node-object ;generic function #:graph-node-output-record ;protocol class #:graph-node-output-record-p ;predicate #:graph-node-parents ;generic function #:graph-output-record ;protocol class #:graph-output-record-p ;predicate #:graph-root-nodes ;generic function #:graphics-displayed-output-record ;protocol class #:graphics-displayed-output-record-p ;predicate #:grid-pane ;pane #:handle-event ;generic function #:handle-repaint ;generic function #:hbox-pane ;pane #:highlight-applicable-presentation ;function #:highlight-output-record ;generic function #:highlight-presentation ;presentation method #:horizontally ;macro #:hrack-pane ;pane #:identity-transformation-p ;generic function #:immediate-repainting-mixin ;class #:immediate-rescan ;generic function #:immediate-sheet-input-mixin ;class #:incremental-redisplay ;generic function #:indenting-output ;macro #:input-context-type ;function #:input-editing-stream ;protocol class #:input-editing-stream-p ;predicate #:input-editor-format ;generic function #:input-not-of-required-type ;error #:input-not-of-required-type ;function #:input-stream-p ;generic function #:integer ;presentation type #:interactive-stream-p ;predicate #:interactor-pane ;pane #:invalidate-cached-regions ;generic function #:invalidate-cached-transformations ;generic function #:invert-transformation ;generic function #:invertible-transformation-p ;generic function #:invoke-updating-output ;generic function #:invoke-with-drawing-options ;generic function #:invoke-with-new-output-record ;generic function #:invoke-with-output-recording-options ;generic function #:invoke-with-output-to-output-record ;generic function #:invoke-with-text-style ;generic function #:item-list-output-record ;protocol class #:item-list-output-record-p ;predicate #:key-press-event ;class #:key-release-event ;class #:keyboard-event ;class #:keyboard-event-character ;generic function #:keyboard-event-key-name ;generic function #:keyword ;presentation type #:label-pane ;pane #:labelled-gadget-mixin ;class #:labelling ;macro #:layout-frame ;generic function #:layout-graph-edges ;generic function #:layout-graph-nodes ;generic function #:line ;protocol class #:line-end-point ;generic function #:line-end-point* ;generic function #:line-start-point ;generic function #:line-start-point* ;generic function #:line-style ;protocol class #:line-style-cap-shape ;generic function #:line-style-dashes ;generic function #:line-style-joint-shape ;generic function #:line-style-p ;predicate #:line-style-thickness ;generic function #:line-style-unit ;generic function #:linep ;predicate #:list-pane ;class #:lookup-keystroke-command-item ;function #:lookup-keystroke-item ;function #:make-3-point-transformation ;function #:make-3-point-transformation* ;function #:make-application-frame ;function #:make-bounding-rectangle ;function #:make-clim-application-pane ;function #:make-clim-interactor-pane ;function #:make-clim-stream-pane ;function #:make-command-table ;function #:make-contrasting-dash-patterns ;function #:make-contrasting-inks ;function #:make-design-from-output-record ;generic function #:make-device-font-text-style ;function #:make-ellipse ;function #:make-ellipse* ;function #:make-elliptical-arc ;function #:make-elliptical-arc* ;function #:make-flipping-ink ;function #:make-gray-color ;function #:make-ihs-color ;function #:make-line ;function #:make-line* ;function #:make-line-style ;function #:make-medium ;generic function #:make-modifier-state ;function #:make-opacity ;function #:make-pane ;function #:make-pane-1 ;generic function #:make-pattern ;function #:make-pattern-from-bitmap-file ;function #:make-point ;function #:make-polygon ;function #:make-polygon* ;function #:make-polyline ;function #:make-polyline* ;function #:make-presentation-type-specifier ;function #:make-rectangle ;function #:make-rectangle* ;function #:make-rectangular-tile ;function #:make-reflection-transformation ;function #:make-reflection-transformation* ;function #:make-rgb-color ;function #:make-rotation-transformation ;function #:make-rotation-transformation* ;function #:make-scaling-transformation ;function #:make-scaling-transformation* ;function #:make-space-requirement ;function #:make-stencil ;function #:make-text-style ;function #:make-transformation ;function #:make-translation-transformation ;function #:map-over-command-table-commands ;function #:map-over-command-table-keystrokes ;function #:map-over-command-table-menu-items ;function #:map-over-command-table-names ;function #:map-over-command-table-translators ;function #:map-over-frames ;function #:map-over-grafts ;function #:map-over-item-list-cells ;generic function #:map-over-output-records ;generic function #:map-over-output-records-containing-position ;generic function #:map-over-output-records-overlapping-region ;generic function #:map-over-polygon-coordinates ;generic function #:map-over-polygon-segments ;generic function #:map-over-ports ;function #:map-over-presentation-type-supertypes ;presentation method #:map-over-presentation-type-supertypes ;function #:map-over-region-set-regions ;generic function #:map-over-row-cells ;generic function #:map-over-row-cells ;generic function #:map-over-sheets ;generic function #:map-over-sheets-containing-position ;generic function #:map-over-sheets-overlapping-region ;generic function #:map-over-table-elements ;generic function #:map-sheet-position-to-child ;generic function #:map-sheet-position-to-parent ;generic function #:map-sheet-rectangle*-to-child ;generic function #:map-sheet-rectangle*-to-parent ;generic function #:match-output-records ;generic function #:medium ;protocol class #:medium-background ;generic function #:medium-background ;generic function #:medium-beep ;generic function #:medium-buffering-output-p ;generic function #:medium-clear-area ;generic function #:medium-clipping-region ;generic function #:medium-clipping-region ;generic function #:medium-copy-area ;generic function #:medium-current-text-style ;generic function #:medium-default-text-style ;generic function #:medium-default-text-style ;generic function #:medium-draw-ellipse* ;generic function #:medium-draw-line* ;generic function #:medium-draw-lines* ;generic function #:medium-draw-point* ;generic function #:medium-draw-points* ;generic function #:medium-draw-polygon* ;generic function #:medium-draw-rectangle* ;generic function #:medium-draw-rectangles* ;generic function #:medium-draw-text* ;generic function #:medium-drawable ;generic function #:medium-finish-output ;generic function #:medium-force-output ;generic function #:medium-foreground ;generic function #:medium-foreground ;generic function #:medium-ink ;generic function #:medium-ink ;generic function #:medium-line-style ;generic function #:medium-line-style ;generic function #:medium-merged-text-style ;generic function #:medium-sheet ;generic function #:medium-text-style ;generic function #:medium-text-style ;generic function #:medium-transformation ;generic function #:medium-transformation ;generic function #:mediump ;predicate #:member ;presentation type abbrev #:member-alist ;presentation type abbrev #:member-sequence ;presentation type abbrev #:menu-button ;class #:menu-button-pane ;class #:menu-choose ;generic function #:menu-choose-command-from-command-table ;function #:menu-choose-from-drawer ;generic function #:menu-command-parser ;function #:menu-item ;presentation type (mentioned in the description of draw-standard-menu) #:menu-item-display ;function #:menu-item-options ;function #:menu-item-value ;function #:menu-read-remaining-arguments-for-partial-command ;function #:merge-text-styles ;generic function #:mirrored-sheet-mixin ;class #:modifier-state-matches-gesture-name-p ;function #:move-and-resize-sheet ;generic function #:move-sheet ;generic function #:new-page ;function #:nil ;presentation type #:note-command-disabled ;generic function #:note-command-enabled ;generic function #:note-frame-deiconified ;generic function #:note-frame-disabled ;generic function #:note-frame-enabled ;generic function #:note-frame-iconified ;generic function #:note-gadget-activated ;generic function #:note-gadget-deactivated ;generic function #:note-output-record-child-changed ;generic function #:note-sheet-adopted ;generic function #:note-sheet-degrafted ;generic function #:note-sheet-disabled ;generic function #:note-sheet-disowned ;generic function #:note-sheet-enabled ;generic function #:note-sheet-grafted ;generic function #:note-sheet-region-changed ;generic function #:note-sheet-transformation-changed ;generic function #:note-space-requirements-changed ;generic function #:notify-user ;generic function #:null ;presentation type #:null-or-type ;presentation type abbrev #:number ;presentation type #:opacity ;protocol class #:opacity-value ;generic function #:opacityp ;predicate #:open-stream-p ;generic function #:open-window-stream ;function #:option-pane ;class #:or ;presentation type #:oriented-gadget-mixin ;class #:outlined-pane ;pane #:outlining ;macro #:output-record ;protocol class #:output-record-cache-value ;generic function #:output-record-children ;generic function #:output-record-contents-ok ;generic function #:output-record-count ;generic function #:output-record-displayer ;generic function #:output-record-end-cursor-position ;generic function #:output-record-fixed-position ;generic function #:output-record-hit-detection-rectangle* ;generic function #:output-record-p ;predicate #:output-record-parent ;generic function #:output-record-position ;generic function #:output-record-refined-position-test ;generic function #:output-record-start-cursor-position ;generic function #:output-record-unique-id ;generic function #:output-recording-stream ;protocol class #:output-recording-stream-p ;predicate #:output-stream-p ;generic function #:pane ;protocol class #:pane-background ;generic function #:pane-foreground ;generic function #:pane-frame ;generic function #:pane-name ;generic function #:pane-needs-redisplay ;generic function #:pane-scroller ;generic function #:pane-text-style ;generic function #:pane-viewport ;generic function #:pane-viewport-region ;generic function #:panep ;predicate #:parse-text-style ;function #:partial-command-p ;function #:path ;protocol class #:pathname ;presentation type #:pathp ;predicate #:pattern-height ;generic function #:pattern-width ;generic function #:permanent-medium-sheet-output-mixin ;class #:pixmap-depth ;generic function #:pixmap-height ;generic function #:pixmap-width ;generic function #:point ;protocol class #:point-position ;generic function #:point-x ;generic function #:point-y ;generic function #:pointer ;protocol class #:pointer-boundary-event ;class #:pointer-boundary-event-kind ;generic function #:pointer-button-event ;class #:pointer-button-hold-event ;class #:pointer-button-press-event ;class #:pointer-button-release-event ;class #:pointer-button-state ;generic function #:pointer-click-and-hold-event ;class #:pointer-click-event ;class #:pointer-cursor ;generic function #:pointer-documentation-pane ;pane #:pointer-documentation-view ;class #:pointer-double-click-event ;class #:pointer-enter-event ;class #:pointer-event ;class #:pointer-event-button ;generic function #:pointer-event-native-x ;generic function #:pointer-event-native-y ;generic function #:pointer-event-pointer ;generic function #:pointer-event-x ;generic function #:pointer-event-y ;generic function #:pointer-exit-event ;class #:pointer-motion-event ;class #:pointer-position ;generic function #:pointer-sheet ;generic function #:pointerp ;predicate #:pointp ;predicate #:polygon ;protocol class #:polygon-points ;generic function #:polygonp ;predicate #:polyline ;protocol class #:polyline-closed ;generic function #:polylinep ;predicate #:port ;protocol class #:port ;generic function #:port-keyboard-input-focus ;generic function #:port-name ;generic function #:port-properties ;generic function #:port-server-path ;generic function #:port-type ;generic function #:portp ;predicate #:present ;presentation method #:present ;function #:present-to-string ;function #:presentation ;protocol class #:presentation-default-preprocessor ;presentation method #:presentation-matches-context-type ;function #:presentation-modifier ;generic function #:presentation-object ;generic function #:presentation-refined-position-test ;presentation method #:presentation-replace-input ;generic function #:presentation-single-box ;generic function #:presentation-subtypep ;presentation method #:presentation-subtypep ;function #:presentation-type ;generic function #:presentation-type-direct-supertypes ;function #:presentation-type-history ;presentation method #:presentation-type-name ;function #:presentation-type-of ;function #:presentation-type-options ;function #:presentation-type-parameters ;function #:presentation-type-specifier-p ;presentation method #:presentation-type-specifier-p ;function #:presentation-typep ;presentation method #:presentation-typep ;function #:presentationp ;predicate #:print-menu-item ;function #:process-next-event ;generic function #:prompt-for-accept ;generic function #:prompt-for-accept-1 ;function #:propagate-output-record-changes ;generic function #:propagate-output-record-changes-p ;generic function #:push-button ;class #:push-button-pane ;class #:push-button-show-as-default ;generic function #:queue-event ;generic function #:queue-repaint ;generic function #:queue-rescan ;generic function #:radio-box ;class #:radio-box-current-selection ;generic function #:radio-box-pane ;class #:radio-box-selections ;generic function #:raise-frame ;generic function #:raise-mirror ;generic function #:raise-sheet ;generic function #:range-gadget-mixin ;class #:ratio ;presentation type #:rational ;presentation type #:read-bitmap-file ;generic function #:read-command ;function #:read-command-using-keystrokes ;function #:read-frame-command ;generic function #:read-gesture ;function #:read-token ;function #:real ;presentation type #:realize-mirror ;generic function #:recompute-contents-ok ;generic function #:recompute-extent-for-changed-child ;generic function #:recompute-extent-for-new-child ;generic function #:rectangle ;protocol class #:rectangle-edges* ;generic function #:rectangle-height ;generic function #:rectangle-max-point ;generic function #:rectangle-max-x ;generic function #:rectangle-max-y ;generic function #:rectangle-min-point ;generic function #:rectangle-min-x ;generic function #:rectangle-min-y ;generic function #:rectangle-size ;generic function #:rectangle-width ;generic function #:rectanglep ;predicate #:rectilinear-transformation-p ;generic function #:redisplay ;function #:redisplay-frame-pane ;generic function #:redisplay-frame-panes ;generic function #:redisplay-output-record ;generic function #:redisplayable-stream-p ;generic function #:redraw-input-buffer ;generic function #:reflection-transformation-p ;generic function #:reflection-underspecified ;error #:region ;protocol class #:region-contains-position-p ;generic function #:region-contains-region-p ;generic function #:region-difference ;generic function #:region-equal ;generic function #:region-intersection ;generic function #:region-intersects-region-p ;generic function #:region-set ;protocol class #:region-set-p ;predicate #:region-set-regions ;generic function #:region-union ;generic function #:regionp ;predicate #:remove-command-from-command-table ;function #:remove-keystroke-from-command-table ;function #:remove-menu-item-from-command-table ;function #:remove-presentation-translator-from-command-table ;function #:reorder-sheets ;generic function #:repaint-sheet ;generic function #:replace-input ;generic function #:replay ;function #:replay-output-record ;generic function #:rescan-if-necessary ;generic function #:reset-frame ;generic function #:reset-scan-pointer ;generic function #:resize-sheet ;generic function #:restart-port ;generic function #:restraining ;macro #:restraining-pane ;pane #:rigid-transformation-p ;generic function #:row-output-record ;protocol class #:row-output-record-p ;predicate #:run-frame-top-level ;generic function #:scaling-transformation-p ;generic function #:scroll-bar ;class #:scroll-bar-drag-callback ;generic function #:scroll-bar-pane ;class #:scroll-bar-scroll-down-line-callback ;generic function #:scroll-bar-scroll-down-page-callback ;generic function #:scroll-bar-scroll-to-bottom-callback ;generic function #:scroll-bar-scroll-to-top-callback ;generic function #:scroll-bar-scroll-up-line-callback ;generic function #:scroll-bar-scroll-up-page-callback ;generic function #:scroll-down-line-callback ;callback #:scroll-down-page-callback ;callback #:scroll-extent ;generic function #:scroll-to-bottom-callback ;callback #:scroll-to-top-callback ;callback #:scroll-up-line-callback ;callback #:scroll-up-page-callback ;callback #:scroller-pane ;pane #:scrolling ;macro #:sequence ;presentation type #:sequence-enumerated ;presentation type #:set-highlighted-presentation ;function #:sheet ;protocol class #:sheet-adopt-child ;generic function #:sheet-allocated-region ;generic function #:sheet-ancestor-p ;generic function #:sheet-children ;generic function #:sheet-delta-transformation ;generic function #:sheet-device-region ;generic function #:sheet-device-transformation ;generic function #:sheet-direct-mirror ;generic function #:sheet-disown-child ;generic function #:sheet-enabled-children ;generic function #:sheet-enabled-p ;generic function #:sheet-event-queue ;generic function #:sheet-grafted-p ;generic function #:sheet-identity-transformation-mixin ;class #:sheet-leaf-mixin ;class #:sheet-medium ;generic function #:sheet-mirror ;generic function #:sheet-mirrored-ancestor ;generic function #:sheet-multiple-child-mixin ;class #:sheet-mute-input-mixin ;class #:sheet-mute-output-mixin ;class #:sheet-mute-repainting-mixin ;class #:sheet-native-region ;generic function #:sheet-native-transformation ;generic function #:sheet-occluding-sheets ;generic function #:sheet-parent ;generic function #:sheet-parent-mixin ;class #:sheet-region ;generic function #:sheet-siblings ;generic function #:sheet-single-child-mixin ;class #:sheet-transformation ;generic function #:sheet-transformation-mixin ;class #:sheet-translation-mixin ;class #:sheet-viewable-p ;generic function #:sheet-with-medium-mixin ;class #:sheet-y-inverting-transformation-mixin ;class #:sheetp ;predicate #:shrink-frame ;generic function #:simple-completion-error ;condition #:simple-parse-error ;error #:simple-parse-error ;function #:singular-transformation ;error #:slider ;class #:slider-drag-callback ;generic function #:slider-pane ;class #:space-requirement ;class #:space-requirement+ ;function #:space-requirement+* ;function #:space-requirement-combine ;function #:space-requirement-components ;generic function #:space-requirement-height ;generic function #:space-requirement-max-height ;generic function #:space-requirement-max-width ;generic function #:space-requirement-min-height ;generic function #:space-requirement-min-width ;generic function #:space-requirement-width ;generic function #:spacing ;macro #:spacing-pane ;pane #:standard-application-frame ;class #:standard-bounding-rectangle ;class #:standard-cell-output-record ;class #:standard-column-output-record ;class #:standard-command-table ;class #:standard-ellipse ;class #:standard-elliptical-arc ;class #:standard-encapsulating-stream ;class #:standard-extended-input-stream ;class #:standard-extended-output-stream ;class #:standard-graph-node-output-record ;class #:standard-graph-output-record ;class #:standard-input-editing-stream ;class #:standard-input-stream ;class #:standard-item-list-output-record ;class #:standard-line ;class #:standard-line-style ;class #:standard-output-recording-stream ;class #:standard-output-stream ;class #:standard-point ;class #:standard-pointer ;class #:standard-polygon ;class #:standard-polyline ;class #:standard-presentation ;class #:standard-rectangle ;class #:standard-region-difference ;class #:standard-region-intersection ;class #:standard-region-union ;class #:standard-repainting-mixin ;class #:standard-row-output-record ;class #:standard-sequence-output-history ;class #:standard-sequence-output-record ;class #:standard-sheet-input-mixin ;class #:standard-sheet-output-mixin ;class #:standard-table-output-record ;class #:standard-text-cursor ;class #:standard-text-style ;class #:standard-tree-output-history ;class #:standard-tree-output-record ;class #:standard-updating-output-record ;class #:stream-accept ;generic function #:stream-add-character-output ;generic function #:stream-add-output-record ;generic function #:stream-add-string-output ;generic function #:stream-advance-to-column ;generic function #:stream-advance-to-column ;generic function #:stream-baseline ;generic function #:stream-character-width ;generic function #:stream-clear-input ;generic function #:stream-clear-input ;generic function #:stream-clear-output ;generic function #:stream-clear-output ;generic function #:stream-close-text-output-record ;generic function #:stream-current-output-record ;generic function #:stream-cursor-position ;generic function #:stream-default-view ;generic function #:stream-drawing-p ;generic function #:stream-element-type ;generic function #:stream-end-of-line-action ;generic function #:stream-end-of-page-action ;generic function #:stream-finish-output ;generic function #:stream-finish-output ;generic function #:stream-force-output ;generic function #:stream-force-output ;generic function #:stream-fresh-line ;generic function #:stream-fresh-line ;generic function #:stream-increment-cursor-position ;generic function #:stream-input-buffer ;generic function #:stream-input-wait ;generic function #:stream-insertion-pointer ;generic function #:stream-line-column ;generic function #:stream-line-column ;generic function #:stream-line-height ;generic function #:stream-listen ;generic function #:stream-listen ;generic function #:stream-output-history ;generic function #:stream-output-history-mixin ;class #:stream-pathname ;generic function #:stream-peek-char ;generic function #:stream-peek-char ;generic function #:stream-pointer-position ;generic function #:stream-present ;generic function #:stream-process-gesture ;generic function #:stream-read-byte ;generic function #:stream-read-char ;generic function #:stream-read-char ;generic function #:stream-read-char-no-hang ;generic function #:stream-read-char-no-hang ;generic function #:stream-read-gesture ;generic function #:stream-read-line ;generic function #:stream-read-line ;generic function #:stream-recording-p ;generic function #:stream-redisplaying-p ;generic function #:stream-replay ;generic function #:stream-rescanning-p ;generic function #:stream-scan-pointer ;generic function #:stream-set-cursor-position ;generic function #:stream-set-input-focus ;generic function #:stream-start-line-p ;generic function #:stream-start-line-p ;generic function #:stream-string-width ;generic function #:stream-terpri ;generic function #:stream-terpri ;generic function #:stream-text-cursor ;generic function #:stream-text-margin ;generic function #:stream-text-output-record ;generic function #:stream-truename ;generic function #:stream-unread-char ;generic function #:stream-unread-char ;generic function #:stream-unread-gesture ;generic function #:stream-vertical-spacing ;generic function #:stream-write-byte ;generic function #:stream-write-char ;generic function #:stream-write-char ;generic function #:stream-write-string ;generic function #:stream-write-string ;generic function #:streamp ;generic function #:string ;presentation type #:subset ;presentation type abbrev #:subset-alist ;presentation type abbrev #:subset-completion ;presentation type #:subset-sequence ;presentation type abbrev #:substitute-numeric-argument-marker ;function #:suggest ;function #:surrounding-output-with-border ;macro #:symbol ;presentation type #:t ;presentation type #:table-output-record ;protocol class #:table-output-record-p ;predicate #:table-pane ;pane #:tabling ;macro #:temporary-medium-sheet-output-mixin ;class #:test-presentation-translator ;function #:text-displayed-output-record ;protocol class #:text-displayed-output-record-p ;predicate #:text-displayed-output-record-string ;generic function #:text-editor ;class #:text-editor-pane ;class #:text-field ;class #:text-field-pane ;class #:text-size ;generic function #:text-style ;protocol class #:text-style-ascent ;generic function #:text-style-components ;generic function #:text-style-descent ;generic function #:text-style-face ;generic function #:text-style-family ;generic function #:text-style-fixed-width-p ;generic function #:text-style-height ;generic function #:text-style-mapping ;generic function #:text-style-p ;predicate #:text-style-size ;generic function #:text-style-width ;generic function #:textual-dialog-view ;class #:textual-menu-view ;class #:textual-view ;class #:throw-highlighted-presentation ;function #:timer-event ;class #:title-pane ;pane #:toggle-button ;class #:toggle-button-indicator-type ;generic function #:toggle-button-pane ;class #:token-or-type ;presentation type abbrev #:tracking-pointer ;macro #:transform-distance ;generic function #:transform-position ;generic function #:transform-rectangle* ;generic function #:transform-region ;generic function #:transformation ;protocol class #:transformation-equal ;generic function #:transformation-error ;error #:transformation-underspecified ;error #:transformationp ;predicate #:translation-transformation-p ;generic function #:tree-recompute-extent ;generic function #:type-or-string ;presentation type abbrev #:unhighlight-highlighted-presentation ;function #:unread-gesture ;function #:untransform-distance ;generic function #:untransform-position ;generic function #:untransform-rectangle* ;generic function #:untransform-region ;generic function #:updating-output ;macro #:updating-output-record ;protocol class #:updating-output-record-p ;predicate #:user-command-table ;command table #:value-changed-callback ;callback #:value-gadget ;class #:vbox-pane ;pane #:vertically ;macro #:view ;protocol class #:viewp ;predicate #:vrack-pane ;pane #:window-clear ;generic function #:window-configuration-event ;class #:window-erase-viewport ;generic function #:window-event ;class #:window-event-mirrored-sheet ;generic function #:window-event-native-region ;generic function #:window-event-region ;generic function #:window-manager-delete-event ;class #:window-manager-event ;class #:window-refresh ;generic function #:window-repaint-event ;class #:window-viewport ;generic function #:window-viewport-position ;generic function #:with-accept-help ;macro #:with-activation-gestures ;macro #:with-application-frame ;macro #:with-bounding-rectangle* ;macro #:with-command-table-keystrokes ;macro #:with-delimiter-gestures ;macro #:with-drawing-options ;macro #:with-end-of-line-action ;macro #:with-end-of-page-action ;macro #:with-first-quadrant-coordinates ;macro #:with-frame-manager ;macro #:with-graft-locked ;macro #:with-identity-transformation ;macro #:with-input-context ;macro #:with-input-editing ;macro #:with-input-editor-typeout ;macro #:with-input-focus ;macro #:with-local-coordinates ;macro #:with-look-and-feel-realization ;macro #:with-menu ;macro #:with-new-output-record ;macro #:with-output-as-gadget ;macro #:with-output-as-presentation ;macro #:with-output-buffered ;macro #:with-output-recording-options ;macro #:with-output-to-output-record ;macro #:with-output-to-pixmap ;macro #:with-output-to-postscript-stream ;macro #:with-port-locked ;macro #:with-presentation-type-decoded ;macro #:with-presentation-type-options ;macro #:with-presentation-type-parameters ;macro #:with-radio-box ;macro #:with-room-for-graphics ;macro #:with-rotation ;macro #:with-scaling ;macro #:with-sheet-medium ;macro #:with-sheet-medium-bound ;macro #:with-text-face ;macro #:with-text-family ;macro #:with-text-size ;macro #:with-text-style ;macro #:with-translation ;macro #:write-token ;function ) ;;;; symbols, which were exported as of 2002-02-09, but no longer are. ;; dispatch-repaint: ;; several mentions in silica.tex. ;; invoke-accept-values-command-button ;; mentioned in dialogs.tex. ;; labelled ;; labelled-gadget, through there is a labelled-gadget-mixin ;; mute-repainting-mixin, through there is a sheet-mute-repainting-mixin ;; oriented-gadget, through there is a oriented-gadget-mixin ;; output-record-refined-sensitivity-test: ;; there is mention of this symbol in output-recording.tex. spelling error? ;; pointer-button-click-event ;; this is mentioned in silica.tex. spelling error? ;;;; absolutly no mention of the following in the spec: ;; add-watcher ;; bordering ;; border-pane ;; delete-watcher ;; display-cursor ;; draw-triangle ;; draw-triangle* ;; frame-pane ;; gadget-label-text-style ;; gesture-processing-handler ;; key-modifier-state-match-p ;; mute-sheet-input-mixin ;; mute-sheet-output-mixin ;; note-frame-state-changed ;; panes-need-redisplay ;; pointer-button-click-and-hold-event ;; pointer-button-double-click-event ;; pointer-buttons ;; pointer-port ;; port-draw-character* ;; port-draw-ellipse* ;; port-draw-line* ;; port-draw-lines* ;; port-draw-point* ;; port-draw-points* ;; port-draw-polygon* ;; port-draw-rectangle* ;; port-draw-string* ;; push-button-show-as-default-p ;; reset-watcher ;; scroll-bar-drag-down-line-callback ;; scroll-bar-drag-down-page-callback ;; scroll-bar-drag-up-line-callback ;; scroll-bar-drag-up-page-callback ;; spacer-pane ;; standard-gadget ;; stream-pointers ;; stream-primary-pointer ;; stream-redisplayable-p ;; stream-restore-input-focus ;;; Vendor extensions which are exported from the CLIM package, ;;; including CLIM 2.2 symbols. (:export ;; I forget where the wheel symbols come from. They aren't in the ;; Franz guide. Are they from Lispworks, or did McCLIM invent them? #:+pointer-wheel-up+ #:+pointer-wheel-down+ #:+pointer-wheel-left+ #:+pointer-wheel-right+ ;; Franz and CLIM 2.2 Stuff: #:+text-field-view+ ;constant (Franz User's Guide) #:find-application-frame ;function (in Franz User's Guide) #:format-graph-from-root ;function #:list-pane-view ;class #:+list-pane-view+ ;constant #:option-pane-view ;class #:+option-pane-view+ ;constant #:pattern-array ;generic function (in franz user guide) #:pattern-designs ;generic function (in franz user guide) #:pointer-input-rectangle ;function (in franz user guide) #:pointer-input-rectangle* ;function (in franz user guide) #:pointer-place-rubber-band-line* ;function (in franz user guide) #:port-modifier-state ;generic function (in franz user guide) #:port-pointer ;generic function (in franz user guide) #:push-button-view ;class #:+push-button-view+ ;constant #:radio-box-view ;class #:+radio-box-view+ ;class #:read-bitmap-file ;function #:slider-view ;slider-view #:+slider-view+ ;constant #:text-editor-view ;class #:+text-editor-view+ ;constant #:text-field-view ;class (Franz User's Guide) #:toggle-button-view ;class #:+toggle-button-view+ ;constant #:sheet-pointer-cursor) ;;; x11 color names - some are not in the spec - mikemac (:export #:+snow+ #:+ghost-white+ #:+ghostwhite+ #:+white-smoke+ #:+whitesmoke+ #:+gainsboro+ #:+floral-white+ #:+floralwhite+ #:+old-lace+ #:+oldlace+ #:+linen+ #:+antique-white+ #:+antiquewhite+ #:+papaya-whip+ #:+papayawhip+ #:+blanched-almond+ #:+blanchedalmond+ #:+bisque+ #:+peach-puff+ #:+peachpuff+ #:+navajo-white+ #:+navajowhite+ #:+moccasin+ #:+cornsilk+ #:+ivory+ #:+lemon-chiffon+ #:+lemonchiffon+ #:+seashell+ #:+honeydew+ #:+mint-cream+ #:+mintcream+ #:+azure+ #:+alice-blue+ #:+aliceblue+ #:+lavender+ #:+lavender-blush+ #:+lavenderblush+ #:+misty-rose+ #:+mistyrose+ #:+white+ #:+black+ #:+dark-slate-gray+ #:+darkslategray+ #:+dark-slate-grey+ #:+darkslategrey+ #:+dim-gray+ #:+dimgray+ #:+dim-grey+ #:+dimgrey+ #:+slate-gray+ #:+slategray+ #:+slate-grey+ #:+slategrey+ #:+light-slate-gray+ #:+lightslategray+ #:+light-slate-grey+ #:+lightslategrey+ #:+gray+ #:+grey+ #:+light-grey+ #:+lightgrey+ #:+light-gray+ #:+lightgray+ #:+midnight-blue+ #:+midnightblue+ #:+navy+ #:+navy-blue+ #:+navyblue+ #:+cornflower-blue+ #:+cornflowerblue+ #:+dark-slate-blue+ #:+darkslateblue+ #:+slate-blue+ #:+slateblue+ #:+medium-slate-blue+ #:+mediumslateblue+ #:+light-slate-blue+ #:+lightslateblue+ #:+medium-blue+ #:+mediumblue+ #:+royal-blue+ #:+royalblue+ #:+blue+ #:+dodger-blue+ #:+dodgerblue+ #:+deep-sky-blue+ #:+deepskyblue+ #:+sky-blue+ #:+skyblue+ #:+light-sky-blue+ #:+lightskyblue+ #:+steel-blue+ #:+steelblue+ #:+light-steel-blue+ #:+lightsteelblue+ #:+light-blue+ #:+lightblue+ #:+powder-blue+ #:+powderblue+ #:+pale-turquoise+ #:+paleturquoise+ #:+dark-turquoise+ #:+darkturquoise+ #:+medium-turquoise+ #:+mediumturquoise+ #:+turquoise+ #:+cyan+ #:+light-cyan+ #:+lightcyan+ #:+cadet-blue+ #:+cadetblue+ #:+medium-aquamarine+ #:+mediumaquamarine+ #:+aquamarine+ #:+dark-green+ #:+darkgreen+ #:+dark-olive-green+ #:+darkolivegreen+ #:+dark-sea-green+ #:+darkseagreen+ #:+sea-green+ #:+seagreen+ #:+medium-sea-green+ #:+mediumseagreen+ #:+light-sea-green+ #:+lightseagreen+ #:+pale-green+ #:+palegreen+ #:+spring-green+ #:+springgreen+ #:+lawn-green+ #:+lawngreen+ #:+green+ #:+chartreuse+ #:+medium-spring-green+ #:+mediumspringgreen+ #:+green-yellow+ #:+greenyellow+ #:+lime-green+ #:+limegreen+ #:+yellow-green+ #:+yellowgreen+ #:+forest-green+ #:+forestgreen+ #:+olive-drab+ #:+olivedrab+ #:+dark-khaki+ #:+darkkhaki+ #:+khaki+ #:+pale-goldenrod+ #:+palegoldenrod+ #:+light-goldenrod-yellow+ #:+lightgoldenrodyellow+ #:+light-yellow+ #:+lightyellow+ #:+yellow+ #:+gold+ #:+light-goldenrod+ #:+lightgoldenrod+ #:+goldenrod+ #:+dark-goldenrod+ #:+darkgoldenrod+ #:+rosy-brown+ #:+rosybrown+ #:+indian-red+ #:+indianred+ #:+saddle-brown+ #:+saddlebrown+ #:+sienna+ #:+peru+ #:+burlywood+ #:+beige+ #:+wheat+ #:+sandy-brown+ #:+sandybrown+ #:+tan+ #:+chocolate+ #:+firebrick+ #:+brown+ #:+dark-salmon+ #:+darksalmon+ #:+salmon+ #:+light-salmon+ #:+lightsalmon+ #:+orange+ #:+dark-orange+ #:+darkorange+ #:+coral+ #:+light-coral+ #:+lightcoral+ #:+tomato+ #:+orange-red+ #:+orangered+ #:+red+ #:+hot-pink+ #:+hotpink+ #:+deep-pink+ #:+deeppink+ #:+pink+ #:+light-pink+ #:+lightpink+ #:+pale-violet-red+ #:+palevioletred+ #:+maroon+ #:+medium-violet-red+ #:+mediumvioletred+ #:+violet-red+ #:+violetred+ #:+magenta+ #:+violet+ #:+plum+ #:+orchid+ #:+medium-orchid+ #:+mediumorchid+ #:+dark-orchid+ #:+darkorchid+ #:+dark-violet+ #:+darkviolet+ #:+blue-violet+ #:+blueviolet+ #:+purple+ #:+medium-purple+ #:+mediumpurple+ #:+thistle+ #:+snow1+ #:+snow2+ #:+snow3+ #:+snow4+ #:+seashell1+ #:+seashell2+ #:+seashell3+ #:+seashell4+ #:+antiquewhite1+ #:+antiquewhite2+ #:+antiquewhite3+ #:+antiquewhite4+ #:+bisque1+ #:+bisque2+ #:+bisque3+ #:+bisque4+ #:+peachpuff1+ #:+peachpuff2+ #:+peachpuff3+ #:+peachpuff4+ #:+navajowhite1+ #:+navajowhite2+ #:+navajowhite3+ #:+navajowhite4+ #:+lemonchiffon1+ #:+lemonchiffon2+ #:+lemonchiffon3+ #:+lemonchiffon4+ #:+cornsilk1+ #:+cornsilk2+ #:+cornsilk3+ #:+cornsilk4+ #:+ivory1+ #:+ivory2+ #:+ivory3+ #:+ivory4+ #:+honeydew1+ #:+honeydew2+ #:+honeydew3+ #:+honeydew4+ #:+lavenderblush1+ #:+lavenderblush2+ #:+lavenderblush3+ #:+lavenderblush4+ #:+mistyrose1+ #:+mistyrose2+ #:+mistyrose3+ #:+mistyrose4+ #:+azure1+ #:+azure2+ #:+azure3+ #:+azure4+ #:+slateblue1+ #:+slateblue2+ #:+slateblue3+ #:+slateblue4+ #:+royalblue1+ #:+royalblue2+ #:+royalblue3+ #:+royalblue4+ #:+blue1+ #:+blue2+ #:+blue3+ #:+blue4+ #:+dodgerblue1+ #:+dodgerblue2+ #:+dodgerblue3+ #:+dodgerblue4+ #:+steelblue1+ #:+steelblue2+ #:+steelblue3+ #:+steelblue4+ #:+deepskyblue1+ #:+deepskyblue2+ #:+deepskyblue3+ #:+deepskyblue4+ #:+skyblue1+ #:+skyblue2+ #:+skyblue3+ #:+skyblue4+ #:+lightskyblue1+ #:+lightskyblue2+ #:+lightskyblue3+ #:+lightskyblue4+ #:+slategray1+ #:+slategray2+ #:+slategray3+ #:+slategray4+ #:+lightsteelblue1+ #:+lightsteelblue2+ #:+lightsteelblue3+ #:+lightsteelblue4+ #:+lightblue1+ #:+lightblue2+ #:+lightblue3+ #:+lightblue4+ #:+lightcyan1+ #:+lightcyan2+ #:+lightcyan3+ #:+lightcyan4+ #:+paleturquoise1+ #:+paleturquoise2+ #:+paleturquoise3+ #:+paleturquoise4+ #:+cadetblue1+ #:+cadetblue2+ #:+cadetblue3+ #:+cadetblue4+ #:+turquoise1+ #:+turquoise2+ #:+turquoise3+ #:+turquoise4+ #:+cyan1+ #:+cyan2+ #:+cyan3+ #:+cyan4+ #:+darkslategray1+ #:+darkslategray2+ #:+darkslategray3+ #:+darkslategray4+ #:+aquamarine1+ #:+aquamarine2+ #:+aquamarine3+ #:+aquamarine4+ #:+darkseagreen1+ #:+darkseagreen2+ #:+darkseagreen3+ #:+darkseagreen4+ #:+seagreen1+ #:+seagreen2+ #:+seagreen3+ #:+seagreen4+ #:+palegreen1+ #:+palegreen2+ #:+palegreen3+ #:+palegreen4+ #:+springgreen1+ #:+springgreen2+ #:+springgreen3+ #:+springgreen4+ #:+green1+ #:+green2+ #:+green3+ #:+green4+ #:+chartreuse1+ #:+chartreuse2+ #:+chartreuse3+ #:+chartreuse4+ #:+olivedrab1+ #:+olivedrab2+ #:+olivedrab3+ #:+olivedrab4+ #:+darkolivegreen1+ #:+darkolivegreen2+ #:+darkolivegreen3+ #:+darkolivegreen4+ #:+khaki1+ #:+khaki2+ #:+khaki3+ #:+khaki4+ #:+lightgoldenrod1+ #:+lightgoldenrod2+ #:+lightgoldenrod3+ #:+lightgoldenrod4+ #:+lightyellow1+ #:+lightyellow2+ #:+lightyellow3+ #:+lightyellow4+ #:+yellow1+ #:+yellow2+ #:+yellow3+ #:+yellow4+ #:+gold1+ #:+gold2+ #:+gold3+ #:+gold4+ #:+goldenrod1+ #:+goldenrod2+ #:+goldenrod3+ #:+goldenrod4+ #:+darkgoldenrod1+ #:+darkgoldenrod2+ #:+darkgoldenrod3+ #:+darkgoldenrod4+ #:+rosybrown1+ #:+rosybrown2+ #:+rosybrown3+ #:+rosybrown4+ #:+indianred1+ #:+indianred2+ #:+indianred3+ #:+indianred4+ #:+sienna1+ #:+sienna2+ #:+sienna3+ #:+sienna4+ #:+burlywood1+ #:+burlywood2+ #:+burlywood3+ #:+burlywood4+ #:+wheat1+ #:+wheat2+ #:+wheat3+ #:+wheat4+ #:+tan1+ #:+tan2+ #:+tan3+ #:+tan4+ #:+chocolate1+ #:+chocolate2+ #:+chocolate3+ #:+chocolate4+ #:+firebrick1+ #:+firebrick2+ #:+firebrick3+ #:+firebrick4+ #:+brown1+ #:+brown2+ #:+brown3+ #:+brown4+ #:+salmon1+ #:+salmon2+ #:+salmon3+ #:+salmon4+ #:+lightsalmon1+ #:+lightsalmon2+ #:+lightsalmon3+ #:+lightsalmon4+ #:+orange1+ #:+orange2+ #:+orange3+ #:+orange4+ #:+darkorange1+ #:+darkorange2+ #:+darkorange3+ #:+darkorange4+ #:+coral1+ #:+coral2+ #:+coral3+ #:+coral4+ #:+tomato1+ #:+tomato2+ #:+tomato3+ #:+tomato4+ #:+orangered1+ #:+orangered2+ #:+orangered3+ #:+orangered4+ #:+red1+ #:+red2+ #:+red3+ #:+red4+ #:+deeppink1+ #:+deeppink2+ #:+deeppink3+ #:+deeppink4+ #:+hotpink1+ #:+hotpink2+ #:+hotpink3+ #:+hotpink4+ #:+pink1+ #:+pink2+ #:+pink3+ #:+pink4+ #:+lightpink1+ #:+lightpink2+ #:+lightpink3+ #:+lightpink4+ #:+palevioletred1+ #:+palevioletred2+ #:+palevioletred3+ #:+palevioletred4+ #:+maroon1+ #:+maroon2+ #:+maroon3+ #:+maroon4+ #:+violetred1+ #:+violetred2+ #:+violetred3+ #:+violetred4+ #:+magenta1+ #:+magenta2+ #:+magenta3+ #:+magenta4+ #:+orchid1+ #:+orchid2+ #:+orchid3+ #:+orchid4+ #:+plum1+ #:+plum2+ #:+plum3+ #:+plum4+ #:+mediumorchid1+ #:+mediumorchid2+ #:+mediumorchid3+ #:+mediumorchid4+ #:+darkorchid1+ #:+darkorchid2+ #:+darkorchid3+ #:+darkorchid4+ #:+purple1+ #:+purple2+ #:+purple3+ #:+purple4+ #:+mediumpurple1+ #:+mediumpurple2+ #:+mediumpurple3+ #:+mediumpurple4+ #:+thistle1+ #:+thistle2+ #:+thistle3+ #:+thistle4+ #:+gray0+ #:+grey0+ #:+gray1+ #:+grey1+ #:+gray2+ #:+grey2+ #:+gray3+ #:+grey3+ #:+gray4+ #:+grey4+ #:+gray5+ #:+grey5+ #:+gray6+ #:+grey6+ #:+gray7+ #:+grey7+ #:+gray8+ #:+grey8+ #:+gray9+ #:+grey9+ #:+gray10+ #:+grey10+ #:+gray11+ #:+grey11+ #:+gray12+ #:+grey12+ #:+gray13+ #:+grey13+ #:+gray14+ #:+grey14+ #:+gray15+ #:+grey15+ #:+gray16+ #:+grey16+ #:+gray17+ #:+grey17+ #:+gray18+ #:+grey18+ #:+gray19+ #:+grey19+ #:+gray20+ #:+grey20+ #:+gray21+ #:+grey21+ #:+gray22+ #:+grey22+ #:+gray23+ #:+grey23+ #:+gray24+ #:+grey24+ #:+gray25+ #:+grey25+ #:+gray26+ #:+grey26+ #:+gray27+ #:+grey27+ #:+gray28+ #:+grey28+ #:+gray29+ #:+grey29+ #:+gray30+ #:+grey30+ #:+gray31+ #:+grey31+ #:+gray32+ #:+grey32+ #:+gray33+ #:+grey33+ #:+gray34+ #:+grey34+ #:+gray35+ #:+grey35+ #:+gray36+ #:+grey36+ #:+gray37+ #:+grey37+ #:+gray38+ #:+grey38+ #:+gray39+ #:+grey39+ #:+gray40+ #:+grey40+ #:+gray41+ #:+grey41+ #:+gray42+ #:+grey42+ #:+gray43+ #:+grey43+ #:+gray44+ #:+grey44+ #:+gray45+ #:+grey45+ #:+gray46+ #:+grey46+ #:+gray47+ #:+grey47+ #:+gray48+ #:+grey48+ #:+gray49+ #:+grey49+ #:+gray50+ #:+grey50+ #:+gray51+ #:+grey51+ #:+gray52+ #:+grey52+ #:+gray53+ #:+grey53+ #:+gray54+ #:+grey54+ #:+gray55+ #:+grey55+ #:+gray56+ #:+grey56+ #:+gray57+ #:+grey57+ #:+gray58+ #:+grey58+ #:+gray59+ #:+grey59+ #:+gray60+ #:+grey60+ #:+gray61+ #:+grey61+ #:+gray62+ #:+grey62+ #:+gray63+ #:+grey63+ #:+gray64+ #:+grey64+ #:+gray65+ #:+grey65+ #:+gray66+ #:+grey66+ #:+gray67+ #:+grey67+ #:+gray68+ #:+grey68+ #:+gray69+ #:+grey69+ #:+gray70+ #:+grey70+ #:+gray71+ #:+grey71+ #:+gray72+ #:+grey72+ #:+gray73+ #:+grey73+ #:+gray74+ #:+grey74+ #:+gray75+ #:+grey75+ #:+gray76+ #:+grey76+ #:+gray77+ #:+grey77+ #:+gray78+ #:+grey78+ #:+gray79+ #:+grey79+ #:+gray80+ #:+grey80+ #:+gray81+ #:+grey81+ #:+gray82+ #:+grey82+ #:+gray83+ #:+grey83+ #:+gray84+ #:+grey84+ #:+gray85+ #:+grey85+ #:+gray86+ #:+grey86+ #:+gray87+ #:+grey87+ #:+gray88+ #:+grey88+ #:+gray89+ #:+grey89+ #:+gray90+ #:+grey90+ #:+gray91+ #:+grey91+ #:+gray92+ #:+grey92+ #:+gray93+ #:+grey93+ #:+gray94+ #:+grey94+ #:+gray95+ #:+grey95+ #:+gray96+ #:+grey96+ #:+gray97+ #:+grey97+ #:+gray98+ #:+grey98+ #:+gray99+ #:+grey99+ #:+gray100+ #:+grey100+ #:+dark-grey+ #:+darkgrey+ #:+dark-gray+ #:+darkgray+ #:+dark-blue+ #:+darkblue+ #:+dark-cyan+ #:+darkcyan+ #:+dark-magenta+ #:+darkmagenta+ #:+dark-red+ #:+darkred+ #:+light-green+ #:+lightgreen+ )) (defpackage :clim-sys (:use) ;; #+cmu (:import-from :mp #:make-process #:destroy-process #:current-process #:all-processes #:processp #:process-name #:process-state #:process-whostate #:process-wait #:process-wait-with-timeout #:process-yield #:process-interrupt #:disable-process #:enable-process #:restart-process #:without-scheduling #:atomic-incf #:atomic-decf) ;; (:export #:defresource #:using-resource #:allocate-resource #:deallocate-resource #:clear-resource #:map-resource ;; #:*multiprocessing-p* #:make-process #:destroy-process #:current-process #:all-processes #:processp #:process-name #:process-state #:process-whostate #:process-wait #:process-wait-with-timeout #:process-yield #:process-interrupt #:disable-process #:enable-process #:restart-process #:without-scheduling #:atomic-incf #:atomic-decf ;; #:make-lock #:with-lock-held #:make-recursive-lock #:with-recursive-lock-held ;; #:make-condition-variable #:condition-wait #:condition-notify ;; #:defgeneric* #:defmethod* ) ) (defpackage :clim-extensions (:use) (:export #:line-style-effective-thickness #:medium-miter-limit #:raised-pane #:raising #:lowered-pane #:lowering #:viewport-pane #:draw-glyph #:device-font-text-style-p #:draw-image #:image-pane #:draw-label #:box-adjuster-gadget #:compose-space-aux #:simple-event-loop #:pointer-motion-hint-event #:invoke-with-output-to-pointer-documentation #:with-output-to-pointer-documentation #:frame-display-pointer-documentation-string #:list-pane-items #:output-record-baseline #:merging-dead-keys #:draw-output-border-over #:draw-output-border-under #:make-bordered-output-record #:bordered-output-record #:draw-rounded-rectangle* #:highlight-output-record-tree #:cut-and-paste-mixin #:mouse-wheel-scroll-mixin ;; Font listing extension: #:font-family #:font-face #:port-all-font-families #:font-family-name #:font-family-port #:font-family-all-faces #:font-face-name #:font-face-family #:font-face-all-sizes #:font-face-scalable-p #:font-face-text-style #:define-bitmap-file-reader #:unsupported-bitmap-format #:bitmap-format #:*default-vertical-scroll-bar-position*)) ;;; Symbols that must be defined by a backend. ;;; ;;; To start with, I grabbed the methods defined by the CLX backend ;;; whose symbol package is CLIM or CLIMI. (defpackage :clim-backend (:nicknames :climb) (:use :clim :clim-extensions) (:export ;; Originally in CLIM-INTERNALS #:get-next-event #:invoke-with-special-choices #:make-graft #:medium-draw-circle* #:medium-draw-glyph #:mirror-transformation #:port-allocate-pixmap #:port-deallocate-pixmap #:port-disable-sheet #:port-enable-sheet #:port-force-output #:port-frame-keyboard-input-focus #:port-grab-pointer #:port-mirror-height #:port-mirror-width #:port-motion-hints #:port-set-mirror-region #:port-set-mirror-transformation #:port-set-sheet-region #:port-set-sheet-transformation #:port-ungrab-pointer #:queue-callback #:set-sheet-pointer-cursor #:synthesize-pointer-motion-event #:text-style-character-width ;; From CLIM (mentioned in the spec) #:adopt-frame #:allocate-space #:destroy-mirror #:destroy-port #:graft #:graft-height #:graft-width #:handle-repaint #:make-medium #:make-pane-1 #:medium-beep #:medium-buffering-output-p #:medium-clear-area #:medium-clipping-region #:medium-copy-area #:medium-draw-ellipse* #:medium-draw-line* #:medium-draw-lines* #:medium-draw-point* #:medium-draw-points* #:medium-draw-polygon* #:medium-draw-rectangle* #:medium-draw-rectangles* #:medium-draw-text* #:medium-finish-output #:medium-force-output #:medium-line-style #:medium-text-style #:note-space-requirements-changed #:pointer-button-state #:pointer-modifier-state #:pointer-position #:realize-mirror #:text-size #:text-style-ascent #:text-style-descent #:text-style-height #:text-style-mapping #:text-style-width ;; Text selection protocol #:selection-owner #:selection-timestamp #:selection-event #:selection-clear-event #:selection-notify-event #:selection-request-event #:selection-event-requestor #:request-selection #:release-selection #:bind-selection #:send-selection #:get-selection-from-event ;; CLIM-EXTENSIONS #:medium-miter-limit)) (defpackage :clim-internals (:use :clim :clim-sys :clim-extensions :clim-backend :clim-lisp) (:nicknames :climi) #+excl (:import-from :excl compile-system load-system) (:intern #:letf)) ;(defpackage :CLIM ; (:use #+nil :clim-extensions ; will use it later ; :clim-internals :common-lisp) ; ) ;(let ((climi-package (find-package :climi)) ; (ext-package (find-package :clim-extensions))) ; (do-external-symbols (sym ext-package) ; (export sym climi-package))) ;(let ((clim-package (find-package :clim)) ; (climi-package (find-package :climi))) ; (do-external-symbols (sym climi-package) ; (export sym clim-package))) ;(use-package :clim-extensions :clim) (defpackage :clim-demo (:use :clim-extensions :clim :clim-lisp) #+excl(:import-from :excl compile-system load-system exit) ) (defpackage :clim-user (:use :clim :clim-lisp)) (defpackage :goatee (:use :clim :clim-lisp :clim-sys) (:import-from :clim-internals #:letf) (:shadow #:point) (:export #:execute-gesture-command #:goatee-input-editing-mixin #:simple-screen-area)) ;;; Macros and definitions for interfacing with a host Lisp's FFI. (defpackage :clim-ffi (:use :clim-lisp) (:export #:cref #:make-record #:null-pointer #:with-c-strings #:with-c-data ;; Types #:signed-char #:signed-byte #:short #:signed-halfword #:int #:signed-fullword #:long #:signed-short #:signed-int #:signed-long #:signed-doubleword #:char #:unsigned-char #:unsigned-byte #:unsigned-short #:unsigned-halfword #:unsigned-int #:unsigned-fullword #:unsigned-long #:unsigned-doubleword #:float #:double #:void #:address )) (defpackage :clim-tab-layout (:use :clim :clim-lisp) (:export #:tab-layout #:tab-layout-pane #:tab-layout-pages #:tab-page #:tab-page-tab-layout #:tab-page-title #:tab-page-pane #:tab-page-presentation-type #:tab-page-drawing-options #:add-page #:remove-page #:tab-layout-enabled-page #:sheet-to-page #:find-tab-page-named #:switch-to-page #:remove-page-named #:with-tab-layout #:com-switch-to-tab-page #:com-remove-tab-page #:internal-child-p #:note-tab-page-changed)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/describe.lisp0000644000175000017500000001615510161572116017460 0ustar pdmpdm;;; -*- Mode: Lisp; Package: COMMON-LISP -*- ;;; (c) copyright 2002 by Michael McDonald (mikemac@mikemac.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-lisp) (defun describe (thing &optional stream) (if (null stream) (setq stream *standard-output*) (if (eq stream t) (setq stream *terminal-io*))) (describe-object thing stream) (values)) (defgeneric describe-object (thing stream)) ;;; For these methods, stream should be of type ;;; (or EXTENDED-OUTPUT-STREAM OUTPUT-RECORDING-STREAM) ;;; but CLIM-STREAM-PANE is used instead. (clim-internals::with-system-redefinition-allowed (defmethod describe-object ((thing t) stream) (let ((*print-array* nil)) (clim:present thing (clim:presentation-type-of thing) :stream stream) (format stream " is of type ") (clim:present (type-of thing) (clim:presentation-type-of (type-of thing)) :stream stream) (terpri stream))) ) (defmethod describe-object ((thing symbol) stream) (clim:present thing (clim:presentation-type-of thing) :stream stream) (format stream " is of type ") (clim:present (type-of thing) (clim:presentation-type-of (type-of thing)) :stream stream) (terpri stream) (cond ((not (boundp thing)) (format stream " it is unbound~%")) (t (format stream " it has a value of ") (clim:present (symbol-value thing) (clim:presentation-type-of (symbol-value thing)) :stream stream) (terpri))) (format stream " it is in the ") (clim:present (symbol-package thing) (clim:presentation-type-of (symbol-package thing)) :stream stream) (format stream " package~%") (when (fboundp thing) (format stream " it has a function definition of ~S~%" (symbol-function thing)) (format stream " which has the argument list ") (let ((arglist #+excl (excl:arglist (symbol-function thing)) #+cmu (kernel:%function-arglist (symbol-function thing)) #+sbcl (sb-kernel:%simple-fun-arglist (symbol-function thing)) #+clisp (ext:arglist (symbol-function thing)) #-(or excl cmu sbcl clisp) "( ??? )")) (when arglist (clim:present arglist (clim:presentation-type-of arglist) :stream stream))) (terpri)) (format stream " it has a property list of ~S~%" (symbol-plist thing))) (defmethod describe-object ((thing number) stream) (clim:present thing (clim:presentation-type-of thing) :stream stream) (format stream " is a number of type ") (clim:present (type-of thing) (clim:presentation-type-of (type-of thing)) :stream stream) (terpri stream)) (defmethod describe-object ((thing string) stream) (clim:present thing (clim:presentation-type-of thing) :stream stream) (format stream " is of type ") (clim:present (type-of thing) (clim:presentation-type-of (type-of thing)) :stream stream) (format stream " with a length of ") (clim:present (length thing) 'clim:integer :stream stream) (terpri stream)) (defmethod describe-object ((thing package) stream) (clim:present thing (clim:presentation-type-of thing) :stream stream) (format stream " is a package named ") (clim:present (package-name thing) (clim:presentation-type-of (package-name thing)) :stream stream) (terpri stream) (format stream " it has the nicknames of ") (clim:present (package-nicknames thing) 'clim:expression :stream stream) (terpri stream) (format stream " it uses these packages: ") (clim:present (package-use-list thing) 'clim:expression :stream stream) (terpri stream) (format stream " it is used by the packages: ") (clim:present (package-used-by-list thing) 'clim:expression :stream stream) (terpri stream)) (labels ((present-instance-slots-text (thing stream) (let* ((slots (clim-mop:class-slots (class-of thing))) (width (loop for slot in slots maximizing (length (symbol-name (clim-mop:slot-definition-name slot)))))) (loop for slot in slots do (cond ((slot-boundp thing (clim-mop:slot-definition-name slot)) (format stream " ~v@A: " width (clim-mop:slot-definition-name slot)) (clim:present (slot-value thing (clim-mop:slot-definition-name slot)) 'clim:expression :stream stream) (terpri stream)) (t (format stream " ~v@A: ~%" width (clim-mop:slot-definition-name slot))))))) (present-instance-slots-clim (thing stream) (let ((slots (clim-mop:class-slots (class-of thing)))) (clim:formatting-table (stream) (dolist (slot slots) (clim:formatting-row (stream) (clim:formatting-cell (stream :align-x :right) (clim:present (clim-mop:slot-definition-name slot) 'clim:symbol :stream stream) (write-char #\: stream)) (clim:formatting-cell (stream) (if (slot-boundp thing (clim-mop:slot-definition-name slot)) (clim:present (slot-value thing (clim-mop:slot-definition-name slot)) 'clim:expression :stream stream) (format stream "")))))))) (describe-instance (thing a-what stream) (clim:present thing (clim:presentation-type-of thing) :stream stream) (format stream " is ~A of type " a-what) (clim:present (type-of thing) (clim:presentation-type-of (type-of thing)) :stream stream) (terpri stream) (format stream " it has the following slots:~%") (if (typep stream 'clim:output-recording-stream) (present-instance-slots-clim thing stream) (present-instance-slots-text thing stream)))) (defmethod describe-object ((thing standard-object) stream) (describe-instance thing "an instance" stream)) (defmethod describe-object ((thing structure-object) stream) (describe-instance thing "a structure" stream))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/text-selection.lisp0000644000175000017500000004465111345155772020663 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIMI; -*- ;;; (c) copyright 2003 by Gilbert Baumann ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Cut and Paste (in-package :climi) ;;;; Interaction implemented: ;; Shift-Mouse-L down: clear active selection and set the first point ;; Shift-Mouse-L drag: drag the second point ;; Shift-Mouse-L up: set the second point ;; Shift-Mouse-R down: pick the nearest point, if any ;; Shift-Mouse-R drag: drag said point ;; Shift-Mouse-R up: leave said point where it was dragged to. ;; Shift-Mouse-M: paste ;;;; Interaction to implement: ;; Shift-Mouse-L single click: (maybe) select current presentation, if any. ;; Shift-Mouse-L double click: select word ;; Shift-Mouse-L triple click: select "line". ;; TODO: ;; * Editor input (both active and old) is not currently highlighted. ;; * Selecting large regions gets slow. ;; * Structure of line breaks in the original text is not preserved (CLIM/McCLIM design issue) ;;;; Preferences (defparameter *marking-border* 1) (defparameter *marked-foreground* +white+ "Foreground ink to use for marked stuff.") (defparameter *marked-background* +blue4+ "Background ink to use for marked stuff.") ;;;; Text Selection Protocol (defgeneric release-selection (port &optional time) (:documentation "Relinquish ownership of the selection.")) (defgeneric request-selection (port requestor time) (:documentation "Request that the window system retrieve the selection from its current owner. This should cause a selection-notify-event to be delivered.")) (defgeneric bind-selection (port window &optional time) (:documentation "Take ownership of the selection.")) (defgeneric send-selection (port request-event string) (:documentation "Send 'string' to a client in response to a selection-request-event.")) (defgeneric get-selection-from-event (port event) (:documentation "Given a selection-notify event, return a string containing the incoming selection.")) ;; These events are probably very X11 specific. ;; Backends will likely produce subclasses of selection-notify-event ;; and selection-request-event. (defclass selection-event (window-event) ((selection :initarg :selection :reader selection-event-selection))) (defclass selection-clear-event (selection-event) ()) (defclass selection-notify-event (selection-event) ()) (defclass selection-request-event (selection-event) ((requestor :initarg :requestor :reader selection-event-requestor))) ;;;; Random Notes ;; - McCLIM still has absolutely no idea of lines. (defclass marking () () (:documentation "A common super class for markings (= stuff marked).")) (defgeneric marking-region (stream marking) (:documentation "Region marked/affected.")) (defclass string-marking (marking) ((record :initarg :record :documentation "The text output record this belongs to.") (styled-string :initarg :styled-string :documentation "The styled string sub-record of 'record'.") (start :initarg :start :reader mark-start :documentation "Start index within string.") (end :initarg :end :reader mark-end :documentation "End index within string. Caution: Could be one off the end to indicate a newline implied.")) (:documentation "Some part of a styled-string marked.")) (defmethod marking-region (stream (marking string-marking)) (with-slots (record styled-string start end) marking (with-slots (baseline start-y) record (if (= start end) +nowhere+ (with-slots (start-x string text-style) styled-string (make-rectangle* (+ start-x (stream-string-width stream string :start 0 :end start :text-style text-style) (- *marking-border*)) (+ start-y baseline (- (text-style-ascent text-style stream)) (- *marking-border*)) (+ start-x (stream-string-width stream string :start 0 :end end :text-style text-style) *marking-border*) (+ start-y baseline (text-style-descent text-style stream) *marking-border*))))))) ;(defgeneric draw-marking (medium marking) ; (:documentation "Draw the marking to medium.")) ; ;(defmethod draw-marking (stream (marking string-marking)) ; (draw-design (sheet-medium stream) (marking-region marking) ; :ink +flipping-ink+)) ;;;; (defclass cut-and-paste-mixin () ((markings :initform nil) (point-1-x :initform nil) (point-1-y :initform nil) (point-2-x :initform nil) (point-2-y :initform nil) (dragging-p :initform nil))) (defclass paste-as-keypress-mixin () () (:documentation "Implements the old McCLIM behavior of pasting via a sequence of key press events. You couldn't possibly want this.")) (defmethod handle-repaint :around ((pane cut-and-paste-mixin) region) (with-slots (markings) pane (cond ((null markings) (call-next-method)) (t (let ((marked-region (reduce #'region-union (mapcar #'(lambda (x) (marking-region pane x)) (slot-value pane 'markings)) :initial-value +nowhere+))) (with-sheet-medium (medium pane) (let ((R (region-difference region marked-region))) (with-drawing-options (medium :clipping-region R) (call-next-method pane R)))) (with-sheet-medium (medium pane) (let ((R (region-intersection region marked-region))) (with-drawing-options (medium :clipping-region R) (letf (((medium-foreground medium) *marked-foreground*) ((medium-background medium) *marked-background*)) (call-next-method pane R)))))))))) (defmethod dispatch-event :around ((pane cut-and-paste-mixin) (event pointer-button-press-event)) (if (eql (event-modifier-state event) +shift-key+) (eos/shift-click pane event) (call-next-method))) (defmethod dispatch-event :around ((pane cut-and-paste-mixin) (event pointer-button-release-event)) (if (eql (event-modifier-state event) +shift-key+) (eos/shift-release pane event) (call-next-method))) (defmethod dispatch-event :around ((pane cut-and-paste-mixin) (event pointer-motion-event)) (with-slots (point-1-x dragging-p) pane (if (and (eql (event-modifier-state event) +shift-key+)) (when dragging-p (eos/shift-drag pane event)) (call-next-method)))) (defun pane-clear-markings (pane &optional time) (repaint-markings pane (slot-value pane 'markings) (setf (slot-value pane 'markings) nil)) (release-selection (port pane) time)) (defmethod eos/shift-click ((pane extended-output-stream) event) (with-slots (point-1-x point-1-y point-2-x point-2-y dragging-p) pane (cond ((eql +pointer-left-button+ (pointer-event-button event)) (pane-clear-markings pane (event-timestamp event)) ;; start dragging, set point-1 where the mouse is (setf point-1-x (pointer-event-x event)) (setf point-1-y (pointer-event-y event)) (setf dragging-p t)) ((eql +pointer-middle-button+ (pointer-event-button event)) ;; paste (request-selection (port pane) #|:UTF8_STRING|# (sheet-direct-mirror pane) (event-timestamp event))) ((eql +pointer-right-button+ (pointer-event-button event)) (when (and point-1-x point-1-y point-2-x point-2-y) ;; If point-1 and point-2 are set up pick the nearest (what metric?) and drag it around. (when (< (+ (expt (- (pointer-event-x event) point-1-x) 2) (expt (- (pointer-event-y event) point-1-y) 2)) (+ (expt (- (pointer-event-x event) point-2-x) 2) (expt (- (pointer-event-y event) point-2-y) 2))) (rotatef point-1-x point-2-x) (rotatef point-1-y point-2-y)) (eos/shift-drag pane event) (setf dragging-p t))) (t (describe event))))) (defmethod eos/shift-release ((pane extended-output-stream) event) (with-slots (point-1-x point-1-y point-2-x point-2-y dragging-p) pane (when dragging-p (setf point-2-x (pointer-event-x event) point-2-y (pointer-event-y event) dragging-p nil) ;; (let ((owner (selection-owner (port pane)))) (when (and owner (not (eq owner pane))) (distribute-event (port pane) (make-instance 'selection-clear-event :sheet owner :selection :primary)))) (when (bind-selection (port pane) pane (event-timestamp event)) (setf (selection-owner (port pane)) pane) (setf (selection-timestamp (port pane)) (event-timestamp event)))))) (defun repaint-markings (pane old-markings new-markings) (let ((old-region (reduce #'region-union (mapcar #'(lambda (x) (marking-region pane x)) old-markings) :initial-value +nowhere+)) (new-region (reduce #'region-union (mapcar #'(lambda (x) (marking-region pane x)) new-markings) :initial-value +nowhere+))) (handle-repaint pane (region-exclusive-or old-region new-region)))) (defmethod eos/shift-drag ((pane extended-output-stream) event) (with-slots (point-1-x point-1-y) pane (let ((old-markings (slot-value pane 'markings))) (setup-marked-extents pane (stream-output-history pane) +everywhere+ point-1-x point-1-y (pointer-event-x event) (pointer-event-y event)) (repaint-markings pane old-markings (slot-value pane 'markings))))) (defun map-over-text (record function) (cond ((typep record 'standard-text-displayed-output-record) (with-slots (strings baseline max-height start-y wrapped x1 y1) record (loop for substring in strings do (with-slots (start-x string marked-extent text-style) substring (funcall function start-x (+ start-y baseline) string text-style substring record))))) (t (map-over-output-records-overlapping-region #'(lambda (x) (map-over-text x function)) record +everywhere+)))) (defun setup-marked-extents (stream record region bx1 by1 bx2 by2) (declare (ignore region)) (when (> by1 by2) (rotatef by1 by2) (rotatef bx1 bx2)) (let ((*lines* nil) (*all-lines* nil)) (map-over-text record (lambda (x y string ts record full-record) (let ((q (assoc y *lines*))) (unless q (push (setf q (cons y nil)) *lines*)) (push (list x y string ts record full-record) (cdr q))) (force-output *trace-output*))) (setf *lines* (sort (mapcar (lambda (line) (cons (car line) (sort (cdr line) #'< :key #'first))) *lines*) #'< :key #'car)) (setf *all-lines* *lines*) ;; Nuke every line that is above by1 (setf *lines* (remove-if (lambda (line) (< (+ (car line) 3) by1)) *lines*)) ;; Also nuke all that are below by2 (setf *lines* (remove-if (lambda (line) (> (- (car line) 10) by2)) *lines*)) ;; Special case: (when (= 1 (length *lines*)) (psetf bx1 (min bx1 bx2) bx2 (max bx1 bx2))) ;; Then, in the first line find the index farthest to the right ;; which is still less than bx1. (let ((start-i 0) (start-record (fifth (cadar *lines*))) (end-i 0) (end-record (fifth (cadar (last *lines*))))) (loop for chunk in (cdr (first *lines*)) do (destructuring-bind (x y string ts record full-record) chunk (declare (ignorable x y string ts record full-record)) (loop for i to (length string) do (when (< (+ x (stream-string-width stream string :start 0 :end i :text-style ts)) bx1) (setf start-i i start-record record))))) ;; Finally in the last line find the index farthest to the left ;; which still is greater than bx2. Or put differently: Search ;; from the left and while we are still in bounds maintain end-i ;; and end-record. (loop for chunk in (cdr (car (last *lines*))) do (destructuring-bind (x y string ts record full-record) chunk (declare (ignorable x y string ts record full-record)) (loop for i to (length string) do (when (< (+ x (stream-string-width stream string :start 0 :end i :text-style ts)) bx2) (setf end-i i end-record record))))) ;; Now grovel over the records, in order ... (let ((in-p nil) (marks nil)) (labels ((visit (chunk) (destructuring-bind (x y string ts record full-record) chunk (declare (ignorable x y string ts record full-record)) (let ((marked-extent nil)) (cond ((eq record start-record) (cond ((eq record end-record) (setf marked-extent (cons start-i end-i))) (t (setf marked-extent (cons start-i (length string))) (setf in-p t)))) ((eq record end-record) (setf marked-extent (cons 0 end-i)) (setf in-p nil)) (t (setf marked-extent (if in-p (cons 0 (length string)) nil))) ) (when marked-extent (push (destructuring-bind (x y string ts record full-record) chunk (declare (ignorable x y string ts record full-record)) (make-instance 'string-marking :record full-record :styled-string record :start (car marked-extent) :end (cdr marked-extent))) marks)) )))) (loop for line in *all-lines* do (loop for chunk in (cdr line) do (visit chunk)) ) (setf (slot-value stream 'markings) (reverse marks))))))) ;;;; Selections Events (defmethod dispatch-event :around ((pane cut-and-paste-mixin) (event selection-clear-event)) (pane-clear-markings pane (event-timestamp event))) (defmethod dispatch-event :around ((pane cut-and-paste-mixin) (event selection-request-event)) (send-selection (port pane) event (fetch-selection pane))) (define-condition selection-notify () ((event :reader event-of :initarg :event))) (defmethod handle-event ((pane cut-and-paste-mixin) (event selection-notify-event)) (signal 'selection-notify :event event)) (defmethod dispatch-event :around ((pane paste-as-keypress-mixin) (event selection-notify-event)) (let ((matter (get-selection-from-event (port pane) event))) (loop for c across matter do (dispatch-event pane (make-instance 'key-press-event :timestamp (event-timestamp event) :sheet pane :modifier-state 0 :x 0 :y 0 :graft-x 0 :graft-y 0 :key-name nil :key-character c))))) ;; FIXME: Non-text target conversions.. (?) (defun fetch-selection (pane) (let (old-y2 old-x2) (with-output-to-string (bag) (map nil (lambda (m) (with-slots (record styled-string start end) m (with-standard-rectangle* (:x1 x1 :x2 x2 :y1 y1 :y2 y2) record (cond ((and old-y2 (>= y1 old-y2)) (setf old-y2 nil old-x2 0 ;<-- ### we should use the minimum of all x1 coordinates. ) (terpri bag)) (t (setf old-y2 (max y2 (or old-y2 y2))))) (when old-x2 (loop repeat (round (- x1 old-x2) (text-style-width (slot-value styled-string 'text-style) pane)) do (princ " " bag))) (setf old-x2 x2) (princ (subseq (styled-string-string styled-string) start end) bag)))) (slot-value pane 'markings))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/frames.lisp0000644000175000017500000020314411345155771017162 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com) ;;; (c) copyright 2000 by ;;; Iban Hatchondo (hatchond@emi.u-bordeaux.fr) ;;; Julien Boninfante (boninfan@emi.u-bordeaux.fr) ;;; Robert Strandh (strandh@labri.u-bordeaux.fr) ;;; (c) copyright 2004 by ;;; Gilbert Baumann ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) ;; *application-frame* is in decls.lisp (defvar *default-frame-manager* nil) ;;; Frame-Manager class ;; FIXME: The spec says the port must "conform to options". ;; I've added a check that the ports match, but we've no ;; protocol for testing the other options. -Hefner (defun find-frame-manager (&rest options &key port &allow-other-keys) (declare (special *frame-manager*)) (if (and (boundp '*frame-manager*) (or (null port) (eql port (port *frame-manager*)))) *frame-manager* (if (and *default-frame-manager* (frame-manager-p *default-frame-manager*) (or (null port) (eql port (port *default-frame-manager*)))) *default-frame-manager* (first (frame-managers (or port (apply #'find-port options))))))) (defmacro with-frame-manager ((frame-manager) &body body) `(let ((*frame-manager* ,frame-manager)) (declare (special *frame-manager*)) (locally ,@body))) ;;; XXX These should force the redisplay of the menu bar. They don't ;;; yet. (defmethod note-command-enabled (frame-manager frame command-name) (declare (ignore frame-manager frame command-name)) nil) (defmethod note-command-disabled (frame-manager frame command-name) (declare (ignore frame-manager frame command-name)) nil) ;;; Application-Frame class ;;; XXX All these slots should move to a mixin or to standard-application-frame. ;;; -- moore ; extension (defgeneric frame-schedule-timer-event (frame sheet delay token)) (defgeneric note-input-focus-changed (pane state) (:documentation "Called when a pane receives or loses the keyboard input focus. This is a McCLIM extension.")) (defclass standard-application-frame (application-frame presentation-history-mixin) ((port :initform nil :initarg :port :accessor port) (graft :initform nil :initarg :graft :accessor graft) (name :initarg :name :reader frame-name) (pretty-name :initarg :pretty-name :accessor frame-pretty-name) (command-table :initarg :command-table :initform nil :accessor frame-command-table) (named-panes :accessor frame-named-panes :initform nil) (panes :initform nil :reader frame-panes :documentation "The tree of panes in the current layout.") (layouts :initform nil :initarg :layouts :reader frame-layouts) (current-layout :initform nil :initarg :current-layout :accessor frame-current-layout) (panes-for-layout :initform nil :accessor frame-panes-for-layout :documentation "alist of names and panes (as returned by make-pane)") (top-level-sheet :initform nil :reader frame-top-level-sheet) (menu-bar :initarg :menu-bar :initform nil) (state :initarg :state :initform :disowned :reader frame-state) (manager :initform nil :reader frame-manager :accessor %frame-manager) (properties :accessor %frame-properties :initarg :properties :initform nil) (top-level :initform '(default-frame-top-level) :initarg :top-level :reader frame-top-level) (top-level-lambda :initarg :top-level-lambda :reader frame-top-level-lambda) (hilited-presentation :initform nil :initarg :hilited-presentation :accessor frame-hilited-presentation) (process :accessor frame-process :initform nil) (client-settings :accessor client-settings :initform nil) (event-queue :initarg :frame-event-queue :initarg :input-buffer :initform nil :accessor frame-event-queue :documentation "The event queue that, by default, will be shared by all panes in the stream") (documentation-state :accessor frame-documentation-state :initform nil :documentation "Used to keep of track of what needs to be rendered in the pointer documentation frame.") (calling-frame :reader frame-calling-frame :initarg :calling-frame :initform nil :documentation "The frame that is the parent of this frame, if any") (disabled-commands :accessor disabled-commands :accessor frame-disabled-commands :initarg :disabled-commands :initform nil :documentation "A list of command names that have been disabled in this frame") (documentation-record :accessor documentation-record :initform nil :documentation "updating output record for pointer documentation produced by presentations.") (geometry-left :accessor geometry-left :initarg :left :initform nil) (geometry-right :accessor geometry-right :initarg :right :initform nil) (geometry-top :accessor geometry-top :initarg :top :initform nil) (geometry-bottom :accessor geometry-bottom :initarg :bottom :initform nil) (geometry-width :accessor geometry-width :initarg :width :initform nil) (geometry-height :accessor geometry-height :initarg :height :initform nil))) (defmethod frame-geometry* ((frame standard-application-frame)) "-> width height &optional top left" (let ((pane (frame-top-level-sheet frame))) ;(destructuring-bind (&key left top right bottom width height) (frame-geometry frame) (with-slots (geometry-left geometry-top geometry-right geometry-bottom geometry-width geometry-height) frame ;; Find width and height from looking at the respective options ;; first, then at left/right and top/bottom and finally at what ;; compose-space says. (let* ((width (or geometry-width (and geometry-left geometry-right (- geometry-right geometry-left)) (space-requirement-width (compose-space pane)))) (height (or geometry-height (and geometry-top geometry-bottom (- geometry-bottom geometry-top)) (space-requirement-height (compose-space pane)))) ;; See if a position is wanted and return left, top. (left (or geometry-left (and geometry-right (- geometry-right geometry-width)))) (top (or geometry-top (and geometry-bottom (- geometry-bottom geometry-height))))) (values width height left top))))) ;;; Support the :input-buffer initarg for compatibility with "real CLIM" (defmethod initialize-instance :after ((obj standard-application-frame) &key &allow-other-keys) (when (and (frame-calling-frame obj) (null (frame-event-queue obj))) (setf (frame-event-queue obj) (frame-event-queue (frame-calling-frame obj)))) (unless (frame-event-queue obj) (setf (frame-event-queue obj) (make-instance 'port-event-queue)))) (defmethod (setf frame-manager) (fm (frame application-frame)) (let ((old-manager (frame-manager frame))) (setf (%frame-manager frame) nil) (when old-manager (disown-frame old-manager frame) (setf (slot-value frame 'panes) nil) (setf (slot-value frame 'layouts) nil)) (setf (%frame-manager frame) fm))) (define-condition frame-layout-changed (condition) ((frame :initarg :frame :reader frame-layout-changed-frame))) (defmethod (setf frame-current-layout) :after (name (frame application-frame)) (declare (ignore name)) (when (frame-manager frame) (generate-panes (frame-manager frame) frame) (multiple-value-bind (w h) (frame-geometry* frame) (layout-frame frame w h)) (signal 'frame-layout-changed :frame frame))) (defmethod generate-panes :before (fm (frame application-frame)) (declare (ignore fm)) (when (and (frame-panes frame) (eq (sheet-parent (frame-panes frame)) (frame-top-level-sheet frame))) (sheet-disown-child (frame-top-level-sheet frame) (frame-panes frame))) (loop for (nil . pane) in (frame-panes-for-layout frame) for parent = (sheet-parent pane) if parent do (sheet-disown-child parent pane))) (defmethod generate-panes :after (fm (frame application-frame)) (declare (ignore fm)) (sheet-adopt-child (frame-top-level-sheet frame) (frame-panes frame)) (unless (sheet-parent (frame-top-level-sheet frame)) (sheet-adopt-child (graft frame) (frame-top-level-sheet frame))) ;; Find the size of the new frame (multiple-value-bind (w h x y) (frame-geometry* frame) (declare (ignore x y)) ;; automatically generates a window-configuation-event ;; which then calls allocate-space ;; ;; Not any longer, we turn off CONFIGURE-NOTIFY events until the ;; window is mapped and do the space allocation now, so that all ;; sheets will have their correct geometry at once. --GB (setf (sheet-region (frame-top-level-sheet frame)) (make-bounding-rectangle 0 0 w h)) (allocate-space (frame-top-level-sheet frame) w h) )) (defmethod layout-frame ((frame application-frame) &optional width height) (let ((pane (frame-panes frame))) (when (and (or width height) (not (and width height))) (error "LAYOUT-FRAME must be called with both WIDTH and HEIGHT or neither")) (if (and (null width) (null height)) (let ((space (compose-space pane))) ;I guess, this might be wrong. --GB 2004-06-01 (setq width (space-requirement-width space)) (setq height (space-requirement-height space)))) (let ((tpl-sheet (frame-top-level-sheet frame))) (unless (and (= width (bounding-rectangle-width tpl-sheet)) (= height (bounding-rectangle-height tpl-sheet))) (resize-sheet (frame-top-level-sheet frame) width height))) (allocate-space pane width height))) (defun find-pane-if (predicate panes) "Returns a pane satisfying PREDICATE in the forest growing from PANES" (map-over-sheets #'(lambda (p) (when (funcall predicate p) (return-from find-pane-if p))) panes) nil) (defun find-pane-of-type (panes type) (find-pane-if #'(lambda (pane) (typep pane type)) panes)) ;;; There are several ways to do this; this isn't particularly efficient, but ;;; it shouldn't matter much. If it does, it might be better to map over the ;;; panes in frame-named-panes looking for panes with parents. (defmethod frame-current-panes ((frame application-frame)) (let ((panes nil) (named-panes (frame-named-panes frame))) (map-over-sheets #'(lambda (p) (when (member p named-panes) (push p panes))) (frame-panes frame)) panes)) (defmethod get-frame-pane ((frame application-frame) pane-name) (let ((pane (find-pane-named frame pane-name))) (if (typep pane 'clim-stream-pane) pane nil))) (defmethod find-pane-named ((frame application-frame) pane-name) (find pane-name (frame-named-panes frame) :key #'pane-name)) (defmethod frame-standard-output ((frame application-frame)) (or (find-pane-of-type (frame-panes frame) 'application-pane) (find-pane-of-type (frame-panes frame) 'interactor-pane))) (defmethod frame-standard-input ((frame application-frame)) (or (find-pane-of-type (frame-panes frame) 'interactor-pane) (frame-standard-output frame))) (defmethod frame-query-io ((frame application-frame)) (or (frame-standard-input frame) (frame-standard-output frame))) (defmethod frame-error-output ((frame application-frame)) (frame-standard-output frame)) (defvar *pointer-documentation-output* nil) (defmethod frame-pointer-documentation-output ((frame application-frame)) (find-pane-of-type (frame-panes frame) 'pointer-documentation-pane)) #+nil (defmethod redisplay-frame-panes ((frame application-frame) &key force-p) (map-over-sheets (lambda (sheet) (when (typep sheet 'pane) (when (and (typep sheet 'clim-stream-pane) (not (eq :no-clear (pane-redisplay-needed sheet)))) (window-clear sheet)) (redisplay-frame-pane frame sheet :force-p force-p))) (frame-top-level-sheet frame))) (defmethod redisplay-frame-panes ((frame application-frame) &key force-p) (map-over-sheets (lambda (sheet) (redisplay-frame-pane frame sheet :force-p force-p)) (frame-top-level-sheet frame))) (defmethod frame-replay (frame stream &optional region) (declare (ignore frame)) (stream-replay stream region)) (defmethod frame-properties ((frame application-frame) property) (getf (%frame-properties frame) property)) (defmethod (setf frame-properties) (value (frame application-frame) property) (setf (getf (%frame-properties frame) property) value)) ;;; Command loop interface (define-condition frame-exit (condition) ((frame :initarg :frame :reader %frame-exit-frame))) ;; I make the assumption here that the contents of *application-frame* is ;; the frame the top-level loop is running. With the introduction of ;; window-stream frames that may be sharing the event queue with the main ;; application frame, we need to discriminate between them here to avoid ;; shutting down the application at the wrong time. ;; ... ;; A better way to do this would be to make the handler bound in ;; run-frame-top-level check whether the frame signalled is the one ;; it was invoked on.. -- Hefner (defmethod frame-exit ((frame standard-application-frame)) (if (eq *application-frame* frame) (signal 'frame-exit :frame frame) (disown-frame (frame-manager frame) frame))) (defmethod frame-exit-frame ((c frame-exit)) (%frame-exit-frame c)) (defmethod redisplay-frame-pane ((frame application-frame) pane &key force-p) (declare (ignore pane force-p)) nil) (defgeneric medium-invoke-with-possible-double-buffering (frame pane medium continuation)) (defmethod medium-invoke-with-possible-double-buffering (frame pane medium continuation) (funcall continuation)) (defgeneric invoke-with-possible-double-buffering (frame pane continuation)) (defmethod invoke-with-possible-double-buffering (frame pane continuation) (declare (ignore frame pane)) (funcall continuation)) (defmethod invoke-with-possible-double-buffering (frame (pane sheet-with-medium-mixin) continuation) (medium-invoke-with-possible-double-buffering frame pane (sheet-medium pane) continuation)) (defmacro with-possible-double-buffering ((frame pane) &body body) `(invoke-with-possible-double-buffering ,frame ,pane (lambda () ,@body))) (defmethod redisplay-frame-pane :around ((frame application-frame) pane &key force-p) (let ((pane-object (if (typep pane 'pane) pane (find-pane-named frame pane)))) (restart-case (multiple-value-bind (redisplayp clearp) (pane-needs-redisplay pane-object) (when force-p (setq redisplayp (or redisplayp t) clearp t)) (when redisplayp (let ((hilited (frame-hilited-presentation frame))) (when hilited (highlight-presentation-1 (car hilited) (cdr hilited) :unhighlight) (setf (frame-hilited-presentation frame) nil))) (with-possible-double-buffering (frame pane-object) (when clearp (window-clear pane-object)) (call-next-method)) (unless (or (eq redisplayp :command-loop) (eq redisplayp :no-clear)) (setf (pane-needs-redisplay pane-object) nil)))) (clear-pane-try-again () :report "Clear the output history of the pane and reattempt forceful redisplay" (window-clear pane) (redisplay-frame-pane frame pane :force-p t)) (clear-pane () :report "Clear the output history of the pane, but don't redisplay" (window-clear pane)) (skip-redisplay () :report "Skip this redisplay")))) (defmethod run-frame-top-level ((frame application-frame) &key &allow-other-keys) (letf (((frame-process frame) (current-process))) (handler-case (funcall (frame-top-level-lambda frame) frame) (frame-exit () nil)))) (defmethod run-frame-top-level :around ((frame application-frame) &key) (let ((*application-frame* frame) (*input-context* nil) (*input-wait-test* nil) (*input-wait-handler* nil) (*pointer-button-press-handler* nil) (original-state (frame-state frame))) (declare (special *input-context* *input-wait-test* *input-wait-handler* *pointer-button-press-handler*)) (when (eq (frame-state frame) :disowned) ; Adopt frame into frame manager (adopt-frame (or (frame-manager frame) (find-frame-manager)) frame)) (unless (or (eq (frame-state frame) :enabled) (eq (frame-state frame) :shrunk)) (enable-frame frame)) (unwind-protect (loop for query-io = (frame-query-io frame) for *default-frame-manager* = (frame-manager frame) do (handler-case (return (if query-io (with-input-focus (query-io) (call-next-method)) (call-next-method))) (frame-layout-changed () nil))) (let ((fm (frame-manager frame))) (case original-state (:disabled (disable-frame frame)) (:disowned (disown-frame fm frame))))))) (defparameter +default-prompt-style+ (make-text-style :sans-serif :bold :normal)) (defmethod default-frame-top-level ((frame application-frame) &key (command-parser 'command-line-command-parser) (command-unparser 'command-line-command-unparser) (partial-command-parser 'command-line-read-remaining-arguments-for-partial-command) (prompt "Command: ")) ;; Give each pane a fresh start first time through. (let ((first-time t)) (loop ;; The variables are rebound each time through the loop because the ;; values of frame-standard-input et al. might be changed by a command. (let* ((*standard-input* (or (frame-standard-input frame) *standard-input*)) (*standard-output* (or (frame-standard-output frame) *standard-output*)) (query-io (frame-query-io frame)) (*query-io* (or query-io *query-io*)) (*pointer-documentation-output* (frame-pointer-documentation-output frame)) ;; during development, don't alter *error-output* ;; (*error-output* (frame-error-output frame)) (*command-parser* command-parser) (*command-unparser* command-unparser) (*partial-command-parser* partial-command-parser) (interactorp (typep *query-io* 'interactor-pane))) (restart-case (progn (redisplay-frame-panes frame :force-p first-time) (setq first-time nil) (if query-io ;; For frames with an interactor: (progn ;; Hide cursor, so we don't need to toggle it during ;; command output. (setf (cursor-visibility (stream-text-cursor *query-io*)) nil) (when (and prompt interactorp) (with-text-style (*query-io* +default-prompt-style+) (if (stringp prompt) (write-string prompt *query-io*) (funcall prompt *query-io* frame)) (force-output *query-io*))) (let ((command (read-frame-command frame :stream *query-io*))) (when interactorp (fresh-line *query-io*)) (when command (execute-frame-command frame command)) (when interactorp (fresh-line *query-io*)))) ;; Frames without an interactor: (let ((command (read-frame-command frame :stream nil))) (when command (execute-frame-command frame command))))) (abort () :report "Return to application command loop" (if interactorp (format *query-io* "~&Command aborted.~&") (beep)))))))) (defmethod read-frame-command :around ((frame application-frame) &key (stream *standard-input*)) (with-input-context ('menu-item) (object) (call-next-method) (menu-item (let ((command (command-menu-item-value object)) (table (frame-command-table frame))) (unless (listp command) (setq command (partial-command-from-name command table))) (if (partial-command-p command) (funcall *partial-command-parser* table stream command 0) command))))) (defmethod read-frame-command ((frame application-frame) &key (stream *standard-input*)) ;; The following is the correct interpretation according to the spec. ;; I think it is terribly counterintuitive and want to look into ;; what existing CLIMs do before giving in to it. ;; If we do things as the spec says, command accelerators will ;; appear to not work, confusing new users. #+NIL (read-command (frame-command-table frame) :use-keystrokes nil :stream stream) (if stream (read-command (frame-command-table frame) :use-keystrokes t :stream stream) (simple-event-loop frame))) (define-event-class execute-command-event (window-manager-event) ((sheet :initarg :sheet :reader event-sheet) (command :initarg :command :reader execute-command-event-command))) (defmethod execute-frame-command ((frame application-frame) command) ;; ### FIXME: I'd like a different method than checking for ;; *application-frame* to decide, which process processes which ;; frames command loop. Perhaps looking ath the process slot? ;; --GB 2005-11-28 (cond ((eq *application-frame* frame) (restart-case (apply (command-name command) (command-arguments command)) (try-again () :report (lambda (stream) (format stream "Try executing the command ~A again" (command-name command))) (execute-frame-command frame command)))) (t (let ((eq (sheet-event-queue (frame-top-level-sheet frame)))) (event-queue-append eq (make-instance 'execute-command-event :sheet frame :command command)))))) (defmethod handle-event ((frame application-frame) (event execute-command-event)) (execute-frame-command frame (execute-command-event-command event))) (defmethod command-enabled (command-name (frame standard-application-frame)) (and (command-accessible-in-command-table-p command-name (frame-command-table frame)) (not (member command-name (disabled-commands frame))))) (defmethod (setf command-enabled) (enabled command-name (frame standard-application-frame)) (unless (command-accessible-in-command-table-p command-name (frame-command-table frame)) (return-from command-enabled nil)) (with-accessors ((disabled-commands disabled-commands)) frame (if enabled (progn (setf disabled-commands (delete command-name disabled-commands)) (note-command-enabled (frame-manager frame) frame command-name) enabled) (progn (pushnew command-name disabled-commands) (note-command-disabled (frame-manager frame) frame command-name) nil)))) (defmethod make-pane-1 :around (fm (frame standard-application-frame) type &rest args &key (input-buffer nil input-buffer-p) (name nil namep) &allow-other-keys) (declare (ignore name input-buffer)) "Default input-buffer to the frame event queue." (let ((pane (if input-buffer-p (call-next-method) (apply #'call-next-method fm frame type :input-buffer (frame-event-queue frame) args)))) (when namep (push pane (frame-named-panes frame))) pane)) (defmethod adopt-frame ((fm frame-manager) (frame application-frame)) (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames))) (setf (frame-manager frame) fm) (setf (port frame) (port fm)) (setf (graft frame) (find-graft :port (port frame))) (let* ((*application-frame* frame) (t-l-s (make-pane-1 fm frame 'top-level-sheet-pane :name 'top-level-sheet ;; enabling should be left to enable-frame :enabled-p nil)) #+clim-mp (event-queue (sheet-event-queue t-l-s))) (setf (slot-value frame 'top-level-sheet) t-l-s) (generate-panes fm frame) (setf (slot-value frame 'state) :disabled) #+clim-mp (when (typep event-queue 'port-event-queue) (setf (event-queue-port event-queue) (port fm))) frame)) (defmethod disown-frame ((fm frame-manager) (frame application-frame)) #+CLIM-MP (let* ((t-l-s (frame-top-level-sheet frame)) (queue (sheet-event-queue t-l-s))) (when (typep queue 'port-event-queue) (setf (event-queue-port queue) nil))) (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames))) (sheet-disown-child (graft frame) (frame-top-level-sheet frame)) (setf (%frame-manager frame) nil) (setf (slot-value frame 'state) :disowned) (port-force-output (port fm)) frame) (defmethod enable-frame ((frame application-frame)) (setf (sheet-enabled-p (frame-top-level-sheet frame)) t) (setf (slot-value frame 'state) :enabled) (note-frame-enabled (frame-manager frame) frame)) (defmethod disable-frame ((frame application-frame)) (let ((t-l-s (frame-top-level-sheet frame))) (setf (sheet-enabled-p t-l-s) nil) (when (port t-l-s) (port-force-output (port t-l-s)))) (setf (slot-value frame 'state) :disabled) (note-frame-disabled (frame-manager frame) frame)) (defmethod destroy-frame ((frame application-frame)) (when (eq (frame-state frame) :enabled) (disable-frame frame)) (disown-frame (frame-manager frame) frame)) (defmethod raise-frame ((frame application-frame)) (raise-sheet (frame-top-level-sheet frame))) (defmethod bury-frame ((frame application-frame)) (bury-sheet (frame-top-level-sheet frame))) (defmethod note-frame-enabled ((fm frame-manager) frame) (declare (ignore frame)) t) (defmethod note-frame-disabled ((fm frame-manager) frame) (declare (ignore frame)) t) (defun map-over-frames (function &key port frame-manager) (cond (frame-manager (mapc function (frame-manager-frames frame-manager))) (port (loop for manager in (frame-managers port) do (map-over-frames function :frame-manager manager))) (t (loop for p in *all-ports* do (map-over-frames function :port p))))) (defvar *pane-realizer* nil) (defmacro with-look-and-feel-realization ((frame-manager frame) &body body) `(let ((*pane-realizer* ,frame-manager) (*application-frame* ,frame)) (locally ,@body))) ; The menu-bar code in the following two functions is incorrect. ; it needs to be moved to somewhere after the backend, since ; it depends on the backend chosen. ; ; This hack slaps a menu-bar into the start of the application-frame, ; in such a way that it is hard to find. ; ; FIXME (defun make-single-pane-generate-panes-form (class-name menu-bar pane) `(progn (defmethod generate-panes ((fm frame-manager) (frame ,class-name)) ;; v-- hey, how can this be? (with-look-and-feel-realization (fm frame) (let ((pane ,(cond ((eq menu-bar t) `(vertically () (clim-internals::make-menu-bar ',class-name) ,pane)) ((consp menu-bar) `(vertically () (clim-internals::make-menu-bar (make-command-table nil :menu ',menu-bar)) ,pane)) (menu-bar `(vertically () (clim-internals::make-menu-bar ',menu-bar) ,pane)) ;; The form below is unreachable with (listp ;; menu-bar) instead of (consp menu-bar) above ;; --GB (t pane)))) (setf (slot-value frame 'panes) pane)))) (defmethod frame-all-layouts ((frame ,class-name)) nil))) (defun find-pane-for-layout (name frame) (cdr (assoc name (frame-panes-for-layout frame) :test #'eq))) (defun save-pane-for-layout (name pane frame) (push (cons name pane) (frame-panes-for-layout frame)) pane) (defun coerce-pane-name (pane name) (when pane (setf (slot-value pane 'name) name) (push pane (frame-named-panes (pane-frame pane)))) pane) (defun do-pane-creation-form (name form) (cond ((and (= (length form) 1) (listp (first form))) `(coerce-pane-name ,(first form) ',name)) ((keywordp (first form)) (let ((maker (intern (concatenate 'string (symbol-name '#:make-clim-) (symbol-name (first form)) (symbol-name '#:-pane)) :clim))) (if (fboundp maker) `(,maker :name ',name ,@(cdr form)) `(make-pane ',(first form) :name ',name ,@(cdr form))))) (t `(make-pane ',(first form) :name ',name ,@(cdr form))))) (defun make-panes-generate-panes-form (class-name menu-bar panes layouts pointer-documentation) (when pointer-documentation (setf panes (append panes '((%pointer-documentation% pointer-documentation-pane))))) `(progn (defmethod generate-panes ((fm frame-manager) (frame ,class-name)) (let ((*application-frame* frame)) (with-look-and-feel-realization (fm frame) (let ,(loop for (name . form) in panes collect `(,name (or (find-pane-for-layout ',name frame) (save-pane-for-layout ',name ,(do-pane-creation-form name form) frame)))) ;; [BTS] added this, but is not sure that this is correct for ;; adding a menu-bar transparently, should also only be done ;; where the exterior window system does not support menus ,(if (or menu-bar pointer-documentation) `(setf (slot-value frame 'panes) (ecase (frame-current-layout frame) ,@(mapcar (lambda (layout) `(,(first layout) (vertically () ,@(cond ((eq menu-bar t) `((clim-internals::make-menu-bar ',class-name))) ((consp menu-bar) `((clim-internals::make-menu-bar (make-command-table nil :menu ',menu-bar)))) (menu-bar `((clim-internals::make-menu-bar ',menu-bar))) (t nil)) ,@(rest layout) ,@(when pointer-documentation '(%pointer-documentation%))))) layouts))) `(setf (slot-value frame 'panes) (ecase (frame-current-layout frame) ,@layouts))))))) (defmethod frame-all-layouts ((frame ,class-name)) ',(mapcar #'car layouts)))) (defmacro define-application-frame (name superclasses slots &rest options) (if (null superclasses) (setq superclasses '(standard-application-frame))) (let ((pane nil) (panes nil) (layouts nil) (current-layout nil) (command-table (list name)) (menu-bar t) (disabled-commands nil) (command-definer t) (top-level '(default-frame-top-level)) (others nil) (pointer-documentation nil) (geometry nil) (user-default-initargs nil) (frame-arg (gensym "FRAME-ARG"))) (loop for (prop . values) in options do (case prop (:pane (setq pane (first values))) (:panes (setq panes values)) (:layouts (setq layouts values)) (:command-table (setq command-table (first values))) (:menu-bar (setq menu-bar (if (listp values) (first values) values))) (:disabled-commands (setq disabled-commands values)) (:command-definer (setq command-definer (first values))) (:top-level (setq top-level (first values))) (:pointer-documentation (setq pointer-documentation (car values))) (:geometry (setq geometry values)) (:default-initargs (setq user-default-initargs values)) (t (push (cons prop values) others)))) (when (eq command-definer t) (setf command-definer (intern (concatenate 'string (symbol-name '#:define-) (symbol-name name) (symbol-name '#:-command))))) (if (or (and pane panes) (and pane layouts)) (error ":pane cannot be specified along with either :panes or :layouts")) (if pane (setq panes (list 'single-pane pane) layouts `((:default ,(car pane))))) (setq current-layout (first (first layouts))) `(progn (defclass ,name ,superclasses ,slots (:default-initargs :name ',name :pretty-name ,(string-capitalize name) :command-table (find-command-table ',(first command-table)) :disabled-commands ',disabled-commands :menu-bar ',menu-bar :current-layout ',current-layout :layouts ',layouts :top-level (list ',(car top-level) ,@(cdr top-level)) :top-level-lambda (lambda (,frame-arg) (,(car top-level) ,frame-arg ,@(cdr top-level))) ,@geometry ,@user-default-initargs) ,@others) ,(if pane (make-single-pane-generate-panes-form name menu-bar pane) (make-panes-generate-panes-form name menu-bar panes layouts pointer-documentation)) ,@(if command-table `((define-command-table ,@command-table))) ,@(if command-definer `((defmacro ,command-definer (name-and-options arguments &rest body) (let ((name (if (listp name-and-options) (first name-and-options) name-and-options)) (options (if (listp name-and-options) (cdr name-and-options) nil)) (command-table ',(first command-table))) `(define-command (,name :command-table ,command-table ,@options) ,arguments ,@body)))))))) (defun make-application-frame (frame-name &rest options &key (pretty-name (string-capitalize frame-name)) (frame-manager nil frame-manager-p) enable (state nil state-supplied-p) save-under (frame-class frame-name) &allow-other-keys) (declare (ignore save-under)) (with-keywords-removed (options (:pretty-name :frame-manager :enable :state :save-under :frame-class)) (let ((frame (apply #'make-instance frame-class :name frame-name :pretty-name pretty-name options))) (when frame-manager-p (adopt-frame frame-manager frame)) (cond ((or enable (eq state :enabled)) (enable-frame frame)) ((and (eq state :disowned) (not (eq (frame-state frame) :disowned))) (disown-frame (frame-manager frame) frame)) (state-supplied-p (warn ":state ~S not supported yet." state))) frame))) ;;; From Franz Users Guide (defun find-application-frame (frame-name &rest initargs &key (create t) (activate t) (own-process *multiprocessing-p*) port frame-manager frame-class &allow-other-keys) (declare (ignorable frame-class)) (let ((frame (unless (eq create :force) (block found-frame (map-over-frames #'(lambda (frame) (when (eq (frame-name frame) frame-name) (return-from found-frame frame))) :port port :frame-manager frame-manager))))) (unless (or frame create) (return-from find-application-frame nil)) (unless frame (with-keywords-removed (initargs (:create :activate :own-process)) (setq frame (apply #'make-application-frame frame-name initargs)))) (when (and frame activate) (cond ((frame-process frame) (raise-frame frame)) (own-process (clim-sys:make-process #'(lambda () (run-frame-top-level frame)) :name (format nil "~A" frame-name))) (t (run-frame-top-level frame)))) frame)) ;;; Menu frame class (defclass menu-frame () ((left :initform 0 :initarg :left) (top :initform 0 :initarg :top) (min-width :initform nil :initarg :min-width) (top-level-sheet :initform nil :reader frame-top-level-sheet) (panes :reader frame-panes :initarg :panes) (graft :initform nil :accessor graft) (manager :initform nil :accessor frame-manager))) (defclass menu-unmanaged-top-level-sheet-pane (unmanaged-top-level-sheet-pane) ()) (defmethod adopt-frame ((fm frame-manager) (frame menu-frame)) (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames))) (setf (frame-manager frame) fm) (let* ((t-l-s (make-pane-1 fm *application-frame* 'menu-unmanaged-top-level-sheet-pane :name 'top-level-sheet))) (setf (slot-value frame 'top-level-sheet) t-l-s) (sheet-adopt-child t-l-s (frame-panes frame)) (let ((graft (find-graft :port (port fm)))) (sheet-adopt-child graft t-l-s) (setf (graft frame) graft)) (let ((pre-space (compose-space t-l-s)) (frame-min-width (slot-value frame 'min-width))) (multiple-value-bind (width min-width max-width height min-height max-height) (space-requirement-components pre-space) (flet ((foomax (x y) (max (or x 1) (or y 1)))) (let ((space (make-space-requirement :min-width (foomax frame-min-width min-width) :width (foomax frame-min-width width) :max-width (foomax frame-min-width max-width) :min-height min-height :height height :max-height max-height))) (allocate-space (frame-panes frame) (space-requirement-width space) (space-requirement-height space)) (setf (sheet-region t-l-s) (make-bounding-rectangle 0 0 (space-requirement-width space) (space-requirement-height space)))) (setf (sheet-transformation t-l-s) (make-translation-transformation (slot-value frame 'left) (slot-value frame 'top)))))))) (defmethod disown-frame ((fm frame-manager) (frame menu-frame)) (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames))) (sheet-disown-child (graft frame) (frame-top-level-sheet frame)) (setf (frame-manager frame) nil)) (defun make-menu-frame (pane &key (left 0) (top 0) (min-width 1)) (make-instance 'menu-frame :panes pane :left left :top top :min-width min-width)) ;;; Frames and presentations (defmethod frame-maintain-presentation-histories ((frame standard-application-frame)) (if (find-pane-of-type (frame-panes frame) 'interactor-pane) t nil)) (defmethod frame-find-innermost-applicable-presentation ((frame standard-application-frame) input-context stream x y &key event) (find-innermost-applicable-presentation input-context stream x y :frame frame :event event)) (defmethod frame-input-context-button-press-handler ((frame standard-application-frame) (stream output-recording-stream) button-press-event) (let ((presentation (find-innermost-applicable-presentation *input-context* stream (pointer-event-x button-press-event) (pointer-event-y button-press-event) :frame frame :event button-press-event))) (when presentation (throw-highlighted-presentation presentation *input-context* button-press-event)))) (defmethod frame-input-context-button-press-handler ((frame standard-application-frame) stream button-press-event) (declare (ignore stream button-press-event)) nil) (defgeneric frame-update-pointer-documentation (frame input-context stream event)) (defconstant +button-documentation+ '((#.+pointer-left-button+ "L") (#.+pointer-middle-button+ "M") (#.+pointer-right-button+ "R") (#.+pointer-wheel-up+ "WheelUp") (#.+pointer-wheel-down+ "WheelDown"))) (defconstant +modifier-documentation+ '((#.+shift-key+ "sh" "Shift") (#.+control-key+ "c" "Control") (#.+meta-key+ "m" "Meta") (#.+super-key+ "s" "Super") (#.+hyper-key+ "h" "Hyper"))) ;;; Give a coherent order to sets of modifier combinations. Multi-key combos ;;; come after single keys. (defun cmp-modifiers (a b) (let ((cnt-a (logcount a)) (cnt-b (logcount b))) (cond ((eql cnt-a cnt-b) (< a b)) (t (< cnt-a cnt-b))))) (defun print-modifiers (stream modifiers style) (if (zerop modifiers) (when (eq style :long) (write-string "" stream)) (loop with trailing = nil for (bit short long) in +modifier-documentation+ when (logtest bit modifiers) do (progn (format stream "~:[~;-~]~A" trailing (if (eq style :short) short long)) (setq trailing t))))) ;;; XXX Warning: Changing rapidly! ;;; ;;; We don't actually want to print out the translator documentation and redraw ;;; the pointer documentation window on every motion event. So, we compute a ;;; state object (basically modifier state and a list of the applicable ;;; presentation, translator and input context on each mouse button), ;;; compare it to the previous state object, and only write out documentation ;;; if they are different. I suppose it's possible that this state object ;;; doesn't capture all possible documentation changes -- the doc generator is ;;; a function, after all -- but that's just tough. ;;; ;;; It would be nice to evolve this into a protocol so that elements other than ;;; presentations -- menu choices, for example -- could influence pointer ;;; documentation window. (defgeneric frame-compute-pointer-documentation-state (frame input-context stream event) (:documentation "Compute a state object that will be used to generate pointer documentation.")) (defmethod frame-compute-pointer-documentation-state ((frame standard-application-frame) input-context stream event) (let* ((current-modifier (event-modifier-state event)) (x (device-event-x event)) (y (device-event-y event)) (new-translators (loop for (button) in +button-documentation+ for context-list = (multiple-value-list (find-innermost-presentation-context input-context stream x y :modifier-state current-modifier :button button)) when (car context-list) collect (cons button context-list)))) (list current-modifier new-translators))) (defgeneric frame-compare-pointer-documentation-state (frame input-context stream old-state new-state)) (defmethod frame-compare-pointer-documentation-state ((frame standard-application-frame) input-context stream old-state new-state) (declare (ignore input-context stream)) (equal old-state new-state)) (defun record-on-display (stream record) "Return true if `record' is part of the output history of `stream', false otherwise." (labels ((worker (record) (or (eq record (stream-output-history stream)) (and (not (null (output-record-parent record))) (worker (output-record-parent record)))))) (worker record))) (defgeneric frame-print-pointer-documentation (frame input-context stream state event)) (defmethod frame-print-pointer-documentation ((frame standard-application-frame) input-context stream state event) (unless state (return-from frame-print-pointer-documentation nil)) (destructuring-bind (current-modifier new-translators) state (let ((x (device-event-x event)) (y (device-event-y event)) (pstream *pointer-documentation-output*)) (if (null new-translators) (when (and (background-message pstream) (not (record-on-display pstream (background-message pstream)))) (cond ((> (get-universal-time) (+ (background-message-time pstream) *background-message-minimum-lifetime*)) (setf (background-message pstream) nil)) (t (setf (output-record-parent (background-message pstream)) nil) (stream-add-output-record pstream (background-message pstream)) (replay (background-message pstream) pstream)))) (loop for (button presentation translator context) in new-translators for name = (cadr (assoc button +button-documentation+)) for first-one = t then nil do (progn (unless first-one (write-string "; " pstream)) (unless (zerop current-modifier) (print-modifiers pstream current-modifier :short) (write-string "-" pstream)) (format pstream "~A: " name) (document-presentation-translator translator presentation (input-context-type context) *application-frame* event stream x y :stream pstream :documentation-type :pointer)) finally (when new-translators (write-char #\. pstream)))) ;; Wasteful to do this after doing ;; find-innermost-presentation-context above... look at doing this ;; first and then doing the innermost test. (let ((all-translators (find-applicable-translators (stream-output-history stream) input-context *application-frame* stream x y :for-menu t)) (other-modifiers nil)) (loop for (translator) in all-translators for gesture = (gesture translator) unless (eq gesture t) do (loop for (name type modifier) in gesture unless (eql modifier current-modifier) do (pushnew modifier other-modifiers))) (when other-modifiers (setf other-modifiers (sort other-modifiers #'cmp-modifiers)) (terpri pstream) (write-string "To see other commands, press " pstream) (loop for modifier-tail on other-modifiers for (modifier) = modifier-tail for count from 0 do (progn (if (null (cdr modifier-tail)) (progn (when (> count 1) (write-char #\, pstream)) (when (> count 0) (write-string " or " pstream))) (when (> count 0) (write-string ", " pstream))) (print-modifiers pstream modifier :long))) (write-char #\. pstream)))))) (defmethod frame-update-pointer-documentation ((frame standard-application-frame) input-context stream event) (when *pointer-documentation-output* (with-accessors ((frame-documentation-state frame-documentation-state) (documentation-record documentation-record)) frame (setf frame-documentation-state (frame-compute-pointer-documentation-state frame input-context stream event)) ;; These ugly special bindings work around the fact that the outer ;; updating-output form closes over its body and allow the inner ;; form to see the correct, current values of those variables. (let ((%input-context% input-context) (%stream% stream) (%doc-state% frame-documentation-state) (%event% event)) (declare (special %input-context% %stream% %doc-state% %event&)) (if (and documentation-record (output-record-parent documentation-record)) (redisplay documentation-record *pointer-documentation-output*) (progn (setf documentation-record (updating-output (*pointer-documentation-output*) (updating-output (*pointer-documentation-output* :cache-value %doc-state% :cache-test #'equal) (frame-print-pointer-documentation frame %input-context% %stream% %doc-state% %event%)))))))))) (defgeneric invoke-with-output-to-pointer-documentation (frame continuation) (:documentation "Invoke `continuation' with a single argument - a stream that the continuation can write to, the output of which will be used as the background message of the pointer documentation pane of `frame'. If the pointer-documentation of `frame' is not a `pointer-documentation-pane', `continuation' will not be called.")) (defmethod invoke-with-output-to-pointer-documentation ((frame standard-application-frame) continuation) (with-accessors ((pointer-documentation frame-pointer-documentation-output)) frame (when (typep pointer-documentation 'pointer-documentation-pane) (setf (background-message pointer-documentation) (with-output-to-output-record (pointer-documentation) (funcall continuation pointer-documentation)) (background-message-time pointer-documentation) (get-universal-time))))) (defmacro with-output-to-pointer-documentation ((stream frame) &body body) "Bind `stream' to the pointer-documentation pane of `frame' and capture the output of `body' on `stream' as the background message of the pointer documentation pane. If `frame' does not have a `pointer-documentation-pane' as pointer documentation, `body' will not be evaluated." `(invoke-with-output-to-pointer-documentation ,frame #'(lambda (,stream) ,@body))) ;;; A hook for applications to draw random strings in the ;;; *pointer-documentation-output* without screwing up the real pointer ;;; documentation too badly. (defun frame-display-pointer-documentation-string (frame string) (with-output-to-pointer-documentation (stream frame) (write-string string stream))) (defmethod frame-input-context-track-pointer ((frame standard-application-frame) input-context (stream output-recording-stream) event) (declare (ignore input-context event)) nil) (defmethod frame-input-context-track-pointer ((frame standard-application-frame) input-context stream event) (declare (ignore input-context stream event)) nil) (defun frame-highlight-at-position (frame stream x y modifier input-context &key (highlight t)) "Given stream x,y; key modifiers; input-context, find the applicable presentation and maybe highlight it." (flet ((maybe-unhighlight (presentation) (when (and (frame-hilited-presentation frame) (or (not highlight) (not (eq presentation (car (frame-hilited-presentation frame)))))) (highlight-presentation-1 (car (frame-hilited-presentation frame)) (cdr (frame-hilited-presentation frame)) :unhighlight) (setf (frame-hilited-presentation frame) nil)))) (if (output-recording-stream-p stream) (let ((presentation (find-innermost-applicable-presentation input-context stream x y :frame frame :modifier-state modifier))) (maybe-unhighlight presentation) (when (and presentation highlight (not (eq presentation (car (frame-hilited-presentation frame))))) (setf (frame-hilited-presentation frame) (cons presentation stream)) (highlight-presentation-1 presentation stream :highlight)) presentation) (progn (maybe-unhighlight nil) nil)))) (defmethod frame-input-context-track-pointer :before ((frame standard-application-frame) input-context (stream output-recording-stream) event) (frame-highlight-at-position frame stream (device-event-x event) (device-event-y event) (event-modifier-state event) input-context) (frame-update-pointer-documentation frame input-context stream event)) (defun simple-event-loop (&optional (frame *application-frame*)) "An simple event loop for applications that want all events to be handled by handle-event methods" (let ((queue (frame-event-queue frame))) (loop for event = (event-queue-read queue) ;; EVENT-QUEUE-READ in single-process mode calls PROCESS-NEXT-EVENT itself. do (handle-event (event-sheet event) event)))) ;;; Am I missing something? Does this need to do more? - moore (defmacro with-application-frame ((frame) &body body) `(let ((,frame *application-frame*)) ,@body)) (defmethod note-input-focus-changed (pane state) (declare (ignore pane state))) (defmethod (setf client-setting) (value frame setting) (setf (getf (client-settings frame) setting) value)) (defmethod reset-frame (frame &rest client-settings) (loop for (setting value) on client-settings by #'cddr do (setf (client-setting frame setting) value))) ;;; tracking-pointer stuff related to presentations (defclass frame-tracking-pointer-state (tracking-pointer-state) ((presentation-handler :reader presentation-handler :initarg :presentation) (presentation-button-release-handler :reader presentation-button-release-handler :initarg :presentation-button-release) (presentation-button-press-handler :reader presentation-button-press-handler :initarg :presentation-button-press) (applicable-presentation :accessor applicable-presentation :initform nil) (input-context :reader input-context) (highlight :reader highlight)) (:default-initargs :presentation nil :presentation-button-press nil :presentation-button-release nil :context-type t)) (defmethod initialize-instance :after ((obj frame-tracking-pointer-state) &key presentation presentation-button-press presentation-button-release (highlight nil highlightp) context-type multiple-window) (declare (ignore multiple-window)) (let ((presentation-clauses-p (or presentation presentation-button-press presentation-button-release))) (setf (slot-value obj 'highlight) (if highlightp highlight presentation-clauses-p)) (setf (slot-value obj 'input-context) (if (or presentation-clauses-p highlight) (make-fake-input-context context-type) nil)))) (defmethod make-tracking-pointer-state ((frame standard-application-frame) sheet args) (declare (ignore sheet)) (apply #'make-instance 'frame-tracking-pointer-state args)) (defmethod tracking-pointer-loop :before ((state frame-tracking-pointer-state) frame sheet &rest args) (declare (ignore args)) (if (highlight state) (highlight-current-presentation frame (input-context state)) (let ((hilited (frame-hilited-presentation frame))) (when hilited (highlight-presentation-1 (car hilited) (cdr hilited) :unhighlight))))) ;;; Poor man's find-applicable-translators. tracking-pointer doesn't want to ;;; see any results from presentation translators. ;;; ;;; XXX I don't see why not (even though I wrote the above comment :) and ;;; Classic CLIM seems to agree. -- moore (defun highlight-for-tracking-pointer (frame stream event input-context highlight) (let ((presentation nil) (current-hilited (frame-hilited-presentation frame))) (when (output-recording-stream-p stream) ;; XXX Massive hack to prevent the presentation action for completions ;; from being applicable. After the .9.2.2 release that action will have ;; a more restrictive context type. (let ((*completion-possibilities-continuation* nil)) (setq presentation (find-innermost-applicable-presentation input-context stream (device-event-x event) (device-event-y event) :frame frame)))) (when (and current-hilited (not (eq (car current-hilited) presentation))) (highlight-presentation-1 (car current-hilited) (cdr current-hilited) :unhighlight)) (when (and presentation highlight) (setf (frame-hilited-presentation frame) (cons presentation stream)) (highlight-presentation-1 presentation stream :highlight)) presentation)) (defmethod tracking-pointer-loop-step :before ((state frame-tracking-pointer-state) (event pointer-event) x y) (declare (ignore x y)) (when (input-context state) (let ((stream (event-sheet event))) (setf (applicable-presentation state) (highlight-for-tracking-pointer *application-frame* stream event (input-context state) (highlight state)))))) (macrolet ((frob (event handler) `(defmethod tracking-pointer-loop-step ((state frame-tracking-pointer-state) (event ,event) x y) (let ((handler (,handler state)) (presentation (applicable-presentation state))) (if (and handler presentation) (funcall handler :presentation presentation :event event :window (event-sheet event) :x x :y y) (call-next-method)))))) (frob pointer-motion-event presentation-handler) (frob pointer-button-press-event presentation-button-press-handler) (frob pointer-button-release-event presentation-button-release-handler)) (defun make-drag-bounding (old-highlighting new-highlighting old-presentation new-presentation) (let (x1 y1 x2 y2) (flet ((union-with-bounds (rect) (cond ((null rect) nil) ((null x1) (setf (values x1 y1 x2 y2) (bounding-rectangle* rect))) (t (with-bounding-rectangle* (r-x1 r-y1 r-x2 r-y2) rect (setf (values x1 y1 x2 y2) (bound-rectangles x1 y1 x2 y2 r-x1 r-y1 r-x2 r-y2))))))) (union-with-bounds old-highlighting) (union-with-bounds new-highlighting) (union-with-bounds old-presentation) (union-with-bounds new-presentation) (values x1 y1 x2 y2)))) (defun make-drag-and-drop-feedback-function (from-presentation) (multiple-value-bind (record-x record-y) (output-record-position from-presentation) (let ((current-to-presentation nil) (current-from-higlighting nil)) (lambda (frame from-presentation to-presentation initial-x initial-y x y event) (let ((dx (- record-x initial-x)) (dy (- record-y initial-y))) (typecase event (null ()))))))) (defmethod frame-drag-and-drop-feedback ((frame standard-application-frame) from-presentation stream initial-x initial-y x y state) (with-bounding-rectangle* (fp-x1 fp-y1 fp-x2 fp-y2) from-presentation ;; Offset from origin of presentation is preserved throughout (let* ((x-off (- fp-x1 initial-x)) (y-off (- fp-y1 initial-y)) (hilite-x1 (+ x-off x)) (hilite-y1 (+ y-off y)) (hilite-x2 (+ hilite-x1 (- fp-x2 fp-x1))) (hilite-y2 (+ hilite-y1 (- fp-y2 fp-y1)))) (with-identity-transformation (stream) (ecase state (:highlight (with-output-recording-options (stream :record nil) (draw-rectangle* stream hilite-x1 hilite-y1 hilite-x2 hilite-y2 :filled nil :line-dashes #(4 4)))) (:unhighlight (with-double-buffering ((stream hilite-x1 hilite-y1 (1+ hilite-x2) (1+ hilite-y2)) (buffer-rectangle)) (stream-replay stream buffer-rectangle)))))))) (defmethod frame-drag-and-drop-highlighting ((frame standard-application-frame) to-presentation stream state) (highlight-presentation-1 to-presentation stream state)) (defun frame-drag-and-drop (translator-name command-table from-presentation context-type frame event window x y) (declare (ignore command-table)) (let* ((*dragged-presentation* from-presentation) (*dragged-object* (presentation-object from-presentation)) (translators (mapcan (lambda (trans) (and (typep trans 'drag-n-drop-translator) (funcall (tester trans) (presentation-object from-presentation) :presentation from-presentation :context-type context-type :frame frame :window window :x x :y y :event event) (list trans))) (find-presentation-translators (presentation-type from-presentation) context-type (frame-command-table frame)))) ;; Try to run the feedback and highlight functions of the translator ;; that got us here. (translator (or (find translator-name translators :key #'name) (car translators))) (initial-feedback-fn (feedback translator)) (initial-hilite-fn (highlighting translator)) (destination-presentation nil) (initial-x x) (initial-y y) (last-presentation nil) (feedback-activated nil) (feedback-fn initial-feedback-fn) (hilite-fn initial-hilite-fn) (last-event nil)) ;; We shouldn't need to use find-innermost-presentation-match ;; This repeats what tracking-pointer has already done, but what are you ;; gonna do? (flet ((find-dest-translator (presentation window x y) (loop for translator in translators when (and (presentation-subtypep (presentation-type presentation) (destination-ptype translator)) (test-presentation-translator translator presentation context-type frame window x y)) do (return-from find-dest-translator translator)) nil) (do-feedback (window x y state) (funcall feedback-fn frame from-presentation window initial-x initial-y x y state)) (do-hilite (presentation window state) (funcall hilite-fn frame presentation window state)) (last-window () (event-sheet last-event)) (last-x () (pointer-event-x last-event)) (last-y () (pointer-event-y last-event))) ;; :highlight nil will cause the presentation that is the source of the ;; dragged object to be unhighlighted initially. (block do-tracking (tracking-pointer (window :context-type `(or ,(mapcar #'from-type translators)) :highlight nil :multiple-window nil) ;XXX (:presentation (&key presentation window event x y) (let ((dest-translator (find-dest-translator presentation window x y))) (when feedback-activated (do-feedback (last-window) (last-x) (last-y) :unhighlight)) (setq feedback-activated t last-event event) (when last-presentation (do-hilite last-presentation (last-window) :unhighlight)) (setq last-presentation presentation feedback-fn (feedback dest-translator) hilite-fn (highlighting dest-translator)) (do-hilite presentation window :highlight) (do-feedback window x y :highlight) (document-drag-n-drop dest-translator presentation context-type frame event window x y))) (:pointer-motion (&key event window x y) (when feedback-activated (do-feedback (last-window) (last-x) (last-y) :unhighlight)) (setq feedback-activated t last-event event) (when last-presentation (do-hilite last-presentation (last-window) :unhighlight)) (setq last-presentation nil) (do-feedback window x y :highlight) (document-drag-n-drop translator nil context-type frame event window x y)) ;; XXX only support finish-on-release for now. #-(and)(:presentation-button-press ()) (:presentation-button-release (&key presentation event) (setq destination-presentation presentation last-event event) (return-from do-tracking nil)) #-(and)(:button-press ()) (:button-release (&key event) (setq last-event event) (return-from do-tracking nil)))) ;; ;; XXX Assumes x y from :button-release are the same as for the preceding ;; button-motion; is that correct? (when feedback-activated (do-feedback (last-window) (last-x) (last-y) :unhighlight)) (when last-presentation (do-hilite last-presentation (last-window) :unhighlight)) (if destination-presentation (let ((final-translator (find-dest-translator destination-presentation (last-window) (last-x) (last-y)))) (if final-translator (funcall (destination-translator final-translator) *dragged-object* :presentation *dragged-presentation* :destination-object (presentation-object destination-presentation) :destination-presentation destination-presentation :context-type context-type :frame frame :event event :window window :x x :y y) (values nil nil))) (values nil nil))))) (defun document-drag-n-drop (translator presentation context-type frame event window x y) (when *pointer-documentation-output* (let ((s *pointer-documentation-output*)) (window-clear s) (with-end-of-page-action (s :allow) (with-end-of-line-action (s :allow) (funcall (pointer-documentation translator) *dragged-object* :presentation *dragged-presentation* :destination-object (and presentation (presentation-object presentation)) :destination-presentation presentation :context-type context-type :frame frame :event event :window window :x x :y y :stream s)))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/builtin-commands.lisp0000640000175000017500000004126310741375205021143 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2002 by Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) ;;; Commands and presentation translators that live in the ;;; global-command-table. ;;; Global help command (define-command (com-null-command :command-table global-command-table :name nil) () nil) (define-command (com-help :command-table global-command-table :name "Help") ((kind '(completion (("Keyboard" keyboard) ("Commands" commands)) :value-key cadr) :prompt "with" :default 'keyboard :display-default nil)) (if (eq kind 'keyboard) (format *query-io* "Input editor commands are like Emacs.~%") (let ((command-table (frame-command-table *application-frame*)) (command-names nil)) (map-over-command-table-names #'(lambda (name command) (push (cons name command) command-names)) command-table) (setf command-names (remove-duplicates command-names :key #'cdr)) (setf command-names (sort command-names #'(lambda (a b) (string-lessp (car a) (car b))))) (formatting-item-list (*query-io*) (loop for (nil . command) in command-names do (formatting-cell (*query-io*) (present command `(command-name :command-table ,command-table) :stream *query-io*))))))) ;;; Describe command. I don't know if this should go in the global command ;;; table, but we don't exactly have a surplus of commands yet... (define-command (com-describe :command-table global-command-table :name "Describe") ((obj 'expression :prompt "object" :gesture :describe)) (describe obj *query-io*)) ;;; Another somewhat gratuitous command... (define-gesture-name :describe-presentation :pointer-button-press (:left :super)) ;;; The argument obj is not really the presentation object but the ;;; presentation itself as supplied by the translator. (define-command (com-describe-presentation :command-table global-command-table) ((obj t)) (com-describe obj)) (define-presentation-to-command-translator com-describe-presentation-translator (t com-describe-presentation global-command-table :gesture :describe-presentation :tester ((presentation) (not (eq presentation *null-presentation*))) :documentation "Describe Presentation" :pointer-documentation "Describe Presentation" :menu presentation-debugging) (presentation) (list presentation)) ;;; Default presentation translator; translates an object to itself. (define-presentation-translator default-translator (t nil global-command-table :gesture :select :tester ((presentation context-type) ;; see the comments around DEFUN PRESENTATION-SUBTYPEP ;; for some of the logic behind this. Only when ;; PRESENTATION-SUBTYPEP is unsure do we test the object ;; itself for PRESENTATION-TYPEP. (multiple-value-bind (yp sp) (presentation-subtypep (presentation-type presentation) context-type) (or yp (not sp)))) :tester-definitive nil :menu nil :documentation ((object presentation context-type frame event window x y stream) (let* ((type (presentation-type presentation)) (options (decode-options type)) (description (getf options :description))) (if description (if (stringp description) (princ description stream) (funcall description object :presentation presentation :context-type context-type :frame frame :event event :window window :x x :y y :stream stream)) (present object (presentation-type presentation) :stream stream :sensitive nil))))) (object presentation) ;; returning (PRESENTATION-TYPE PRESENTATION) as the ptype is ;; formally undefined, as this means that the translator returns a ;; presentation type which is not PRESENTATION-SUBTYPEP the ;; translator's TO-TYPE. (values object (presentation-type presentation))) (define-presentation-action presentation-menu (t nil global-command-table :documentation "Menu" :menu nil :gesture :menu :tester ((presentation frame window x y event) (find-applicable-translators presentation *input-context* ; XXX ? frame window x y :event event ; XXX ? :for-menu t :fastp t))) (presentation frame window x y) (call-presentation-menu presentation *input-context* frame window x y :for-menu t :label (format nil "Operation on ~A" (presentation-type presentation)))) ;;; Action for possibilities menu of complete-input ;;; ;;; XXX The context type needs to change to COMPLETER or something so that this ;;; isn't applicable all over the place. (define-presentation-action possibilities-menu (blank-area nil global-command-table :documentation "Possibilities menu for completion" :pointer-documentation "Possibilities" :menu nil :gesture :menu :tester (() *completion-possibilities-continuation*)) () (funcall *completion-possibilities-continuation*)) ;;; Turn symbols and lists into forms (define-gesture-name :literal-expression :pointer-button-press (:left :meta)) (defun document-form-translator (object &key stream &allow-other-keys) (unless (constantp object) (write-char #\' stream)) (present object 'form :stream stream)) (macrolet ((%frob-exp (type-name) (let ((expression-translator-name (symbol-concat type-name '-to-expression))) `(define-presentation-translator ,expression-translator-name (,type-name expression global-command-table :gesture :select :menu nil) (object) object))) (%frob-constant-form (type-name) (let ((form-translator-name (symbol-concat type-name '-to-form))) `(define-presentation-translator ,form-translator-name (,type-name form global-command-table :gesture :select :menu nil :documentation document-form-translator) (object) object))) (%frob-form (type-name) (let ((form-translator-name (symbol-concat type-name '-to-form))) `(define-presentation-translator ,form-translator-name (,type-name form global-command-table :gesture :select :menu nil :documentation document-form-translator) (object) (if (constantp object) object `',object)))) (frob (type-name) `(progn (%frob-exp ,type-name) (%frob-constant-form ,type-name))) (frob-form (type-name) `(progn (%frob-exp ,type-name) (%frob-form ,type-name)))) (frob null) (frob boolean) (frob keyword) (frob number) (frob character) (frob string) (frob pathname) (frob-form symbol) (frob-form sequence) (frob standard-object)) (define-presentation-translator expression-to-form (expression form global-command-table :gesture :select :menu nil :priority 11) (object) (if (or (consp object) (and (symbolp object) (not (null object)))) `',object object)) ;;; I changed :menu nil to :menu t because :literal-expression is hard for me ;;; to type on my Mac :) I'm not sure why I excluded this from the menu ;;; originally. (define-presentation-translator expression-as-form (expression form global-command-table :gesture :literal-expression :menu t :documentation "expression as literal" :tester ((object) (or (symbolp object) (consp object))) :tester-definitive t) (object) (values object 'form)) ;;; Support for accepting subforms of a form. ;;; Used to signal a read that ends a list (define-presentation-type list-terminator () :inherit-from 'form) (defvar *sys-read* #'read) (defvar *sys-read-preserving-whitespace* #'read-preserving-whitespace) ;;; Arguments for read (defvar *eof-error-p* t) (defvar *eof-value* nil) (defvar *recursivep* nil) ;;; For passing arguments to the call to %read-list-expression. ;;; Gross, but not as gross as using presentation type options. ;;; ;;; XXX But I am using a presentation type option to choice the ;;; subform reader; what's the difference? Granted the presentation ;;;type specifier is constant.... -- moore (defvar *dot-ok*) (defvar *termch*) (defun whitespacep (char) (or (char= char #\Space) (char= char #\Newline) (char= char #\Return) (char= char #\Tab))) #+openmcl (defvar *sys-%read-list-expression* #'ccl::%read-list-expression) #+openmcl (with-system-redefinition-allowed (defun ccl::%read-list-expression (stream *dot-ok* &optional (*termch* #\))) (if (typep stream 'input-editing-stream) (progn ;; Eat "whitespace" so it is not deleted by presentation-replace-input (let ((gesture (read-gesture :stream stream :timeout 0 :peek-p t))) (when (and gesture (or (activation-gesture-p gesture) (delimiter-gesture-p gesture) (and (characterp gesture) (whitespacep gesture)))) (read-gesture :stream stream))) (multiple-value-bind (object type) (accept '((expression) :subform-read t) :stream stream :prompt nil) (values object (if (presentation-subtypep type 'list-terminator) nil t)))) (funcall *sys-%read-list-expression* stream *dot-ok* *termch*))) ) ; with-system-redefinition-allowed (define-presentation-method accept ((type expression) stream (view textual-view) &key) (let* ((object nil) (ptype nil)) #.(funcall (if #+openmcl t #-openmcl nil #'identity #'fourth) `(if subform-read (multiple-value-bind (val valid) (funcall *sys-%read-list-expression* stream *dot-ok* *termch*) (if valid (setq object val) (return-from accept (values nil 'list-terminator)))) ;; We don't want activation gestures like :return causing an eof ;; while reading a form. Also, we don't want spaces within forms or ;; strings causing a premature return either! ;; XXX This loses when rescanning (possibly in other contexts too) an ;; activated input buffer (e.g., reading an expression from the accept ;; method for OR where the previous readers have already given ;; up). We should call *sys-read-preserving-whitespace* and handle the ;; munching of whitespace ourselves according to the ;; PRESERVE-WHITESPACE parameter. Fix after .9.2.2. (with-delimiter-gestures (nil :override t) (with-activation-gestures (nil :override t) (setq object (funcall (if preserve-whitespace *sys-read-preserving-whitespace* *sys-read*) stream *eof-error-p* *eof-value* *recursivep*)))))) (setq ptype (presentation-type-of object)) (unless (presentation-subtypep ptype 'expression) (setq ptype 'expression)) (if (or subform-read auto-activate) (values object ptype) (loop for c = (read-char stream) until (or (activation-gesture-p c) (delimiter-gesture-p c)) finally (when (delimiter-gesture-p c) (unread-char c stream)) (return (values object ptype)))))) (define-presentation-method accept ((type expression) (stream input-editing-stream) (view textual-view) &key) ;; This method is specialized to ;; input-editing-streams and has thus been ;; made slightly more tolerant of input ;; errors. It is slightly hacky, but seems ;; to work fine. (let* ((object nil) (ptype nil)) #.(funcall (if #+openmcl t #-openmcl nil #'identity #'fourth) `(if (and #-openmcl nil subform-read) (multiple-value-bind (val valid) (funcall *sys-%read-list-expression* stream *dot-ok* *termch*) (if valid (setq object val) (return-from accept (values nil 'list-terminator)))) ;; We don't want activation gestures like :return causing an ;; eof while reading a form. Also, we don't want spaces within ;; forms or strings causing a premature return either! (with-delimiter-gestures (nil :override t) (with-activation-gestures (nil :override t) (setq object ;; We loop in our accept of user input, if a reader ;; error is signalled, we merely ignore it and ask ;; for more input. This is so a single malplaced #\( ;; or #\, won't throw up a debugger with a ;; READER-ERROR and remove whatever the user wrote ;; to the stream. (loop for potential-object = (handler-case (funcall (if preserve-whitespace *sys-read-preserving-whitespace* *sys-read*) stream *eof-error-p* *eof-value* *recursivep*) ((and reader-error) (e) (declare (ignore e)) nil)) unless (null potential-object) return potential-object)))))) (setq ptype (presentation-type-of object)) (unless (presentation-subtypep ptype 'expression) (setq ptype 'expression)) (if (or subform-read auto-activate) (values object ptype) (loop for c = (read-char stream) until (or (activation-gesture-p c) (delimiter-gesture-p c)) finally (when (delimiter-gesture-p c) (unread-char c stream)) (return (values object ptype)))))) (with-system-redefinition-allowed (defun read (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursivep nil)) (if (typep stream 'input-editing-stream) (let ((*eof-error-p* eof-error-p) (*eof-value* eof-value) (*recursivep* recursivep)) (accept '((expression) :auto-activate t :preserve-whitespace nil) :stream stream :prompt nil)) (funcall *sys-read* stream eof-error-p eof-value recursivep))) (defun read-preserving-whitespace (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursivep nil)) (if (typep stream 'input-editing-stream) (let ((*eof-error-p* eof-error-p) (*eof-value* eof-value) (*recursivep* recursivep)) (accept '((expression) :auto-activate t :preserve-whitespace t) :stream stream :prompt nil)) (funcall *sys-read-preserving-whitespace* stream eof-error-p eof-value recursivep))) ) ; with-system-redefinition-allowed cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Experimental/0000755000175000017500000000000011347764006017444 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Experimental/menu-choose.lisp0000644000175000017500000003031110200144463022537 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2002 by Alexey Dejneka (adejneka@comail.ru) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Long time TODO (if someone wants to implement them - you are welcome): ;;; ;;; - Menu item options: :items, :type. ;;; ;;; - VIEW. ;;; ;;; - Caching. ;;; ;;; - Default item. ;;; Mid time TODO: ;;; ;;; - Menu item options: :active. ;;; ;;; - Documentation. ;;; ;;; - Menu position. ;;; ;;; - Empty menu. ;;; TODO: ;;; ;;; + returned values ;;; + menu frame size ;;; + layout (in-package :CLIM-INTERNALS) (defgeneric menu-choose (items &key associated-window printer presentation-type default-item text-style label cache unique-id id-test cache-value cache-test max-width max-height n-rows n-columns x-spacing y-spacing row-wise cell-align-x cell-align-y scroll-bars pointer-documentation)) (defgeneric frame-manager-menu-choose (frame-manager items &key associated-window printer presentation-type default-item text-style label cache unique-id id-test cache-value cache-test max-width max-height n-rows n-columns x-spacing y-spacing row-wise cell-align-x cell-align-y scroll-bars pointer-documentation)) (defgeneric menu-choose-from-drawer (menu presentation-type drawer &key x-position y-position cache unique-id id-test cache-value cache-test default-presentation pointer-documentation)) ;;; (defun menu-item-value (menu-item) (cond ((atom menu-item) menu-item) ((atom (cdr menu-item)) (cdr menu-item)) (t (getf (cdr menu-item) :value (car menu-item))))) (defun menu-item-display (menu-item) (if (atom menu-item) menu-item (car menu-item))) (defun menu-item-options (menu-item) (if (and (consp menu-item) (consp (cdr menu-item))) (cdr menu-item) ; XXX Remove :VALUE? nil)) (defun menu-item-option (menu-item option &optional default) (getf (menu-item-options menu-item) option default)) (defun print-menu-item (menu-item &optional (stream *standard-output*)) (let ((style (getf (menu-item-options menu-item) :style '(nil nil nil)))) (with-text-style (stream style) (if (menu-item-option menu-item :active t) (princ (menu-item-display menu-item) stream) (with-drawing-options (stream :ink (compose-over (compose-in ; XXX it should be (MEDIUM-INK), ; but CLX backend is too stupid. ; -- APD, 2002-08-07 (medium-foreground stream) (make-opacity 0.5)) (medium-background stream))) (princ (menu-item-display menu-item) stream)))))) (defun draw-standard-menu (stream presentation-type items default-item &key item-printer max-width max-height n-rows n-columns x-spacing y-spacing row-wise cell-align-x cell-align-y) (declare (ignore default-item)) (orf item-printer #'print-menu-item) (format-items items :stream stream :printer (lambda (item stream) (let ((activep (menu-item-option item :active t))) (with-presentation-type-decoded (name params options) presentation-type (let ((*allow-sensitive-inferiors* activep)) (with-text-style (stream (or (getf (menu-item-options item) :style) '(:sans-serif nil nil))) (with-output-as-presentation (stream item `((,name ,@params) :description ,(getf (menu-item-options item) :documentation) ,@options)) (funcall item-printer item stream))))))) :presentation-type nil :x-spacing x-spacing :y-spacing y-spacing :n-columns n-columns :n-rows n-rows :max-width max-width :max-height max-height :cell-align-x cell-align-x :cell-align-y (or cell-align-y :top) :row-wise row-wise)) (defmacro with-menu ((menu &optional associated-window &key (deexpose t) label scroll-bars) &body body) (check-type menu symbol) (with-gensyms (with-menu-cont) `(flet ((,with-menu-cont (,menu) ,@body)) (declare (dynamic-extent #',with-menu-cont)) (invoke-with-menu #',with-menu-cont ,associated-window ; XXX ',deexpose ; XXX!!! ,label ,scroll-bars)))) (defun invoke-with-menu (continuation associated-window deexpose label scroll-bars) (declare (ignore deexpose label scroll-bars)) ; FIXME!!! (let* ((associated-frame (if associated-window (pane-frame associated-window) *application-frame*)) (fm (frame-manager associated-frame))) (with-look-and-feel-realization (fm associated-frame) ; hmm... checkme (let* ((stream (make-pane-1 fm associated-frame 'command-menu-pane :background +gray80+)) (raised (make-pane-1 fm associated-frame 'raised-pane :border-width 2 :background +gray80+ :contents (list stream))) (frame (make-menu-frame raised :left nil :top nil))) (adopt-frame fm frame) (change-space-requirements stream :width 1 :height 1) ;What is that supposed to do? --GB 2003-03-16 ; Shadow bug somewhere else? (unwind-protect (progn (setf (stream-end-of-line-action stream) :allow (stream-end-of-page-action stream) :allow) (funcall continuation stream)) (disown-frame fm frame)))))) (define-presentation-type menu-item ()) ;;; (defmethod menu-choose (items &rest args &key associated-window &allow-other-keys) (let* ((associated-frame (if associated-window (pane-frame associated-window) *application-frame*)) (frame-manager (frame-manager associated-frame))) (apply #'frame-manager-menu-choose frame-manager items args))) (defmethod frame-manager-menu-choose (frame-manager items ; XXX specialize on STANDARD-FRAME-MANAGER &rest options &key associated-window printer presentation-type (default-item nil default-item-p) text-style label cache unique-id id-test cache-value cache-test max-width max-height n-rows n-columns x-spacing y-spacing row-wise cell-align-x cell-align-y scroll-bars pointer-documentation) (flet ((drawer (stream type) (draw-standard-menu stream type items (if default-item-p default-item (first items)) :item-printer (if printer (lambda (item stream) (funcall printer (menu-item-display item) stream)) #'print-menu-item) :max-width max-width :max-height max-height :n-rows n-rows :n-columns n-columns :x-spacing x-spacing :y-spacing y-spacing :row-wise row-wise :cell-align-x cell-align-x :cell-align-y cell-align-y))) (multiple-value-bind (object event) (with-menu (menu associated-window) (when text-style (setf (medium-text-style menu) text-style)) (letf (((stream-default-view menu) +textual-menu-view+)) (menu-choose-from-drawer menu (or presentation-type 'menu-item) #'drawer :cache cache :unique-id unique-id :id-test id-test :cache-value cache-value :cache-test cache-test :pointer-documentation pointer-documentation))) (let ((subitems (menu-item-option object :items 'menu-item-no-items))) (if (eq subitems 'menu-item-no-items) (values (menu-item-value object) object event) (apply #'frame-manager-menu-choose frame-manager subitems options)))))) #+NIL (defmethod menu-choose-from-drawer (menu presentation-type drawer &key x-position y-position cache unique-id id-test cache-value cache-test default-presentation pointer-documentation) (funcall drawer menu presentation-type) (when (typep menu 'command-menu-pane) (with-bounding-rectangle* (x1 y1 x2 y2) (stream-output-history menu) (declare (ignorable x1 y1 x2 y2)) (change-space-requirements menu :width x2 :height y2 :resize-frame t))) (let ((*pointer-documentation-output* pointer-documentation)) (handler-case (with-input-context (presentation-type :override t) (object type event) (loop (read-gesture :stream menu)) (t (values object event))) (abort-gesture () (values nil))))) (defmethod menu-choose-from-drawer (menu presentation-type drawer &key x-position y-position cache unique-id id-test cache-value cache-test default-presentation pointer-documentation) (with-room-for-graphics (menu :first-quadrant nil) (funcall drawer menu presentation-type)) (when (typep menu 'command-menu-pane) (with-bounding-rectangle* (x1 y1 x2 y2) (stream-output-history menu) (declare (ignorable x1 y1 x2 y2)) (change-space-requirements menu :width x2 :height y2 :resize-frame t))) (let ((*pointer-documentation-output* pointer-documentation)) (tracking-pointer (menu :context-type presentation-type :multiple-window t :highlight t) (:pointer-button-press (&key event x y) ; Close if pointer clicked outside menu. (unless (and (sheet-ancestor-p (event-sheet event) menu) (region-contains-position-p (sheet-region menu) x y)) (return-from menu-choose-from-drawer (values nil)))) (:presentation-button-release (&key event presentation x y) (if (and (sheet-ancestor-p (event-sheet event) menu) (region-contains-position-p (sheet-region menu) x y)) (return-from menu-choose-from-drawer (values (presentation-object presentation) event)) (return-from menu-choose-from-drawer (values nil))))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Experimental/freetype/0000755000175000017500000000000011347763412021267 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Experimental/freetype/freetype-package-cffi.lisp0000640000175000017500000001236610435402052026270 0ustar pdmpdm;;;--------------------------------------------------------------------------- ;;; Moved this here to make loading more convenient for the way I edit ;;; code [2006/05/23:rpg] ;;;--------------------------------------------------------------------------- (DEFPACKAGE :FREETYPE (:import-from :cffi #:define-foreign-library #:use-foreign-library #:defctype #:defcenum ;;#:defcstruct #:defcunion #:defcfun ) (:USE :cl ;;; #+sbcl :sb-alien ;;; #+(or cmu scl) :alien #+(or cmu scl) :c-call ) (:EXPORT "MEMORY-BASE" "DESCENDER" "LINEAR-VERT-ADVANCE" "YX" "XX" "FREE" "AVAILABLE-SIZES" "COVERAGE" "METRICS" "RASTER-FLAG" "GLYPH" "GET-CHAR-INDEX" "LIMIT" "STRING" "SHIFT" "LEN" "UNDERLINE-POSITION" "RASTER-NEW-FUNC" "POINTS" "TAG" "SIZE-INTERNAL" "NUM-SUBGLYPHS" "UNITS-PER-EM" "LIBRARY" "ALLOC" "OPEN-FACE" "ATTACH-FILE" "BITMAP-TOP" "CURSOR" "BITMAP-LEFT" "MODULE" "PIXEL-MODE" "FREE-FUNC" "PITCH" "EXTENSIONS" "RASTER-RENDER-FUNC" "GET-KERNING" "UFWORD" "OPEN-ARGS" "RASTER-FUNCS" "INT32" "PREV" "LOAD-CHAR" "PATHNAME" "HORI-BEARING-Y" "RASTER-RENDER" "ENCODING" "OUTLINE-CONIC-TO-FUNC" "STREAM" "RASTER-RESET" "MOVE-TO" "GENERIC" "ATTACH-STREAM" "Y-MAX" "X-MAX" "FACE-INDEX" "SUBGLYPHS" "BITMAP" "BITMAP-SIZE" "ADVANCE" "MUL-FIX" "SET-PIXEL-SIZES" "OUTLINE-CUBIC-TO-FUNC" "FACE-INTERNAL" "WCHAR-T" "BLACK-SPANS" "TAGS" "N-CONTOURS" "YY" "XY" "CONIC-TO" "INT" "UNDERLINE-THICKNESS" "NUM-FACES" "Y-PPEM" "X-PPEM" "PLATFORM-ID" "ASCENDER" "DIV-FIX" "USHORT" "WINT-T" "CONTROL-LEN" "WIDTH" "NEW-FACE" "CHAR-MAP-REC" "Y-SCALE" "X-SCALE" "ALLOC-FUNC" "OUTLINE-FUNCS" "RASTER-DONE" "UINT16" "FINALIZER" "RENDER-GLYPH" "GLYPH-METRICS" "RASTER-SPAN-FUNC" "CONTOURS" "GLYPH-SLOT-REC" "VERT-BEARING-Y" "INIT-FREE-TYPE" "CLIP-BOX" "RASTER-RESET-FUNC" "FLAGS" "USER" "MEMORY-SIZE" "HEIGHT" "N-POINTS" "UINT" "VECTOR" "NEXT" "LIST" "MEMORY" "BUFFER" "MUL-DIV" "PARAMS" "GET-GLYPH-NAME" "PTRDIFF-T" "CHAR-MAP" "FWORD" "OUTLINE-MOVE-TO-FUNC" "STREAM-CLOSE" "SET-TRANSFORM" "FLOOR-FIX" "GLYPH-FORMAT" "GLYPH-SLOT" "KERNING-MODE" "INT16" "POS" "FAST" "CONTROL-DATA" "NUM-PARAMS" "STYLE-FLAGS" "CHARMAP" "OUTLINE-LINE-TO-FUNC" "SELECT-CHARMAP" "TARGET" "TAIL" "SLOT-INTERNAL" "OUTLINE-FLAGS" "RASTER-SET-MODE" "LIST-NODE" "NEW-MEMORY-FACE" "SIZE-REC" "RASTER-DONE-FUNC" "HORI-ADVANCE" "RASTER" "REALLOC-FUNC" "READ" "ROUND-FIX" "LIST-REC" "UINT32" "ULONG" "HEAD" "DRIVER" "MAX-ADVANCE-HEIGHT" "SIZE-T" "Y-MIN" "X-MIN" "RASTER-SET-MODE-FUNC" "SIZE-METRICS" "ROWS" "OUTLINE" "Y" "X" "ENCODING-ID" "FORMAT" "REALLOC" "INTERNAL" "SIZES-LIST" "MAX-ADVANCE-WIDTH" "DONE-FACE" "SIZE" "SUB-GLYPH" "BBOX" "POINTER" "DELTA" "CEIL-FIX" "PARAMETER" "OFFSET" "MATRIX" "FACE-REC" "GRAY-SPANS" "PALETTE-MODE" "NUM-FIXED-SIZES" "BYTE" "SPAN" "VECTOR-TRANSFORM" "NUM-GRAYS" "RASTER-BIT-SET-FUNC" "RENDERER" "VALUE" "BIT-TEST" "SOURCE" "STYLE-NAME" "LINE-TO" "STREAM-DESC" "LONG" "UNIT-VECTOR" "LIST-NODE-REC" "HORI-BEARING-X" "VERT-ADVANCE" "CUBIC-TO" "GENERIC-FINALIZER" "CHAR" "PTR-DIST" "UFAST" "DESCRIPTOR" "SET-CHAR-SIZE" "LINEAR-HORI-ADVANCE" "MAX-ADVANCE" "AUTOHINT" "FIXED" "OPEN-FLAGS" "BASE" "ERROR" "NUM-GLYPHS" "DATA" "RENDER-MODE" "CHARMAPS" "FACE" "F26DOT6" "OTHER" "RASTER-PARAMS" "SET-CHARMAP" "NUM-CHARMAPS" "LOAD-GLYPH" "RASTER-BIT-TEST-FUNC" "RASTER-NEW" "FAMILY-NAME" "DONE-FREE-TYPE" "BIT-SET" "VERT-BEARING-X" "F2DOT14" "CLOSE" "STREAM-IO" "FACE-FLAGS" "BOOL" "SHORT" "PALETTE" "C" "PALETTE-MODE-" "SIZE-REC-" "B" "A" "RENDER_MODE" "RIGHT_GLYPH" "SIZE-INTERNAL-REC-" "CHAR-MAP-REC-" "RASTER-FUNCS-" "SUB-GLYPH-" "SLOT-INTERNAL-REC-" "OUTLINE-" "RENDER-MODE-" "GLYPH-METRICS-" "PARAMETER-" "LOAD_FLAGS" "MATRIX-" "ARGS" "GLYPH_INDEX" "OUTLINE-FLAGS-" "MEMORY-REC-" "PIXEL_WIDTH" "VEC" "HORZ_RESOLUTION" "LIST-REC-" "STREAM-REC-" "BUFFER_MAX" "LIBRARY-REC-" "SPAN-" "GLYPH-SLOT-REC-" "VERT_RESOLUTION" "LEFT_GLYPH" "PIXEL-MODE-" "AFACE" "MODULE-REC-" "PIXEL_HEIGHT" "CHARCODE" "AKERNING" "ALIBRARY" "LIST-NODE-REC-" "KERNING-MODE-" "FACE-REC-" "BITMAP-SIZE-" "DRIVER-REC-" "FILE_SIZE" "STREAM-DESC-" "FACE-INTERNAL-REC-" "FILEPATHNAME" "UNIT-VECTOR-" "PARAMETERS" "RASTER-PARAMS-" "OUTLINE-FUNCS-" "CHAR_HEIGHT" "BITMAP-" "FILE_BASE" "KERN_MODE" "CHAR_CODE" "RENDERER-REC-" "RASTER-REC-" "VECTOR-" "SIZE-METRICS-" "CHAR_WIDTH" "GENERIC-" "ENCODING-" "FACE_INDEX" "SLOT" "GLYPH-FORMAT-" "OPEN-ARGS-" "BBOX-" "SIZE_S")) (defpackage :mcclim-freetype (:use :climi :clim :clim-lisp) (:export :*freetype-font-path*) (:import-from :cffi #:with-foreign-slots #:foreign-slot-value #:foreign-alloc) (:import-from :freetype #:glyph #:bitmap #:width #:pitch #:rows #:buffer #:x #:y #:bitmap-left #:bitmap-top #:advance #:ascender #:descender #:size_s #:metrics) ;;; (:import-from #+cmucl :alien ;;; #+sbcl :sb-alien ;;; :slot :make-alien :alien :deref) ) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Experimental/freetype/mcclim-native-ttf.lisp0000644000175000017500000002030610750306654025502 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: MCCLIM-TRUETYPE; -*- ;;; --------------------------------------------------------------------------- ;;; Title: Glyph rendering via zpb-ttf and cl-vectors ;;; Created: 2008-01-26 16:32 ;;; Author: Andy Hefner ;;; License: LGPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2008 by Andy Hefner ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :mcclim-truetype) ;;; TODO: ;;; * Kerning (we didn't do this with Freetype, either. Oops.) ;;; * Implement fixed-font-width-p for zpb-ttf. ;;; * Boxes for missing glyphs. ;;; * Make certain left/right bearings and text-bounding-rectangle* ;;; are correct. (I doubt they are..) ;;; Wish-list: ;;; * Subpixel antialiasing. It would be straightforward to generate the ;;; glyphs by tripling the width as passed to cl-vectors and compressing ;;; triplets of pixels together ourselves. I'm not certain how to draw ;;; the result through xrender. I've seen hints on Google that there is ;;; subpixel AA support in xrender, which isn't obvious from CLX or the ;;; spec. Failing that, we could use a 24bpp mask with component-alpha. ;;; That might even be how you're supposed to do it. I'm skeptical as to ;;; whether this would be accelerated for most people. ;;; * Subpixel positioning. Not hard in principle - render multiple versions ;;; of each glyph, offset by fractions of a pixel. Horizontal positioning ;;; is more important than vertical, so 1/4 pixel horizontal resolution ;;; and 1 pixel vertical resolution should suffice. Given how ugly most ;;; CLIM apps are, and the lack of WYSIWYG document editors crying out ;;; for perfect text spacing in small fonts, we don't really need this. ;; So weird.. (defun make-vague-font (filename) (let ((val (gethash filename *vague-font-hash*))) (or val (setf (gethash filename *vague-font-hash*) (make-instance 'vague-font :lib t :filename filename))))) ;;; Ignore the 'concrete font' indirection. #+NIL (defun make-concrete-font (vague-font size &key (dpi *dpi*)) (error "Go away.")) #+NIL (defun set-concrete-font-size (face size dpi) (declare (ignore face size dpi))) (defclass zpb-ttf-face (truetype-face) ((font-loader :reader zpb-ttf-font-loader :initarg :loader) (units->pixels :reader zpb-ttf-font-units->pixels :initarg :units->pixels))) (let ((font-loader-cache (make-hash-table :test #'equal)) (font-cache (make-hash-table :test #'equal))) (defun make-truetype-face (display filename size) (unless display (break "no display!")) (let* ((loader (or (gethash filename font-loader-cache) (setf (gethash filename font-loader-cache) (zpb-ttf:open-font-loader filename)))) (units/em (zpb-ttf:units/em loader)) (pixel-size (* size (/ *dpi* 72))) (units->pixels (* pixel-size (/ units/em))) (font (or (gethash (list display loader size) font-cache) (setf (gethash (list display loader size) font-cache) (make-instance 'zpb-ttf-face :display display :filename filename :size size :units->pixels units->pixels :loader loader :ascent (* (zpb-ttf:ascender loader) units->pixels) :descent (- (* (zpb-ttf:descender loader) units->pixels))))))) font))) (defmethod print-object ((object zpb-ttf-face) stream) (print-unreadable-object (object stream :type t :identity nil) (with-slots (font-loader filename size ascent descent) object (format stream "~W size=~A ascent=~A descent=~A" (or (zpb-ttf:name-entry-value :full-name font-loader) filename) size ascent descent)))) (defun glyph-pixarray (font char) "Render a character of 'face', returning a 2D (unsigned-byte 8) array suitable as an alpha mask, and dimensions. This function returns five values: alpha mask byte array, x-origin, y-origin (subtracted from position before rendering), horizontal and vertical advances." (declare (optimize (debug 3))) (with-slots (font-loader units->pixels size ascent descent) font (let* ((glyph (zpb-ttf:find-glyph char font-loader)) (left-side-bearing (* units->pixels (zpb-ttf:left-side-bearing glyph))) (right-side-bearing (* units->pixels (zpb-ttf:right-side-bearing glyph))) (advance-width (* units->pixels (zpb-ttf:advance-width glyph))) (bounding-box (map 'vector (lambda (x) (float (* x units->pixels))) (zpb-ttf:bounding-box glyph))) (min-x (elt bounding-box 0)) (min-y (elt bounding-box 1)) (max-x (elt bounding-box 2)) (max-y (elt bounding-box 3)) (width (- (ceiling max-x) (floor min-x))) (height (- (ceiling max-y) (floor min-y))) (array (make-array (list height width) :initial-element 0 :element-type '(unsigned-byte 8))) (state (aa:make-state)) (paths (paths-ttf:paths-from-glyph glyph :offset (paths:make-point (- (floor min-x)) (ceiling max-y)) :scale-x units->pixels :scale-y (- units->pixels)))) (assert (<= (elt bounding-box 0) (elt bounding-box 2))) (assert (<= (elt bounding-box 1) (elt bounding-box 3))) ;; Oops. I think the other mcclim-truetype code expects that the rendered glyph ;; includes the left and right bearing, as it computes right = width - left. ;; Fix that. (Do we even use 'right' anywhere?) ;(assert (= left-side-bearing (elt bounding-box 0))) ; Doesn't hold. #+NIL (assert (= advance-width (+ left-side-bearing right-side-bearing (elt bounding-box 2) (- (elt bounding-box 0))))) (dolist (path paths) (vectors:update-state state path)) (aa:cells-sweep state (lambda (x y alpha) (when (and (<= 0 x (1- width)) (<= 0 y (1- height))) (setf alpha (min 255 (abs alpha)) (aref array y x) (climi::clamp (floor (+ (* (- 256 alpha) (aref array y x)) (* alpha 255)) 256) 0 255))))) (values array (floor min-x) (ceiling max-y) (round advance-width) ;; Bah! Why does X add the vertical advance when we are rendering horizontally? ;; Is this considered a property of the font and glyphs rather than a particular drawing call? 0 #+NIL (round (+ ascent descent)))))) (defun font-fixed-width-p (zpb-ttf-font) (declare (ignore zpb-ttf-font)) nil) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Experimental/freetype/mcclim-truetype.asd0000644000175000017500000000227510750306654025107 0ustar pdmpdm;;;; -*- Lisp -*- #| The mcclim-truetype system extends the CLX backend with antialiased font rendering in 100% Common Lisp (no foreign code), using the XRender extension and the libraries zpb-ttf and cl-vectors. To autoload mcclim-truetype after mcclim, link this file to a directory in your asdf:*central-registry* and add the following to your lisp's init file: (defmethod asdf:perform :after ((o asdf:load-op) (s (eql (asdf:find-system :clim-clx)))) (asdf:oos 'asdf:load-op :mcclim-freetype)) |# (defpackage :mcclim-truetype-system (:use :cl :asdf)) (in-package :mcclim-truetype-system) (defsystem :mcclim-truetype :depends-on (:clim-clx :mcclim :zpb-ttf :cl-vectors :cl-paths-ttf :cl-aa) :serial t :components ((:file "truetype-package") (:file "xrender-fonts") (:file "fontconfig") (:file "mcclim-native-ttf"))) (defmethod perform :after ((o load-op) (s (eql (asdf:find-system :mcclim-truetype)))) "Detect fonts using fc-match" (let ((autoconfig (find-symbol (symbol-name '#:autoconfigure-fonts) :mcclim-truetype))) (unless autoconfig (error "Couldn't find autoconfigure-fonts. This shouldn't happen.")) (funcall autoconfig))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Experimental/freetype/freetype-cffi.lisp0000640000175000017500000005714710435402052024705 0ustar pdmpdm;;; automatically generated, hand tweaked, do not regenerate. (in-package :freetype) (define-foreign-library libfreetype (:unix (:or "libfreetype.so.6" "libfreetype")) (t (:default "libfreetype"))) (use-foreign-library libfreetype) (defmacro define-alien-type (&rest rest) ;; cffi seems to have a much simpler model of pointer ;; types... [2006/05/23:rpg] (cond ((and (= (length rest) 2) (eq (car (second rest)) '*)) `(defctype ,(first rest) :pointer)) ((error "Don't understand how to translate alien type definition ~S" `(define-alien-type ,@rest))))) (defmacro define-alien-routine (name retval &rest args) `(defcfun ,name ,retval ,@(loop for (name type) in args for new-type = (if (and (listp type) (eq (car type) '*)) :pointer type) collect (list name new-type)))) (defmacro defcstruct (name &rest slots) `(cffi:defcstruct ,name ,@(loop for (name type) in slots for new-type = (if (and (listp type) (eq (car type) '*)) :pointer type) collect (list name new-type)))) (declaim (optimize (speed 3))) (define-alien-type freetype:memory (* (struct freetype::memory-rec-))) (define-alien-type freetype:stream (* (struct freetype::stream-rec-))) (define-alien-type freetype:raster (* (struct freetype::raster-rec-))) (define-alien-type freetype:list-node (* (struct freetype::list-node-rec-))) (define-alien-type freetype:list (* (struct freetype::list-rec-))) (define-alien-type freetype:library (* (struct freetype::library-rec-))) (define-alien-type freetype:module (* (struct freetype::module-rec-))) (define-alien-type freetype:driver (* (struct freetype::driver-rec-))) (define-alien-type freetype:renderer (* (struct freetype::renderer-rec-))) (define-alien-type freetype:char-map (* (struct freetype::char-map-rec-))) (define-alien-type freetype:face-internal (* (struct freetype::face-internal-rec-))) (define-alien-type freetype:slot-internal (* (struct freetype::slot-internal-rec-))) (define-alien-type freetype:size-internal (* (struct freetype::size-internal-rec-))) (defctype freetype:int16 :int16) (defctype freetype:uint16 :uint16) (defctype freetype:int32 :int32) (defctype freetype:uint32 :uint32) (defctype freetype:fast :int32) (defctype freetype:ufast :uint32) (defctype freetype:ptrdiff-t :int32) (defctype freetype:size-t :uint32) (defctype freetype:wchar-t :int32) (defctype freetype:wint-t :uint32) (defctype freetype:bool :uint8) (defctype freetype:fword :int16) (defctype freetype:ufword :uint16) (defctype freetype:char :int8) (defctype freetype:byte :uint8) (defctype freetype:string :int8) (defctype freetype:short :int16) (defctype freetype:ushort :uint16) (defctype freetype:int :int32) (defctype freetype:uint :uint32) (defctype freetype:long :long) (defctype freetype:ulong :unsigned-long) (defctype freetype:f2dot14 :int16) (defctype freetype:f26dot6 :long) (defctype freetype:fixed :long) (defctype freetype:error :int32) (defctype freetype:pointer :pointer) (defctype freetype:offset freetype:size-t) (defctype freetype:ptr-dist freetype:size-t) (define-alien-type freetype:face (* freetype:face-rec)) (defcenum mod-err (:mod-err-base #.#x000) (:mod-err-autohint #.#x100) (:mod-err-cache #.#x200) (:mod-err-cff #.#x300) (:mod-err-cid #.#x400) (:mod-err-pcf #.#x500) (:mod-err-psaux #.#x600) (:mod-err-psnames #.#x700) (:mod-err-raster #.#x800) (:mod-err-sfnt #.#x900) (:mod-err-smooth #.#xA00) (:mod-err-true-type #.#xB00) (:mod-err-type1 #.#xC00) (:mod-err-winfonts #.#xD00) :mod-err-max) (defcenum error-enum (:err-ok #.#x00) (:err-cannot-open-resource #.(+ #x01 0)) (:err-unknown-file-format #.(+ #x02 0)) (:err-invalid-file-format #.(+ #x03 0)) (:err-invalid-version #.(+ #x04 0)) (:err-lower-module-version #.(+ #x05 0)) (:err-invalid-argument #.(+ #x06 0)) (:err-unimplemented-feature #.(+ #x07 0)) (:err-invalid-glyph-index #.(+ #x10 0)) (:err-invalid-character-code #.(+ #x11 0)) (:err-invalid-glyph-format #.(+ #x12 0)) (:err-cannot-render-glyph #.(+ #x13 0)) (:err-invalid-outline #.(+ #x14 0)) (:err-invalid-composite #.(+ #x15 0)) (:err-too-many-hints #.(+ #x16 0)) (:err-invalid-pixel-size #.(+ #x17 0)) (:err-invalid-handle #.(+ #x20 0)) (:err-invalid-library-handle #.(+ #x21 0)) (:err-invalid-driver-handle #.(+ #x22 0)) (:err-invalid-face-handle #.(+ #x23 0)) (:err-invalid-size-handle #.(+ #x24 0)) (:err-invalid-slot-handle #.(+ #x25 0)) (:err-invalid-char-map-handle #.(+ #x26 0)) (:err-invalid-cache-handle #.(+ #x27 0)) (:err-invalid-stream-handle #.(+ #x28 0)) (:err-too-many-drivers #.(+ #x30 0)) (:err-too-many-extensions #.(+ #x31 0)) (:err-out-of-memory #.(+ #x40 0)) (:err-unlisted-object #.(+ #x41 0)) (:err-cannot-open-stream #.(+ #x51 0)) (:err-invalid-stream-seek #.(+ #x52 0)) (:err-invalid-stream-skip #.(+ #x53 0)) (:err-invalid-stream-read #.(+ #x54 0)) (:err-invalid-stream-operation #.(+ #x55 0)) (:err-invalid-frame-operation #.(+ #x56 0)) (:err-nested-frame-access #.(+ #x57 0)) (:err-invalid-frame-read #.(+ #x58 0)) (:err-raster-uninitialized #.(+ #x60 0)) (:err-raster-corrupted #.(+ #x61 0)) (:err-raster-overflow #.(+ #x62 0)) (:err-raster-negative-height #.(+ #x63 0)) (:err-too-many-caches #.(+ #x70 0)) (:err-invalid-opcode #.(+ #x80 0)) (:err-too-few-arguments #.(+ #x81 0)) (:err-stack-overflow #.(+ #x82 0)) (:err-code-overflow #.(+ #x83 0)) (:err-bad-argument #.(+ #x84 0)) (:err-divide-by-zero #.(+ #x85 0)) (:err-invalid-reference #.(+ #x86 0)) (:err-debug-op-code #.(+ #x87 0)) (:err-endf-in-exec-stream #.(+ #x88 0)) (:err-nested-defs #.(+ #x89 0)) (:err-invalid-code-range #.(+ #x8A 0)) (:err-execution-too-long #.(+ #x8B 0)) (:err-too-many-function-defs #.(+ #x8C 0)) (:err-too-many-instruction-defs #.(+ #x8D 0)) (:err-table-missing #.(+ #x8E 0)) (:err-horiz-header-missing #.(+ #x8F 0)) (:err-locations-missing #.(+ #x90 0)) (:err-name-table-missing #.(+ #x91 0)) (:err-cmap-table-missing #.(+ #x92 0)) (:err-hmtx-table-missing #.(+ #x93 0)) (:err-post-table-missing #.(+ #x94 0)) (:err-invalid-horiz-metrics #.(+ #x95 0)) (:err-invalid-char-map-format #.(+ #x96 0)) (:err-invalid-ppem #.(+ #x97 0)) (:err-invalid-vert-metrics #.(+ #x98 0)) (:err-could-not-find-context #.(+ #x99 0)) (:err-invalid-post-table-format #.(+ #x9A 0)) (:err-invalid-post-table #.(+ #x9B 0)) (:err-syntax-error #.(+ #xA0 0)) (:err-stack-underflow #.(+ #xA1 0)) :err-max) (defctype freetype:alloc-func :pointer) (defctype freetype:free-func :pointer) (defctype freetype:realloc-func :pointer) (defcstruct freetype::memory-rec- (freetype:user :pointer) (freetype:alloc freetype:alloc-func) (freetype:free freetype:free-func) (freetype:realloc freetype:realloc-func)) (defcunion freetype:stream-desc (freetype:value :long) (freetype:pointer :pointer)) (defctype freetype:stream-io :pointer) (defctype freetype:stream-close :pointer) (defcstruct freetype::stream-rec- (freetype:base (* :uint8)) (freetype:size freetype:ulong) (freetype:pos freetype:ulong) (freetype:descriptor freetype:stream-desc) (freetype:pathname freetype:stream-desc) (freetype:read freetype:stream-io) (freetype:close freetype:stream-close) (freetype:memory freetype:memory) (freetype:cursor (* :uint8)) (freetype:limit (* :uint8))) (defctype freetype:pos :long) (defcstruct freetype:vector (freetype:x freetype:pos) (freetype:y freetype:pos)) (defcstruct freetype:bbox (freetype:x-min freetype:pos) (freetype:y-min freetype:pos) (freetype:x-max freetype:pos) (freetype:y-max freetype:pos)) ;; seems like pixel-mode- might possibly be an alias for this... (defcenum freetype:pixel-mode (:ft-pixel-mode-none #.#o0) :ft-pixel-mode-mono :ft-pixel-mode-grays :ft-pixel-mode-pal2 :ft-pixel-mode-pal4 :ft-pixel-mode-pal8 :ft-pixel-mode-rgb15 :ft-pixel-mode-rgb16 :ft-pixel-mode-rgb24 :ft-pixel-mode-rgb32 :ft-pixel-mode-max) ;;; palette-mode- (defcenum freetype:palette-mode (:ft-palette-mode-rgb #.#o0) :ft-palette-mode-rgba :ft-palettte-mode-max) (defcstruct freetype:bitmap (freetype:rows :int32) (freetype:width :int32) (freetype:pitch :int32) (freetype:buffer (* :uint8)) (freetype:num-grays :int16) (freetype:pixel-mode :int8) (freetype:palette-mode :int8) (freetype:palette :pointer)) (defcstruct freetype:outline (freetype:n-contours :int16) (freetype:n-points :int16) (freetype:points (* freetype:vector)) (freetype:tags (* :int8)) (freetype:contours (* :int16)) (freetype:flags :int32)) (defcenum freetype:outline-flags (:ft-outline-none #.#o0) (:ft-outline-owner #.1) (:ft-outline-even-odd-fill #.2) (:ft-outline-reverse-fill #.4) (:ft-outline-ignore-dropouts #.8) (:ft-outline-high-precision #.256) (:ft-outline-single-pass #.512)) (defctype freetype:outline-move-to-func :pointer) (defctype freetype:outline-line-to-func :pointer) (defctype freetype:outline-conic-to-func :pointer) (defctype freetype:outline-cubic-to-func :pointer) (defcstruct freetype:outline-funcs (freetype:move-to freetype:outline-move-to-func) (freetype:line-to freetype:outline-line-to-func) (freetype:conic-to freetype:outline-conic-to-func) (freetype:cubic-to freetype:outline-cubic-to-func) (freetype:shift :int32) (freetype:delta freetype:pos)) (defcenum freetype:glyph-format (:ft-glyph-format-none #.(logior (logior (logior (ash #o0 24) (ash #o0 16)) (ash #o0 8)) #o0)) (:ft-glyph-format-composite #.(logior (logior (logior (ash #.(char-code #\c) 24) (ash #.(char-code #\o) 16)) (ash #.(char-code #\m) 8)) #.(char-code #\p))) (:ft-glyph-format-bitmap #.(logior (logior (logior (ash #.(char-code #\b) 24) (ash #.(char-code #\i) 16)) (ash #.(char-code #\t) 8)) #.(char-code #\s))) (:ft-glyph-format-outline #.(logior (logior (logior (ash #.(char-code #\o) 24) (ash #.(char-code #\u) 16)) (ash #.(char-code #\t) 8)) #.(char-code #\l))) (:ft-glyph-format-plotter #.(logior (logior (logior (ash #.(char-code #\p) 24) (ash #.(char-code #\l) 16)) (ash #.(char-code #\o) 8)) #.(char-code #\t)))) (defcstruct freetype:span (freetype:x :int16) (freetype:len :uint16) (freetype:coverage :uint8)) (defctype freetype:raster-span-func :pointer) (defctype freetype:raster-bit-test-func :pointer) (defctype freetype:raster-bit-set-func :pointer) (defcenum freetype:raster-flag (:ft-raster-flag-default #.#o0) (:ft-raster-flag-aa #.1) (:ft-raster-flag-direct #.2) (:ft-raster-flag-clip #.4)) (defcstruct freetype:raster-params (freetype:target (* freetype:bitmap)) (freetype:source :pointer) (freetype:flags :int32) (freetype:gray-spans freetype:raster-span-func) (freetype:black-spans freetype:raster-span-func) (freetype:bit-test freetype:raster-bit-test-func) (freetype:bit-set freetype:raster-bit-set-func) (freetype:user :pointer) (freetype:clip-box freetype:bbox)) (defctype freetype:raster-new-func :pointer) (defctype freetype:raster-done-func :pointer) (defctype freetype:raster-reset-func :pointer) (defctype freetype:raster-set-mode-func :pointer) (defctype freetype:raster-render-func :pointer) (defcstruct freetype:raster-funcs (freetype:glyph-format freetype:glyph-format) (freetype:raster-new freetype:raster-new-func) (freetype:raster-reset freetype:raster-reset-func) (freetype:raster-set-mode freetype:raster-set-mode-func) (freetype:raster-render freetype:raster-render-func) (freetype:raster-done freetype:raster-done-func)) (defcstruct freetype:unit-vector (freetype:x freetype:f2dot14) (freetype:y freetype:f2dot14)) (defcstruct freetype:matrix (freetype:xx freetype:fixed) (freetype:xy freetype:fixed) (freetype:yx freetype:fixed) (freetype:yy freetype:fixed)) (defctype freetype:generic-finalizer :pointer) (defcstruct freetype:generic (freetype:data :pointer) (freetype:finalizer freetype:generic-finalizer)) (defcstruct freetype:list-node-rec (freetype:prev freetype:list-node) (freetype:next freetype:list-node) (freetype:data :pointer)) (defcstruct freetype:list-rec (freetype:head freetype:list-node) (freetype:tail freetype:list-node)) (defcstruct freetype:glyph-metrics (freetype:width freetype:pos) (freetype:height freetype:pos) (freetype:hori-bearing-x freetype:pos) (freetype:hori-bearing-y freetype:pos) (freetype:hori-advance freetype:pos) (freetype:vert-bearing-x freetype:pos) (freetype:vert-bearing-y freetype:pos) (freetype:vert-advance freetype:pos)) (defcstruct freetype:bitmap-size (freetype:height freetype:short) (freetype:width freetype:short)) (defctype freetype:sub-glyph :pointer) ;; (struct freetype::sub-glyph-)) (defcstruct freetype:glyph-slot-rec (freetype:library freetype:library) (freetype:face (* (struct freetype::face-rec-))) (freetype:next (* (struct freetype::glyph-slot-rec-))) (freetype:flags freetype:uint) (freetype:generic freetype:generic) (freetype:metrics freetype:glyph-metrics) (freetype:linear-hori-advance freetype:fixed) (freetype:linear-vert-advance freetype:fixed) (freetype:advance freetype:vector) (freetype:format freetype:glyph-format) (freetype:bitmap freetype:bitmap) (freetype:bitmap-left freetype:int) (freetype:bitmap-top freetype:int) (freetype:outline freetype:outline) (freetype:num-subglyphs freetype:uint) (freetype:subglyphs (* freetype:sub-glyph)) (freetype:control-data :pointer) (freetype:control-len :long) (freetype:other :pointer) (freetype:internal freetype:slot-internal)) (defcstruct freetype:size-metrics (freetype:x-ppem freetype:ushort) (freetype:y-ppem freetype:ushort) (freetype:x-scale freetype:fixed) (freetype:y-scale freetype:fixed) (freetype:ascender freetype:pos) (freetype:descender freetype:pos) (freetype:height freetype:pos) (freetype:max-advance freetype:pos)) (defcstruct freetype:size-rec (freetype:face (* (struct freetype::face-rec-))) (freetype:generic freetype:generic) (freetype:metrics freetype:size-metrics) (freetype:internal freetype:size-internal)) (defcstruct freetype:face-rec (freetype:num-faces freetype:long) (freetype:face-index freetype:long) (freetype:face-flags freetype:long) (freetype:style-flags freetype:long) (freetype:num-glyphs freetype:long) (freetype:family-name (* freetype:string)) (freetype:style-name (* freetype:string)) (freetype:num-fixed-sizes freetype:int) (freetype:available-sizes (* freetype:bitmap-size)) (freetype:num-charmaps freetype:int) (freetype:charmaps (* freetype:char-map)) (freetype:generic freetype:generic) (freetype:bbox freetype:bbox) (freetype:units-per-em freetype:ushort) (freetype:ascender freetype:short) (freetype:descender freetype:short) (freetype:height freetype:short) (freetype:max-advance-width freetype:short) (freetype:max-advance-height freetype:short) (freetype:underline-position freetype:short) (freetype:underline-thickness freetype:short) (freetype:glyph (* (struct freetype::glyph-slot-rec-))) (freetype:size_s (* (struct freetype:size-rec))) (freetype:charmap freetype:char-map) (freetype:driver freetype:driver) (freetype:memory freetype:memory) (freetype:stream freetype:stream) (freetype:sizes-list freetype:list-rec) (freetype:autohint freetype:generic) (freetype:extensions :pointer) (freetype:internal freetype:face-internal)) (defcstruct freetype:size-rec (freetype:face (* freetype:face-rec)) (freetype:generic freetype:generic) (freetype:metrics freetype:size-metrics) (freetype:internal freetype:size-internal)) (defcstruct freetype:glyph-slot-rec (freetype:library freetype:library) (freetype:face (* freetype:face-rec)) (freetype:next (* (struct freetype::glyph-slot-rec-))) (freetype:flags freetype:uint) (freetype:generic freetype:generic) (freetype:metrics freetype:glyph-metrics) (freetype:linear-hori-advance freetype:fixed) (freetype:linear-vert-advance freetype:fixed) (freetype:advance freetype:vector) (freetype:format freetype:glyph-format) (freetype:bitmap freetype:bitmap) (freetype:bitmap-left freetype:int) (freetype:bitmap-top freetype:int) (freetype:outline freetype:outline) (freetype:num-subglyphs freetype:uint) (freetype:subglyphs (* freetype:sub-glyph)) (freetype:control-data :pointer) (freetype:control-len :long) (freetype:other :pointer) (freetype:internal freetype:slot-internal)) (define-alien-type freetype:glyph-slot (* freetype:glyph-slot-rec)) (define-alien-type freetype:size (* freetype:size-rec)) (define-alien-routine ("FT_Init_FreeType" freetype:init-free-type) freetype:error (freetype::alibrary (* freetype:library))) (define-alien-routine ("FT_Done_FreeType" freetype:done-free-type) freetype:error (freetype:library freetype:library)) (defcenum freetype:open-flags (:ft-open-memory #.1) (:ft-open-stream #.2) (:ft-open-pathname #.4) (:ft-open-driver #.8) (:ft-open-params #.16)) (defcstruct freetype:parameter (freetype:tag freetype:ulong) (freetype:data freetype:pointer)) (defcstruct freetype:open-args (freetype:flags freetype:open-flags) (freetype:memory-base (* freetype:byte)) (freetype:memory-size freetype:long) (freetype:pathname (* freetype:string)) (freetype:stream freetype:stream) (freetype:driver freetype:module) (freetype:num-params freetype:int) (freetype:params (* freetype:parameter))) (define-alien-routine ("FT_New_Face" freetype:new-face) freetype:error (freetype:library freetype:library) (freetype::filepathname :string) (freetype::face_index freetype:long) ;; this is a pointer to a pointer to a face-rec... (freetype::aface (* (* freetype:face-rec)))) (define-alien-routine ("FT_New_Memory_Face" freetype:new-memory-face) freetype:error (freetype:library freetype:library) (freetype::file_base (* freetype:byte)) (freetype::file_size freetype:long) (freetype::face_index freetype:long) (freetype::aface (* freetype:face))) (define-alien-routine ("FT_Open_Face" freetype:open-face) freetype:error (freetype:library freetype:library) (freetype::args (* freetype:open-args)) (freetype::face_index freetype:long) (freetype::aface (* freetype:face))) (define-alien-routine ("FT_Attach_File" freetype:attach-file) freetype:error (freetype:face freetype:face) (freetype::filepathname (* :int8))) (define-alien-routine ("FT_Attach_Stream" freetype:attach-stream) freetype:error (freetype:face freetype:face) (freetype::parameters (* freetype:open-args))) (define-alien-routine ("FT_Done_Face" freetype:done-face) freetype:error (freetype:face freetype:face)) (define-alien-routine ("FT_Set_Char_Size" freetype:set-char-size) freetype:error (freetype:face freetype:face) (freetype::char_width freetype:f26dot6) (freetype::char_height freetype:f26dot6) (freetype::horz_resolution freetype:uint) (freetype::vert_resolution freetype:uint)) (define-alien-routine ("FT_Set_Pixel_Sizes" freetype:set-pixel-sizes) freetype:error (freetype:face freetype:face) (freetype::pixel_width freetype:uint) (freetype::pixel_height freetype:uint)) (define-alien-routine ("FT_Load_Glyph" freetype:load-glyph) freetype:error (freetype:face freetype:face) (freetype::glyph_index freetype:uint) (freetype::load_flags freetype:int)) (define-alien-routine ("FT_Load_Char" freetype:load-char) freetype:error (freetype:face freetype:face) (freetype::char_code freetype:ulong) (freetype::load_flags freetype:int)) (define-alien-routine ("FT_Set_Transform" freetype:set-transform) :void (freetype:face freetype:face) (freetype:matrix (* freetype:matrix)) (freetype:delta (* freetype:vector))) (defcenum freetype:render-mode (:ft-render-mode-normal #.#o0) (:ft-render-mode-mono #.1)) (define-alien-routine ("FT_Render_Glyph" freetype:render-glyph) freetype:error (freetype::slot freetype:glyph-slot) (freetype::render_mode freetype:uint)) (defcenum freetype::kerning-mode- (:ft-kerning-default #.#o0) :ft-kerning-unfitted :ft-kerning-unscaled) (define-alien-routine ("FT_Get_Kerning" freetype:get-kerning) freetype:error (freetype:face freetype:face) (freetype::left_glyph freetype:uint) (freetype::right_glyph freetype:uint) (freetype::kern_mode freetype:uint) (freetype::akerning (* freetype:vector))) (define-alien-routine ("FT_Get_Glyph_Name" freetype:get-glyph-name) freetype:error (freetype:face freetype:face) (freetype::glyph_index freetype:uint) (freetype:buffer freetype:pointer) (freetype::buffer_max freetype:uint)) (define-alien-routine ("FT_Get_Char_Index" freetype:get-char-index) freetype:uint (freetype:face freetype:face) (freetype::charcode freetype:ulong)) (define-alien-routine ("FT_MulDiv" freetype:mul-div) freetype:long (freetype::a freetype:long) (freetype::b freetype:long) (freetype::c freetype:long)) (define-alien-routine ("FT_MulFix" freetype:mul-fix) freetype:long (freetype::a freetype:long) (freetype::b freetype:long)) (define-alien-routine ("FT_DivFix" freetype:div-fix) freetype:long (freetype::a freetype:long) (freetype::b freetype:long)) (define-alien-routine ("FT_RoundFix" freetype:round-fix) freetype:fixed (freetype::a freetype:fixed)) (define-alien-routine ("FT_CeilFix" freetype:ceil-fix) freetype:fixed (freetype::a freetype:fixed)) (define-alien-routine ("FT_FloorFix" freetype:floor-fix) freetype:fixed (freetype::a freetype:fixed)) (define-alien-routine ("FT_Vector_Transform" freetype:vector-transform) :void (freetype::vec (* freetype:vector)) (freetype:matrix (* freetype:matrix))) (defcenum freetype:encoding (:ft-encoding-none #.(logior (logior (logior (ash #o0 24) (ash #o0 16)) (ash #o0 8)) #o0)) (:ft-encoding-symbol #.(logior (logior (logior (ash #.(char-code #\s) 24) (ash #.(char-code #\y) 16)) (ash #.(char-code #\m) 8)) #.(char-code #\b))) (:ft-encoding-unicode #.(logior (logior (logior (ash #.(char-code #\u) 24) (ash #.(char-code #\n) 16)) (ash #.(char-code #\i) 8)) #.(char-code #\c))) (:ft-encoding-latin-2 #.(logior (logior (logior (ash #.(char-code #\l) 24) (ash #.(char-code #\a) 16)) (ash #.(char-code #\t) 8)) #.(char-code #\2))) (:ft-encoding-sjis #.(logior (logior (logior (ash #.(char-code #\s) 24) (ash #.(char-code #\j) 16)) (ash #.(char-code #\i) 8)) #.(char-code #\s))) (:ft-encoding-gb2312 #.(logior (logior (logior (ash #.(char-code #\g) 24) (ash #.(char-code #\b) 16)) (ash #.(char-code #\ ) 8)) #.(char-code #\ ))) (:ft-encoding-big5 #.(logior (logior (logior (ash #.(char-code #\b) 24) (ash #.(char-code #\i) 16)) (ash #.(char-code #\g) 8)) #.(char-code #\5))) (:ft-encoding-wansung #.(logior (logior (logior (ash #.(char-code #\w) 24) (ash #.(char-code #\a) 16)) (ash #.(char-code #\n) 8)) #.(char-code #\s))) (:ft-encoding-johab #.(logior (logior (logior (ash #.(char-code #\j) 24) (ash #.(char-code #\o) 16)) (ash #.(char-code #\h) 8)) #.(char-code #\a))) (:ft-encoding-adobe-standard #.(logior (logior (logior (ash #.(char-code #\A) 24) (ash #.(char-code #\D) 16)) (ash #.(char-code #\O) 8)) #.(char-code #\B))) (:ft-encoding-adobe-expert #.(logior (logior (logior (ash #.(char-code #\A) 24) (ash #.(char-code #\D) 16)) (ash #.(char-code #\B) 8)) #.(char-code #\E))) (:ft-encoding-adobe-custom #.(logior (logior (logior (ash #.(char-code #\A) 24) (ash #.(char-code #\D) 16)) (ash #.(char-code #\B) 8)) #.(char-code #\C))) (:ft-encoding-apple-roman #.(logior (logior (logior (ash #.(char-code #\a) 24) (ash #.(char-code #\r) 16)) (ash #.(char-code #\m) 8)) #.(char-code #\n)))) #| (define-alien-type freetype:char-map-rec (struct freetype::char-map-rec- (freetype:face freetype:face) (freetype:encoding freetype:encoding) (freetype:platform-id freetype:ushort) (freetype:encoding-id freetype:ushort))) |# (define-alien-routine ("FT_Select_Charmap" freetype:select-charmap) freetype:error (freetype:face freetype:face) (freetype:encoding freetype:encoding)) (define-alien-routine ("FT_Set_Charmap" freetype:set-charmap) freetype:error (freetype:face freetype:face) (freetype:charmap freetype:char-map)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Experimental/freetype/freetype-fonts-cffi.lisp0000644000175000017500000001765611345155772026060 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: MCCLIM-TRUETYPE; -*- ;;; --------------------------------------------------------------------------- ;;; Title: Experimental FreeType support ;;; Created: 2003-05-25 16:32 ;;; Author: Gilbert Baumann ;;; License: LGPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2003 by Gilbert Baumann ;;; (c) copyright 2008 by Andy Hefner ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :mcclim-truetype) ;;; Can't unconditionally use this in the package definition.. #+NIL (eval-when (:compile-toplevel :load-toplevel :execute) (use-package :cffi)) ;;; reset safety up to 3 to try to work out some of my problems. If ;;; this gets fixed, presumably it should be dropped back down to ;;; 1... [2006/05/24:rpg] (declaim (optimize (speed 2) (safety 3) (debug 3) (space 3))) (defclass freetype-face (truetype-face) ((concrete-font :initarg :concrete-font :reader freetype-face-concrete-font))) (defun make-vague-font (filename) (let ((val (gethash filename *vague-font-hash*))) (or val (setf (gethash filename *vague-font-hash*) (make-instance 'vague-font :lib ;; I am not at all sure that this is the ;; right translation --- because of the ;; difference between SBCL aliens and ;; CFFI, I'm not sure what the deref was ;; intended to achieve... [2006/05/24:rpg] (let ((libf (cffi:foreign-alloc 'freetype:library))) (freetype:init-free-type libf) (cffi:mem-aref libf 'freetype:library)) :filename filename))))) (defparameter *concrete-font-hash* (make-hash-table :test #'equal)) (defun make-concrete-font (vague-font size &key (dpi *dpi*)) (with-slots (lib filename) vague-font (let* ((key (cons lib filename)) (val (gethash key *concrete-font-hash*))) (unless val (let ((facef ;; this will allocate a pointer (notionally to a ;; face-rec), and return a pointer to it (the pointer). (cffi:foreign-alloc 'freetype:face) ;;(make-alien freetype:face)) )) ;;(declare (type (alien (* freetype:face)) facef)) (if (zerop (freetype:new-face lib filename 0 facef)) (setf val (setf (gethash key *concrete-font-hash*) (cffi:mem-ref facef 'freetype:face))) ;;; (setf val (setf (gethash key *concrete-font-hash*) ;;; (deref facef))) (error "Freetype error in make-concrete-font")))) (let ((face val)) ;; (declare (type (alien freetype:face) face)) face)))) ;(declaim (inline make-concrete-font)) (defun set-concrete-font-size (face size dpi) ;(declare (type (alien freetype:face) face)) (freetype:set-char-size face 0 (round (* size 64)) (round dpi) (round dpi)) face) (defun glyph-pixarray (font char) ;;; (declare (optimize (speed 3) (debug 1)) ;;; (inline freetype:load-glyph freetype:render-glyph) ;;; (type (alien freetype:face) face)) (let ((face (freetype-face-concrete-font font))) (set-concrete-font-size face (truetype-face-size font) *dpi*) (freetype:load-glyph face (freetype:get-char-index face (char-code char)) 0) (freetype:render-glyph (cffi:foreign-slot-value face 'freetype:face-rec 'freetype:glyph) 0) (cffi:with-foreign-slots ((freetype:glyph) face freetype:face-rec) (cffi:with-foreign-slots ((freetype:bitmap) freetype:glyph freetype:glyph-slot-rec) (cffi:with-foreign-slots ((freetype:width freetype:pitch freetype:rows freetype:buffer) freetype:bitmap freetype:bitmap) (let ((res (make-array (list freetype:rows freetype:width) :element-type '(unsigned-byte 8)))) ;;; (let* ((width (slot bm 'freetype:width)) ;;; (pitch (slot bm 'freetype:pitch)) ;;; (height (slot bm 'freetype:rows)) ;;; (buffer (slot bm 'freetype:buffer)) ;;; (res (make-array (list height width) :element-type '(unsigned-byte 8)))) (declare (type (simple-array (unsigned-byte 8) (* *)) res)) (let ((m (* freetype:width freetype:rows))) (locally (declare (optimize (speed 3) (safety 0))) (loop for y*width of-type fixnum below m by freetype:width for y*pitch of-type fixnum from 0 by freetype:pitch do (loop for x of-type fixnum below freetype:width do (setf (row-major-aref res (+ x y*width)) (cffi:mem-aref freetype:buffer :uint8 (+ x y*pitch)) ;; (deref buffer (+ x y*pitch)) ))))) (cffi:with-foreign-slots ((freetype:bitmap-left freetype:bitmap-top freetype:advance) freetype:glyph freetype:glyph-slot-rec) (cffi:with-foreign-slots ((freetype:x freetype:y) freetype:advance freetype:vector) (values res freetype:bitmap-left freetype:bitmap-top (/ freetype:x 64) (/ freetype:y 64)))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun font-fixed-width-p (freetype-font) ;; Fixme! Translate this to CFFI-speak to get the fixed-width optimization: ;;(zerop (logand (slot (freetype-face-concrete-font freetype-font) ;; 'freetype:face-flags) 4))) ; FT_FACE_FLAG_FIXED_WIDTH nil) (defparameter *font-hash* (make-hash-table :test #'equalp)) (let ((cache (make-hash-table :test #'equal))) (defun make-truetype-face (display font size) (or (gethash (list display font size) cache) (setf (gethash (list display font size) cache) (let* ((f.font (or (gethash font *font-hash*) (setf (gethash font *font-hash*) (make-vague-font font)))) (f (make-concrete-font f.font size))) (set-concrete-font-size f size *dpi*) (cffi:with-foreign-slots ((freetype:size_s) f freetype:face-rec) (cffi:with-foreign-slots ((freetype:metrics) freetype:size_s freetype:size-rec) (cffi:with-foreign-slots ((freetype:ascender freetype:descender) freetype:metrics freetype:size-metrics) (make-instance 'freetype-face :display display :filename font :size size :concrete-font f :ascent (/ freetype:ascender 64) :descent (/ freetype:descender -64)))))))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Experimental/freetype/mcclim-freetype.asd0000644000175000017500000000503511345155772025052 0ustar pdmpdm;;;; -*- Lisp -*- #| Mcclim-freetype adds truetype font support to the CLX backend using libfreetype. To autoload mcclim-truetype after mcclim, link this file to a directory in your asdf:*central-registry* and add the following to your lisp's init file: (defmethod asdf:perform :after ((o asdf:load-op) (s (eql (asdf:find-system :clim-clx)))) (asdf:oos 'asdf:load-op :mcclim-freetype)) By default, the native 'Alien' FFI is used on CMUCL, SBCL, and SBCL, while CFFI is used on other lisps. To force the use of CFFI, load the :mcclim-freetype-cffi system instead. This shouldn't be necessary except for testing the CFFI code. |# (defpackage :mcclim-freetype-system (:use :cl :asdf)) (in-package :mcclim-freetype-system) (defclass uncompiled-cl-source-file (source-file) ()) (defmethod perform ((o compile-op) (f uncompiled-cl-source-file)) t) (defmethod perform ((o load-op) (f uncompiled-cl-source-file)) (mapcar #'load (input-files o f))) (defmethod output-files ((operation compile-op) (c uncompiled-cl-source-file)) nil) (defmethod input-files ((operation load-op) (c uncompiled-cl-source-file)) (list (component-pathname c))) (defmethod operation-done-p ((operation compile-op) (c uncompiled-cl-source-file)) t) (defmethod source-file-type ((c uncompiled-cl-source-file) (s module)) "lisp") (defsystem :mcclim-freetype :depends-on (:clim-clx :mcclim #-(or sbcl cmucl scl) :cffi) :serial t :components #+(or cmucl sbcl scl) ((:file "truetype-package") (:file "xrender-fonts") (:uncompiled-cl-source-file "freetype-ffi") (:file "freetype-fonts-alien") (:file "fontconfig")) #-(or cmucl sbcl scl) ((:file "truetype-package") (:file "xrender-fonts") (:file "freetype-package-cffi") (:uncompiled-cl-source-file "freetype-cffi") (:file "fontconfig") (:file "freetype-fonts-cffi"))) (defsystem :mcclim-freetype-cffi :depends-on (:clim-clx :mcclim :cffi) :serial t :components ((:file "truetype-package") (:file "xrender-fonts") (:file "freetype-package-cffi") (:uncompiled-cl-source-file "freetype-cffi") (:file "fontconfig") (:file "freetype-fonts-cffi"))) (defmethod perform :after ((o load-op) (s (eql (asdf:find-system :mcclim-freetype)))) "Detect fonts using fc-match" (funcall (find-symbol (symbol-name '#:autoconfigure-fonts) :mcclim-truetype))) (defmethod perform :after ((o load-op) (s (eql (asdf:find-system :mcclim-freetype-cffi)))) "Detect fonts using fc-match" (funcall (find-symbol (symbol-name '#:autoconfigure-fonts) :mcclim-truetype))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Experimental/freetype/freetype-ffi.lisp0000640000175000017500000007210610561555374024552 0ustar pdmpdm;;; automatically generated, hand tweaked, do not regenerate. (DEFPACKAGE :FREETYPE (:USE :cl #+sbcl :sb-alien #+(or cmu scl) :alien #+(or cmu scl) :c-call) (:EXPORT "MEMORY-BASE" "DESCENDER" "LINEAR-VERT-ADVANCE" "YX" "XX" "FREE" "AVAILABLE-SIZES" "COVERAGE" "METRICS" "RASTER-FLAG" "GLYPH" "GET-CHAR-INDEX" "LIMIT" "STRING" "SHIFT" "LEN" "UNDERLINE-POSITION" "RASTER-NEW-FUNC" "POINTS" "TAG" "SIZE-INTERNAL" "NUM-SUBGLYPHS" "UNITS-PER-EM" "LIBRARY" "ALLOC" "OPEN-FACE" "ATTACH-FILE" "BITMAP-TOP" "CURSOR" "BITMAP-LEFT" "MODULE" "PIXEL-MODE" "FREE-FUNC" "PITCH" "EXTENSIONS" "RASTER-RENDER-FUNC" "GET-KERNING" "UFWORD" "OPEN-ARGS" "RASTER-FUNCS" "INT32" "PREV" "LOAD-CHAR" "PATHNAME" "HORI-BEARING-Y" "RASTER-RENDER" "ENCODING" "OUTLINE-CONIC-TO-FUNC" "STREAM" "RASTER-RESET" "MOVE-TO" "GENERIC" "ATTACH-STREAM" "Y-MAX" "X-MAX" "FACE-INDEX" "SUBGLYPHS" "BITMAP" "BITMAP-SIZE" "ADVANCE" "MUL-FIX" "SET-PIXEL-SIZES" "OUTLINE-CUBIC-TO-FUNC" "FACE-INTERNAL" "WCHAR-T" "BLACK-SPANS" "TAGS" "N-CONTOURS" "YY" "XY" "CONIC-TO" "INT" "UNDERLINE-THICKNESS" "NUM-FACES" "Y-PPEM" "X-PPEM" "PLATFORM-ID" "ASCENDER" "DIV-FIX" "USHORT" "WINT-T" "CONTROL-LEN" "WIDTH" "NEW-FACE" "CHAR-MAP-REC" "Y-SCALE" "X-SCALE" "ALLOC-FUNC" "OUTLINE-FUNCS" "RASTER-DONE" "UINT16" "FINALIZER" "RENDER-GLYPH" "GLYPH-METRICS" "RASTER-SPAN-FUNC" "CONTOURS" "GLYPH-SLOT-REC" "VERT-BEARING-Y" "INIT-FREE-TYPE" "CLIP-BOX" "RASTER-RESET-FUNC" "FLAGS" "USER" "MEMORY-SIZE" "HEIGHT" "N-POINTS" "UINT" "VECTOR" "NEXT" "LIST" "MEMORY" "BUFFER" "MUL-DIV" "PARAMS" "GET-GLYPH-NAME" "PTRDIFF-T" "CHAR-MAP" "FWORD" "OUTLINE-MOVE-TO-FUNC" "STREAM-CLOSE" "SET-TRANSFORM" "FLOOR-FIX" "GLYPH-FORMAT" "GLYPH-SLOT" "KERNING-MODE" "INT16" "POS" "FAST" "CONTROL-DATA" "NUM-PARAMS" "STYLE-FLAGS" "CHARMAP" "OUTLINE-LINE-TO-FUNC" "SELECT-CHARMAP" "TARGET" "TAIL" "SLOT-INTERNAL" "OUTLINE-FLAGS" "RASTER-SET-MODE" "LIST-NODE" "NEW-MEMORY-FACE" "SIZE-REC" "RASTER-DONE-FUNC" "HORI-ADVANCE" "RASTER" "REALLOC-FUNC" "READ" "ROUND-FIX" "LIST-REC" "UINT32" "ULONG" "HEAD" "DRIVER" "MAX-ADVANCE-HEIGHT" "SIZE-T" "Y-MIN" "X-MIN" "RASTER-SET-MODE-FUNC" "SIZE-METRICS" "ROWS" "OUTLINE" "Y" "X" "ENCODING-ID" "FORMAT" "REALLOC" "INTERNAL" "SIZES-LIST" "MAX-ADVANCE-WIDTH" "DONE-FACE" "SIZE" "SUB-GLYPH" "BBOX" "POINTER" "DELTA" "CEIL-FIX" "PARAMETER" "OFFSET" "MATRIX" "FACE-REC" "GRAY-SPANS" "PALETTE-MODE" "NUM-FIXED-SIZES" "BYTE" "SPAN" "VECTOR-TRANSFORM" "NUM-GRAYS" "RASTER-BIT-SET-FUNC" "RENDERER" "VALUE" "BIT-TEST" "SOURCE" "STYLE-NAME" "LINE-TO" "STREAM-DESC" "LONG" "UNIT-VECTOR" "LIST-NODE-REC" "HORI-BEARING-X" "VERT-ADVANCE" "CUBIC-TO" "GENERIC-FINALIZER" "CHAR" "PTR-DIST" "UFAST" "DESCRIPTOR" "SET-CHAR-SIZE" "LINEAR-HORI-ADVANCE" "MAX-ADVANCE" "AUTOHINT" "FIXED" "OPEN-FLAGS" "BASE" "ERROR" "NUM-GLYPHS" "DATA" "RENDER-MODE" "CHARMAPS" "FACE" "F26DOT6" "OTHER" "RASTER-PARAMS" "SET-CHARMAP" "NUM-CHARMAPS" "LOAD-GLYPH" "RASTER-BIT-TEST-FUNC" "RASTER-NEW" "FAMILY-NAME" "DONE-FREE-TYPE" "BIT-SET" "VERT-BEARING-X" "F2DOT14" "CLOSE" "STREAM-IO" "FACE-FLAGS" "BOOL" "SHORT" "PALETTE" "C" "PALETTE-MODE-" "SIZE-REC-" "B" "A" "RENDER_MODE" "RIGHT_GLYPH" "SIZE-INTERNAL-REC-" "CHAR-MAP-REC-" "RASTER-FUNCS-" "SUB-GLYPH-" "SLOT-INTERNAL-REC-" "OUTLINE-" "RENDER-MODE-" "GLYPH-METRICS-" "PARAMETER-" "LOAD_FLAGS" "MATRIX-" "ARGS" "GLYPH_INDEX" "OUTLINE-FLAGS-" "MEMORY-REC-" "PIXEL_WIDTH" "VEC" "HORZ_RESOLUTION" "LIST-REC-" "STREAM-REC-" "BUFFER_MAX" "LIBRARY-REC-" "SPAN-" "GLYPH-SLOT-REC-" "VERT_RESOLUTION" "LEFT_GLYPH" "PIXEL-MODE-" "AFACE" "MODULE-REC-" "PIXEL_HEIGHT" "CHARCODE" "AKERNING" "ALIBRARY" "LIST-NODE-REC-" "KERNING-MODE-" "FACE-REC-" "BITMAP-SIZE-" "DRIVER-REC-" "FILE_SIZE" "STREAM-DESC-" "FACE-INTERNAL-REC-" "FILEPATHNAME" "UNIT-VECTOR-" "PARAMETERS" "RASTER-PARAMS-" "OUTLINE-FUNCS-" "CHAR_HEIGHT" "BITMAP-" "FILE_BASE" "KERN_MODE" "CHAR_CODE" "RENDERER-REC-" "RASTER-REC-" "VECTOR-" "SIZE-METRICS-" "CHAR_WIDTH" "GENERIC-" "ENCODING-" "FACE_INDEX" "SLOT" "GLYPH-FORMAT-" "OPEN-ARGS-" "BBOX-" "SIZE_S")) (in-package :freetype) #+cmu (alien:load-foreign "/usr/lib/libfreetype.so.6") #+scl (alien:load-dynamic-object #+64bit "/usr/lib64/libfreetype.so.6" #-64bit "/usr/lib/libfreetype.so.6") #+(or scl cmu) (defmacro define-alien-type (&rest rest) `(def-alien-type ,@rest)) #+(or scl cmu) (defmacro define-alien-routine (&rest rest) `(def-alien-routine ,@rest)) #+sbcl (load-shared-object #+darwin "/usr/X11R6/lib/libfreetype.6.dylib" #-darwin "libfreetype.so.6") (declaim (optimize (speed 3))) (define-alien-type freetype:memory (* (struct freetype::memory-rec-))) (define-alien-type freetype:stream (* (struct freetype::stream-rec-))) (define-alien-type freetype:raster (* (struct freetype::raster-rec-))) (define-alien-type freetype:list-node (* (struct freetype::list-node-rec-))) (define-alien-type freetype:list (* (struct freetype::list-rec-))) (define-alien-type freetype:library (* (struct freetype::library-rec-))) (define-alien-type freetype:module (* (struct freetype::module-rec-))) (define-alien-type freetype:driver (* (struct freetype::driver-rec-))) (define-alien-type freetype:renderer (* (struct freetype::renderer-rec-))) (define-alien-type freetype:char-map (* (struct freetype::char-map-rec-))) (define-alien-type freetype:face-internal (* (struct freetype::face-internal-rec-))) (define-alien-type freetype:slot-internal (* (struct freetype::slot-internal-rec-))) (define-alien-type freetype:size-internal (* (struct freetype::size-internal-rec-))) (define-alien-type freetype:int16 (signed 16)) (define-alien-type freetype:uint16 (unsigned 16)) (define-alien-type freetype:int32 (signed 32)) (define-alien-type freetype:uint32 (unsigned 32)) (define-alien-type freetype:fast (signed 32)) (define-alien-type freetype:ufast (unsigned 32)) (define-alien-type freetype:ptrdiff-t (signed 32)) (define-alien-type freetype:size-t (unsigned 32)) (define-alien-type freetype:wchar-t (signed 32)) (define-alien-type freetype:wint-t (unsigned 32)) (define-alien-type freetype:bool (unsigned 8)) (define-alien-type freetype:fword (signed 16)) (define-alien-type freetype:ufword (unsigned 16)) (define-alien-type freetype:char (signed 8)) (define-alien-type freetype:byte (unsigned 8)) (define-alien-type freetype:string (signed 8)) (define-alien-type freetype:short (signed 16)) (define-alien-type freetype:ushort (unsigned 16)) (define-alien-type freetype:int (signed 32)) (define-alien-type freetype:uint (unsigned 32)) (define-alien-type freetype:long long) (define-alien-type freetype:ulong unsigned-long) (define-alien-type freetype:f2dot14 (signed 16)) (define-alien-type freetype:f26dot6 long) (define-alien-type freetype:fixed long) (define-alien-type freetype:error (signed 32)) (define-alien-type freetype:pointer (* t)) (define-alien-type freetype:offset freetype:size-t) (define-alien-type freetype:ptr-dist freetype:size-t) (define-alien-type nil (enum nil (:mod-err-base #.#x000) (:mod-err-autohint #.#x100) (:mod-err-cache #.#x200) (:mod-err-cff #.#x300) (:mod-err-cid #.#x400) (:mod-err-pcf #.#x500) (:mod-err-psaux #.#x600) (:mod-err-psnames #.#x700) (:mod-err-raster #.#x800) (:mod-err-sfnt #.#x900) (:mod-err-smooth #.#xA00) (:mod-err-true-type #.#xB00) (:mod-err-type1 #.#xC00) (:mod-err-winfonts #.#xD00) :mod-err-max)) (define-alien-type nil (enum nil (:err-ok #.#x00) (:err-cannot-open-resource #.(+ #x01 0)) (:err-unknown-file-format #.(+ #x02 0)) (:err-invalid-file-format #.(+ #x03 0)) (:err-invalid-version #.(+ #x04 0)) (:err-lower-module-version #.(+ #x05 0)) (:err-invalid-argument #.(+ #x06 0)) (:err-unimplemented-feature #.(+ #x07 0)) (:err-invalid-glyph-index #.(+ #x10 0)) (:err-invalid-character-code #.(+ #x11 0)) (:err-invalid-glyph-format #.(+ #x12 0)) (:err-cannot-render-glyph #.(+ #x13 0)) (:err-invalid-outline #.(+ #x14 0)) (:err-invalid-composite #.(+ #x15 0)) (:err-too-many-hints #.(+ #x16 0)) (:err-invalid-pixel-size #.(+ #x17 0)) (:err-invalid-handle #.(+ #x20 0)) (:err-invalid-library-handle #.(+ #x21 0)) (:err-invalid-driver-handle #.(+ #x22 0)) (:err-invalid-face-handle #.(+ #x23 0)) (:err-invalid-size-handle #.(+ #x24 0)) (:err-invalid-slot-handle #.(+ #x25 0)) (:err-invalid-char-map-handle #.(+ #x26 0)) (:err-invalid-cache-handle #.(+ #x27 0)) (:err-invalid-stream-handle #.(+ #x28 0)) (:err-too-many-drivers #.(+ #x30 0)) (:err-too-many-extensions #.(+ #x31 0)) (:err-out-of-memory #.(+ #x40 0)) (:err-unlisted-object #.(+ #x41 0)) (:err-cannot-open-stream #.(+ #x51 0)) (:err-invalid-stream-seek #.(+ #x52 0)) (:err-invalid-stream-skip #.(+ #x53 0)) (:err-invalid-stream-read #.(+ #x54 0)) (:err-invalid-stream-operation #.(+ #x55 0)) (:err-invalid-frame-operation #.(+ #x56 0)) (:err-nested-frame-access #.(+ #x57 0)) (:err-invalid-frame-read #.(+ #x58 0)) (:err-raster-uninitialized #.(+ #x60 0)) (:err-raster-corrupted #.(+ #x61 0)) (:err-raster-overflow #.(+ #x62 0)) (:err-raster-negative-height #.(+ #x63 0)) (:err-too-many-caches #.(+ #x70 0)) (:err-invalid-opcode #.(+ #x80 0)) (:err-too-few-arguments #.(+ #x81 0)) (:err-stack-overflow #.(+ #x82 0)) (:err-code-overflow #.(+ #x83 0)) (:err-bad-argument #.(+ #x84 0)) (:err-divide-by-zero #.(+ #x85 0)) (:err-invalid-reference #.(+ #x86 0)) (:err-debug-op-code #.(+ #x87 0)) (:err-endf-in-exec-stream #.(+ #x88 0)) (:err-nested-defs #.(+ #x89 0)) (:err-invalid-code-range #.(+ #x8A 0)) (:err-execution-too-long #.(+ #x8B 0)) (:err-too-many-function-defs #.(+ #x8C 0)) (:err-too-many-instruction-defs #.(+ #x8D 0)) (:err-table-missing #.(+ #x8E 0)) (:err-horiz-header-missing #.(+ #x8F 0)) (:err-locations-missing #.(+ #x90 0)) (:err-name-table-missing #.(+ #x91 0)) (:err-cmap-table-missing #.(+ #x92 0)) (:err-hmtx-table-missing #.(+ #x93 0)) (:err-post-table-missing #.(+ #x94 0)) (:err-invalid-horiz-metrics #.(+ #x95 0)) (:err-invalid-char-map-format #.(+ #x96 0)) (:err-invalid-ppem #.(+ #x97 0)) (:err-invalid-vert-metrics #.(+ #x98 0)) (:err-could-not-find-context #.(+ #x99 0)) (:err-invalid-post-table-format #.(+ #x9A 0)) (:err-invalid-post-table #.(+ #x9B 0)) (:err-syntax-error #.(+ #xA0 0)) (:err-stack-underflow #.(+ #xA1 0)) :err-max)) (define-alien-type freetype:alloc-func (* t)) (define-alien-type freetype:free-func (* t)) (define-alien-type freetype:realloc-func (* t)) (define-alien-type nil (struct freetype::memory-rec- (freetype:user (* t)) (freetype:alloc freetype:alloc-func) (freetype:free freetype:free-func) (freetype:realloc freetype:realloc-func))) (define-alien-type freetype:stream-desc (union freetype::stream-desc- (freetype:value long) (freetype:pointer (* t)))) (define-alien-type freetype:stream-io (* t)) (define-alien-type freetype:stream-close (* t)) (define-alien-type nil (struct freetype::stream-rec- (freetype:base (* (unsigned 8))) (freetype:size freetype:ulong) (freetype:pos freetype:ulong) (freetype:descriptor freetype:stream-desc) (freetype:pathname freetype:stream-desc) (freetype:read freetype:stream-io) (freetype:close freetype:stream-close) (freetype:memory freetype:memory) (freetype:cursor (* (unsigned 8))) (freetype:limit (* (unsigned 8))))) (define-alien-type freetype:pos long) (define-alien-type freetype:vector (struct freetype::vector- (freetype:x freetype:pos) (freetype:y freetype:pos))) (define-alien-type freetype:bbox (struct freetype::bbox- (freetype:x-min freetype:pos) (freetype:y-min freetype:pos) (freetype:x-max freetype:pos) (freetype:y-max freetype:pos))) (define-alien-type freetype:pixel-mode (enum freetype::pixel-mode- (:ft-pixel-mode-none #.#o0) :ft-pixel-mode-mono :ft-pixel-mode-grays :ft-pixel-mode-pal2 :ft-pixel-mode-pal4 :ft-pixel-mode-pal8 :ft-pixel-mode-rgb15 :ft-pixel-mode-rgb16 :ft-pixel-mode-rgb24 :ft-pixel-mode-rgb32 :ft-pixel-mode-max)) (define-alien-type freetype:palette-mode (enum freetype::palette-mode- (:ft-palette-mode-rgb #.#o0) :ft-palette-mode-rgba :ft-palettte-mode-max)) (define-alien-type freetype:bitmap (struct freetype::bitmap- (freetype:rows (signed 32)) (freetype:width (signed 32)) (freetype:pitch (signed 32)) (freetype:buffer (* (unsigned 8))) (freetype:num-grays (signed 16)) (freetype:pixel-mode (signed 8)) (freetype:palette-mode (signed 8)) (freetype:palette (* t)))) (define-alien-type freetype:outline (struct freetype::outline- (freetype:n-contours (signed 16)) (freetype:n-points (signed 16)) (freetype:points (* freetype:vector)) (freetype:tags (* (signed 8))) (freetype:contours (* (signed 16))) (freetype:flags (signed 32)))) (define-alien-type freetype:outline-flags (enum freetype::outline-flags- (:ft-outline-none #.#o0) (:ft-outline-owner #.1) (:ft-outline-even-odd-fill #.2) (:ft-outline-reverse-fill #.4) (:ft-outline-ignore-dropouts #.8) (:ft-outline-high-precision #.256) (:ft-outline-single-pass #.512))) (define-alien-type freetype:outline-move-to-func (* t)) (define-alien-type freetype:outline-line-to-func (* t)) (define-alien-type freetype:outline-conic-to-func (* t)) (define-alien-type freetype:outline-cubic-to-func (* t)) (define-alien-type freetype:outline-funcs (struct freetype::outline-funcs- (freetype:move-to freetype:outline-move-to-func) (freetype:line-to freetype:outline-line-to-func) (freetype:conic-to freetype:outline-conic-to-func) (freetype:cubic-to freetype:outline-cubic-to-func) (freetype:shift (signed 32)) (freetype:delta freetype:pos))) (define-alien-type freetype:glyph-format (enum freetype::glyph-format- (:ft-glyph-format-none #.(logior (logior (logior (ash #o0 24) (ash #o0 16)) (ash #o0 8)) #o0)) (:ft-glyph-format-composite #.(logior (logior (logior (ash #.(char-code #\c) 24) (ash #.(char-code #\o) 16)) (ash #.(char-code #\m) 8)) #.(char-code #\p))) (:ft-glyph-format-bitmap #.(logior (logior (logior (ash #.(char-code #\b) 24) (ash #.(char-code #\i) 16)) (ash #.(char-code #\t) 8)) #.(char-code #\s))) (:ft-glyph-format-outline #.(logior (logior (logior (ash #.(char-code #\o) 24) (ash #.(char-code #\u) 16)) (ash #.(char-code #\t) 8)) #.(char-code #\l))) (:ft-glyph-format-plotter #.(logior (logior (logior (ash #.(char-code #\p) 24) (ash #.(char-code #\l) 16)) (ash #.(char-code #\o) 8)) #.(char-code #\t))))) (define-alien-type freetype:span (struct freetype::span- (freetype:x (signed 16)) (freetype:len (unsigned 16)) (freetype:coverage (unsigned 8)))) (define-alien-type freetype:raster-span-func (* t)) (define-alien-type freetype:raster-bit-test-func (* t)) (define-alien-type freetype:raster-bit-set-func (* t)) (define-alien-type freetype:raster-flag (enum nil (:ft-raster-flag-default #.#o0) (:ft-raster-flag-aa #.1) (:ft-raster-flag-direct #.2) (:ft-raster-flag-clip #.4))) (define-alien-type freetype:raster-params (struct freetype::raster-params- (freetype:target (* freetype:bitmap)) (freetype:source (* t)) (freetype:flags (signed 32)) (freetype:gray-spans freetype:raster-span-func) (freetype:black-spans freetype:raster-span-func) (freetype:bit-test freetype:raster-bit-test-func) (freetype:bit-set freetype:raster-bit-set-func) (freetype:user (* t)) (freetype:clip-box freetype:bbox))) (define-alien-type freetype:raster-new-func (* t)) (define-alien-type freetype:raster-done-func (* t)) (define-alien-type freetype:raster-reset-func (* t)) (define-alien-type freetype:raster-set-mode-func (* t)) (define-alien-type freetype:raster-render-func (* t)) (define-alien-type freetype:raster-funcs (struct freetype::raster-funcs- (freetype:glyph-format freetype:glyph-format) (freetype:raster-new freetype:raster-new-func) (freetype:raster-reset freetype:raster-reset-func) (freetype:raster-set-mode freetype:raster-set-mode-func) (freetype:raster-render freetype:raster-render-func) (freetype:raster-done freetype:raster-done-func))) (define-alien-type freetype:unit-vector (struct freetype::unit-vector- (freetype:x freetype:f2dot14) (freetype:y freetype:f2dot14))) (define-alien-type freetype:matrix (struct freetype::matrix- (freetype:xx freetype:fixed) (freetype:xy freetype:fixed) (freetype:yx freetype:fixed) (freetype:yy freetype:fixed))) (define-alien-type freetype:generic-finalizer (* t)) (define-alien-type freetype:generic (struct freetype::generic- (freetype:data (* t)) (freetype:finalizer freetype:generic-finalizer))) (define-alien-type freetype:list-node-rec (struct freetype::list-node-rec- (freetype:prev freetype:list-node) (freetype:next freetype:list-node) (freetype:data (* t)))) (define-alien-type freetype:list-rec (struct freetype::list-rec- (freetype:head freetype:list-node) (freetype:tail freetype:list-node))) (define-alien-type freetype:glyph-metrics (struct freetype::glyph-metrics- (freetype:width freetype:pos) (freetype:height freetype:pos) (freetype:hori-bearing-x freetype:pos) (freetype:hori-bearing-y freetype:pos) (freetype:hori-advance freetype:pos) (freetype:vert-bearing-x freetype:pos) (freetype:vert-bearing-y freetype:pos) (freetype:vert-advance freetype:pos))) (define-alien-type freetype:bitmap-size (struct freetype::bitmap-size- (freetype:height freetype:short) (freetype:width freetype:short))) (define-alien-type freetype:sub-glyph (struct freetype::sub-glyph-)) (define-alien-type freetype:glyph-slot-rec (struct freetype::glyph-slot-rec- (freetype:library freetype:library) (freetype:face (* (struct freetype::face-rec-))) (freetype:next (* (struct freetype::glyph-slot-rec-))) (freetype:flags freetype:uint) (freetype:generic freetype:generic) (freetype:metrics freetype:glyph-metrics) (freetype:linear-hori-advance freetype:fixed) (freetype:linear-vert-advance freetype:fixed) (freetype:advance freetype:vector) (freetype:format freetype:glyph-format) (freetype:bitmap freetype:bitmap) (freetype:bitmap-left freetype:int) (freetype:bitmap-top freetype:int) (freetype:outline freetype:outline) (freetype:num-subglyphs freetype:uint) (freetype:subglyphs (* freetype:sub-glyph)) (freetype:control-data (* t)) (freetype:control-len long) (freetype:other (* t)) (freetype:internal freetype:slot-internal))) (define-alien-type freetype:size-metrics (struct freetype::size-metrics- (freetype:x-ppem freetype:ushort) (freetype:y-ppem freetype:ushort) (freetype:x-scale freetype:fixed) (freetype:y-scale freetype:fixed) (freetype:ascender freetype:pos) (freetype:descender freetype:pos) (freetype:height freetype:pos) (freetype:max-advance freetype:pos))) (define-alien-type freetype:size-rec (struct freetype::size-rec- (freetype:face (* (struct freetype::face-rec-))) (freetype:generic freetype:generic) (freetype:metrics freetype:size-metrics) (freetype:internal freetype:size-internal))) (define-alien-type freetype:face-rec (struct freetype::face-rec- (freetype:num-faces freetype:long) (freetype:face-index freetype:long) (freetype:face-flags freetype:long) (freetype:style-flags freetype:long) (freetype:num-glyphs freetype:long) (freetype:family-name (* freetype:string)) (freetype:style-name (* freetype:string)) (freetype:num-fixed-sizes freetype:int) (freetype:available-sizes (* freetype:bitmap-size)) (freetype:num-charmaps freetype:int) (freetype:charmaps (* freetype:char-map)) (freetype:generic freetype:generic) (freetype:bbox freetype:bbox) (freetype:units-per-em freetype:ushort) (freetype:ascender freetype:short) (freetype:descender freetype:short) (freetype:height freetype:short) (freetype:max-advance-width freetype:short) (freetype:max-advance-height freetype:short) (freetype:underline-position freetype:short) (freetype:underline-thickness freetype:short) (freetype:glyph (* (struct freetype::glyph-slot-rec-))) (freetype:size_s (* (struct freetype:size-rec-))) (freetype:charmap freetype:char-map) (freetype:driver freetype:driver) (freetype:memory freetype:memory) (freetype:stream freetype:stream) (freetype:sizes-list freetype:list-rec) (freetype:autohint freetype:generic) (freetype:extensions (* t)) (freetype:internal freetype:face-internal))) (define-alien-type freetype:size-rec (struct freetype::size-rec- (freetype:face (* freetype:face-rec)) (freetype:generic freetype:generic) (freetype:metrics freetype:size-metrics) (freetype:internal freetype:size-internal))) (define-alien-type freetype:glyph-slot-rec (struct freetype::glyph-slot-rec- (freetype:library freetype:library) (freetype:face (* freetype:face-rec)) (freetype:next (* (struct freetype::glyph-slot-rec-))) (freetype:flags freetype:uint) (freetype:generic freetype:generic) (freetype:metrics freetype:glyph-metrics) (freetype:linear-hori-advance freetype:fixed) (freetype:linear-vert-advance freetype:fixed) (freetype:advance freetype:vector) (freetype:format freetype:glyph-format) (freetype:bitmap freetype:bitmap) (freetype:bitmap-left freetype:int) (freetype:bitmap-top freetype:int) (freetype:outline freetype:outline) (freetype:num-subglyphs freetype:uint) (freetype:subglyphs (* freetype:sub-glyph)) (freetype:control-data (* t)) (freetype:control-len long) (freetype:other (* t)) (freetype:internal freetype:slot-internal))) (define-alien-type freetype:glyph-slot (* freetype:glyph-slot-rec)) (define-alien-type freetype:face (* freetype:face-rec)) (define-alien-type freetype:size (* freetype:size-rec)) (define-alien-routine ("FT_Init_FreeType" freetype:init-free-type) freetype:error (freetype::alibrary (* freetype:library))) (define-alien-routine ("FT_Done_FreeType" freetype:done-free-type) freetype:error (freetype:library freetype:library)) (define-alien-type freetype:open-flags (enum nil (:ft-open-memory #.1) (:ft-open-stream #.2) (:ft-open-pathname #.4) (:ft-open-driver #.8) (:ft-open-params #.16))) (define-alien-type freetype:parameter (struct freetype::parameter- (freetype:tag freetype:ulong) (freetype:data freetype:pointer))) (define-alien-type freetype:open-args (struct freetype::open-args- (freetype:flags freetype:open-flags) (freetype:memory-base (* freetype:byte)) (freetype:memory-size freetype:long) (freetype:pathname (* freetype:string)) (freetype:stream freetype:stream) (freetype:driver freetype:module) (freetype:num-params freetype:int) (freetype:params (* freetype:parameter)))) (define-alien-routine ("FT_New_Face" freetype:new-face) freetype:error (freetype:library freetype:library) (freetype::filepathname #+(or cmu scl) c-call:c-string #+sbcl c-string) (freetype::face_index freetype:long) (freetype::aface (* (* freetype:face-rec)))) (define-alien-routine ("FT_New_Memory_Face" freetype:new-memory-face) freetype:error (freetype:library freetype:library) (freetype::file_base (* freetype:byte)) (freetype::file_size freetype:long) (freetype::face_index freetype:long) (freetype::aface (* freetype:face))) (define-alien-routine ("FT_Open_Face" freetype:open-face) freetype:error (freetype:library freetype:library) (freetype::args (* freetype:open-args)) (freetype::face_index freetype:long) (freetype::aface (* freetype:face))) (define-alien-routine ("FT_Attach_File" freetype:attach-file) freetype:error (freetype:face freetype:face) (freetype::filepathname (* (signed 8)))) (define-alien-routine ("FT_Attach_Stream" freetype:attach-stream) freetype:error (freetype:face freetype:face) (freetype::parameters (* freetype:open-args))) (define-alien-routine ("FT_Done_Face" freetype:done-face) freetype:error (freetype:face freetype:face)) (define-alien-routine ("FT_Set_Char_Size" freetype:set-char-size) freetype:error (freetype:face freetype:face) (freetype::char_width freetype:f26dot6) (freetype::char_height freetype:f26dot6) (freetype::horz_resolution freetype:uint) (freetype::vert_resolution freetype:uint)) (define-alien-routine ("FT_Set_Pixel_Sizes" freetype:set-pixel-sizes) freetype:error (freetype:face freetype:face) (freetype::pixel_width freetype:uint) (freetype::pixel_height freetype:uint)) (define-alien-routine ("FT_Load_Glyph" freetype:load-glyph) freetype:error (freetype:face freetype:face) (freetype::glyph_index freetype:uint) (freetype::load_flags freetype:int)) (define-alien-routine ("FT_Load_Char" freetype:load-char) freetype:error (freetype:face freetype:face) (freetype::char_code freetype:ulong) (freetype::load_flags freetype:int)) (define-alien-routine ("FT_Set_Transform" freetype:set-transform) #+(or cmu scl) c-call:void #+sbcl void (freetype:face freetype:face) (freetype:matrix (* freetype:matrix)) (freetype:delta (* freetype:vector))) (define-alien-type freetype:render-mode (enum freetype::render-mode- (:ft-render-mode-normal #.#o0) (:ft-render-mode-mono #.1))) (define-alien-routine ("FT_Render_Glyph" freetype:render-glyph) freetype:error (freetype::slot freetype:glyph-slot) (freetype::render_mode freetype:uint)) (define-alien-type freetype:kerning-mode (enum freetype::kerning-mode- (:ft-kerning-default #.#o0) :ft-kerning-unfitted :ft-kerning-unscaled)) (define-alien-routine ("FT_Get_Kerning" freetype:get-kerning) freetype:error (freetype:face freetype:face) (freetype::left_glyph freetype:uint) (freetype::right_glyph freetype:uint) (freetype::kern_mode freetype:uint) (freetype::akerning (* freetype:vector))) (define-alien-routine ("FT_Get_Glyph_Name" freetype:get-glyph-name) freetype:error (freetype:face freetype:face) (freetype::glyph_index freetype:uint) (freetype:buffer freetype:pointer) (freetype::buffer_max freetype:uint)) (define-alien-routine ("FT_Get_Char_Index" freetype:get-char-index) freetype:uint (freetype:face freetype:face) (freetype::charcode freetype:ulong)) (define-alien-routine ("FT_MulDiv" freetype:mul-div) freetype:long (freetype::a freetype:long) (freetype::b freetype:long) (freetype::c freetype:long)) (define-alien-routine ("FT_MulFix" freetype:mul-fix) freetype:long (freetype::a freetype:long) (freetype::b freetype:long)) (define-alien-routine ("FT_DivFix" freetype:div-fix) freetype:long (freetype::a freetype:long) (freetype::b freetype:long)) (define-alien-routine ("FT_RoundFix" freetype:round-fix) freetype:fixed (freetype::a freetype:fixed)) (define-alien-routine ("FT_CeilFix" freetype:ceil-fix) freetype:fixed (freetype::a freetype:fixed)) (define-alien-routine ("FT_FloorFix" freetype:floor-fix) freetype:fixed (freetype::a freetype:fixed)) (define-alien-routine ("FT_Vector_Transform" freetype:vector-transform) #+(or cmu scl) c-call:void #+sbcl void (freetype::vec (* freetype:vector)) (freetype:matrix (* freetype:matrix))) (define-alien-type freetype:encoding (enum freetype::encoding- (:ft-encoding-none #.(logior (logior (logior (ash #o0 24) (ash #o0 16)) (ash #o0 8)) #o0)) (:ft-encoding-symbol #.(logior (logior (logior (ash #.(char-code #\s) 24) (ash #.(char-code #\y) 16)) (ash #.(char-code #\m) 8)) #.(char-code #\b))) (:ft-encoding-unicode #.(logior (logior (logior (ash #.(char-code #\u) 24) (ash #.(char-code #\n) 16)) (ash #.(char-code #\i) 8)) #.(char-code #\c))) (:ft-encoding-latin-2 #.(logior (logior (logior (ash #.(char-code #\l) 24) (ash #.(char-code #\a) 16)) (ash #.(char-code #\t) 8)) #.(char-code #\2))) (:ft-encoding-sjis #.(logior (logior (logior (ash #.(char-code #\s) 24) (ash #.(char-code #\j) 16)) (ash #.(char-code #\i) 8)) #.(char-code #\s))) (:ft-encoding-gb2312 #.(logior (logior (logior (ash #.(char-code #\g) 24) (ash #.(char-code #\b) 16)) (ash #.(char-code #\ ) 8)) #.(char-code #\ ))) (:ft-encoding-big5 #.(logior (logior (logior (ash #.(char-code #\b) 24) (ash #.(char-code #\i) 16)) (ash #.(char-code #\g) 8)) #.(char-code #\5))) (:ft-encoding-wansung #.(logior (logior (logior (ash #.(char-code #\w) 24) (ash #.(char-code #\a) 16)) (ash #.(char-code #\n) 8)) #.(char-code #\s))) (:ft-encoding-johab #.(logior (logior (logior (ash #.(char-code #\j) 24) (ash #.(char-code #\o) 16)) (ash #.(char-code #\h) 8)) #.(char-code #\a))) (:ft-encoding-adobe-standard #.(logior (logior (logior (ash #.(char-code #\A) 24) (ash #.(char-code #\D) 16)) (ash #.(char-code #\O) 8)) #.(char-code #\B))) (:ft-encoding-adobe-expert #.(logior (logior (logior (ash #.(char-code #\A) 24) (ash #.(char-code #\D) 16)) (ash #.(char-code #\B) 8)) #.(char-code #\E))) (:ft-encoding-adobe-custom #.(logior (logior (logior (ash #.(char-code #\A) 24) (ash #.(char-code #\D) 16)) (ash #.(char-code #\B) 8)) #.(char-code #\C))) (:ft-encoding-apple-roman #.(logior (logior (logior (ash #.(char-code #\a) 24) (ash #.(char-code #\r) 16)) (ash #.(char-code #\m) 8)) #.(char-code #\n))))) #| (define-alien-type freetype:char-map-rec (struct freetype::char-map-rec- (freetype:face freetype:face) (freetype:encoding freetype:encoding) (freetype:platform-id freetype:ushort) (freetype:encoding-id freetype:ushort))) |# (define-alien-routine ("FT_Select_Charmap" freetype:select-charmap) freetype:error (freetype:face freetype:face) (freetype:encoding freetype:encoding)) (define-alien-routine ("FT_Set_Charmap" freetype:set-charmap) freetype:error (freetype:face freetype:face) (freetype:charmap freetype:char-map)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Experimental/freetype/fontconfig.lisp0000644000175000017500000000677310750306653024326 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: MCCLIM-FREETYPE; -*- ;;; --------------------------------------------------------------------------- ;;; Title: Experimental FreeType support ;;; Created: 2003-05-25 16:32 ;;; Author: Gilbert Baumann ;;; License: LGPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2008 by Andy Hefner ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Who originally wrote this? I want to put them in the file header. -Hefner (in-package :mcclim-truetype) (defparameter *family-names* '((:serif . "Serif") (:sans-serif . "Sans") (:fix . "Mono"))) (defparameter *fontconfig-faces* '((:roman . "") (:bold . "bold") (:italic . "oblique") ((:bold :italic) . "bold:oblique"))) (defun parse-fontconfig-output (s) (let* ((match-string (concatenate 'string (string #\Tab) "file:")) (matching-line (loop for l = (read-line s nil nil) while l if (= (mismatch l match-string) (length match-string)) do (return l))) (filename (when matching-line (probe-file (subseq matching-line (1+ (position #\" matching-line :from-end nil :test #'char=)) (position #\" matching-line :from-end t :test #'char=)))))) (when filename (parse-namestring filename)))) (defun warn-about-unset-font-path () (cerror "Proceed" "~%~%NOTE:~%~ * McCLIM was unable to configure itself automatically using fontconfig. Therefore you must configure it manually. Remember to set mcclim-freetype:*freetype-font-path* to the location of the Bitstream Vera family of fonts on disk. If you don't have them, get them from http://www.gnome.org/fonts/~%")) (defun find-fontconfig-font (font-fc-name) (with-input-from-string (s (with-output-to-string (asdf::*verbose-out*) (let ((code (asdf:run-shell-command "fc-match -v \"~A\"" font-fc-name))) (unless (zerop code) (warn "~&fc-match failed with code ~D.~%" code))))) (parse-fontconfig-output s))) (defun fontconfig-name (family face) (format nil "~A:~A" family face)) (defun build-font/family-map (&optional (families *family-names*)) (loop for family in families nconcing (loop for face in *fontconfig-faces* as filename = (find-fontconfig-font (fontconfig-name (cdr family) (cdr face))) when (null filename) do (return-from build-font/family-map nil) collect (cons (list (car family) (car face)) filename)))) (defun autoconfigure-fonts () (let ((map (build-font/family-map))) (if map (setf *families/faces* map) (warn-about-unset-font-path)))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Experimental/freetype/freetype-fonts-alien.lisp0000644000175000017500000001413510750306653026221 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: MCCLIM-TRUETYPE; -*- ;;; --------------------------------------------------------------------------- ;;; Title: Experimental FreeType support for CMUCL and SBCL ;;; Created: 2003-05-25 16:32 ;;; Author: Gilbert Baumann ;;; License: LGPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2003 by Gilbert Baumann ;;; (c) copyright 2008 by Andy Hefner ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :mcclim-truetype) (eval-when (:compile-toplevel :load-toplevel :execute) (import #+(or cmu scl) '(alien:slot alien:make-alien alien:alien alien:deref) #+sbcl '(sb-alien:slot sb-alien:make-alien sb-alien:alien sb-alien:deref))) (declaim (optimize (speed 1) (safety 3) (debug 1) (space 0))) (defclass freetype-face (truetype-face) ((concrete-font :initarg :concrete-font :reader freetype-face-concrete-font))) (defun make-vague-font (filename) (let ((val (gethash filename *vague-font-hash*))) (or val (setf (gethash filename *vague-font-hash*) (make-instance 'vague-font :lib (let ((libf (make-alien freetype:library))) (declare (type (alien (* freetype:library)) libf)) (freetype:init-free-type libf) (deref libf)) :filename filename))))) ;; A 'concrete' font is an instance of a 'vague' font at a particular text size. (defparameter *concrete-font-hash* (make-hash-table :test #'equal)) (defun make-concrete-font (vague-font size &key (dpi *dpi*)) (with-slots (lib filename) vague-font (let* ((key (cons lib filename)) (val (gethash key *concrete-font-hash*))) (unless val (let ((facef (make-alien freetype:face))) (declare (type (alien (* freetype:face)) facef)) (if (zerop (freetype:new-face lib filename 0 facef)) (setf val (setf (gethash key *concrete-font-hash*) (deref facef))) (error "Freetype error in make-concrete-font")))) val))) ;;; One "concrete font" is shared for a given face, regardless of text size. ;;; We call set-concrete-font-size to choose the current size before ;;; generating glyphs. (defun set-concrete-font-size (face size dpi) (declare (type (alien freetype:face) face)) (freetype:set-char-size face 0 (round (* size 64)) (round dpi) (round dpi)) face) (defun glyph-pixarray (font char) (declare (optimize (speed 3)) (inline freetype:load-glyph freetype:render-glyph)) (let ((face (the (alien freetype:face) (freetype-face-concrete-font font)))) (set-concrete-font-size face (truetype-face-size font) *dpi*) (freetype:load-glyph face (freetype:get-char-index face (char-code char)) 0) (freetype:render-glyph (slot face 'freetype:glyph) 0) (symbol-macrolet ((glyph (slot face 'freetype:glyph)) (bm (slot glyph 'freetype:bitmap))) (let* ((width (slot bm 'freetype:width)) (pitch (slot bm 'freetype:pitch)) (height (slot bm 'freetype:rows)) (buffer (slot bm 'freetype:buffer)) (res (make-array (list height width) :element-type '(unsigned-byte 8)))) (declare (type (simple-array (unsigned-byte 8) (* *)) res)) (let ((m (* width height))) (locally (declare (optimize (speed 3) (safety 0))) (loop for y*width of-type fixnum below m by width for y*pitch of-type fixnum from 0 by pitch do (loop for x of-type fixnum below width do (setf (row-major-aref res (+ x y*width)) (deref buffer (+ x y*pitch))))))) (values res (slot glyph 'freetype:bitmap-left) (slot glyph 'freetype:bitmap-top) (/ (slot (slot glyph 'freetype:advance) 'freetype:x) 64) (/ (slot (slot glyph 'freetype:advance) 'freetype:y) 64)))))) (defun font-fixed-width-p (freetype-font) (zerop (logand (slot (freetype-face-concrete-font freetype-font) 'freetype:face-flags) 4))) ; FT_FACE_FLAG_FIXED_WIDTH (defparameter *font-hash* (make-hash-table :test #'equalp)) (let ((cache (make-hash-table :test #'equal))) (defun make-truetype-face (display filename size) (or (gethash (list display filename size) cache) (setf (gethash (list display filename size) cache) (let* ((f.font (or (gethash filename *font-hash*) (setf (gethash filename *font-hash*) (make-vague-font filename)))) (f (make-concrete-font f.font size))) (declare (type (alien freetype:face) f)) (set-concrete-font-size f size *dpi*) (make-instance 'freetype-face :display display :filename filename :size size :concrete-font f :ascent (/ (slot (slot (slot f 'freetype:size_s) 'freetype:metrics) 'freetype:ascender) 64) :descent (/ (slot (slot (slot f 'freetype:size_s) 'freetype:metrics) 'freetype:descender) -64)))))))cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Experimental/freetype/truetype-package.lisp0000644000175000017500000000136310750306654025433 0ustar pdmpdm (cl:defpackage :mcclim-truetype (:use :climi :clim :clim-lisp) (:export :*truetype-font-path* :*family-names* :*fontconfig-faces* :truetype-device-font-name :fontconfig-font-name :make-truetype-device-font-name :make-fontconfig-font-name :truetype-face-filename :truetype-face-size :truetype-face-ascent :truetype-face-descent ) ;; Hmm. Replaced by import/use-package in freetype-fonts-alien ;; and freetype-fonts-cffi, so that I can load with either alien ;; or cffi on SBCL. ;;#+(or cmu scl sbcl) #+NIL (:import-from #+(or cmu scl) :alien #+sbcl :sb-alien :slot :make-alien :alien :deref)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Experimental/freetype/xrender-fonts.lisp0000644000175000017500000007362211331323431024752 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: MCCLIM-TRUETYPE; -*- ;;; --------------------------------------------------------------------------- ;;; Title: Font matrics, caching, and XRender text support ;;; Created: 2003-05-25 16:32 ;;; Author: Gilbert Baumann ;;; License: LGPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2003 by Gilbert Baumann ;;; (c) copyright 2008 by Andy Hefner ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :mcclim-truetype) (declaim (optimize (speed 1) (safety 3) (debug 1) (space 0))) (defparameter *dpi* 72) ;;;; Notes ;; You might need to tweak mcclim-truetype::*families/faces* to point ;; to where ever there are suitable TTF fonts on your system. ;; FIXME: I don't think draw-text* works for strings spanning multiple lines. ;; FIXME: Not particularly thread safe. ;; Some day, it might become useful to decouple the font representation ;; from the xrender details. (defclass vague-font () ((lib :initarg :lib) (filename :initarg :filename))) (defparameter *vague-font-hash* (make-hash-table :test #'equal)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((lookaside nil)) (defun display-the-glyph-set (display) (if (eq (car lookaside) display) (cdr lookaside) (let ((glyph-set (or (getf (xlib:display-plist display) 'the-glyph-set) (setf (getf (xlib:display-plist display) 'the-glyph-set) (xlib::render-create-glyph-set (first (xlib::find-matching-picture-formats display :alpha 8 :red 0 :green 0 :blue 0))))))) (setf lookaside (cons display glyph-set)) glyph-set)))) (defun display-free-glyph-ids (display) (getf (xlib:display-plist display) 'free-glyph-ids)) (defun (setf display-free-glyph-ids) (new-value display) (setf (getf (xlib:display-plist display) 'free-glyph-ids) new-value)) (defun display-free-glyph-id-counter (display) (getf (xlib:display-plist display) 'free-glyph-id-counter 0)) (defun (setf display-free-glyph-id-counter) (new-value display) (setf (getf (xlib:display-plist display) 'free-glyph-id-counter) new-value)) (defun display-draw-glyph-id (display) (or (pop (display-free-glyph-ids display)) (incf (display-free-glyph-id-counter display)))) (defstruct (glyph-info (:constructor glyph-info (id width height left right top))) id ; FIXME: Types? width height left right top) ;;;;;;; mcclim interface (defclass truetype-face () ((display :initarg :display :reader truetype-face-display) (filename :initarg :filename :reader truetype-face-filename) (size :initarg :size :reader truetype-face-size) (ascent :initarg :ascent :reader truetype-face-ascent) (descent :initarg :descent :reader truetype-face-descent) (fixed-width :initform nil) (glyph-id-cache :initform (make-gcache)) (glyph-width-cache :initform (make-gcache)) (char->glyph-info :initform (make-hash-table :size 256)))) (defun font-generate-glyph (font glyph-index) (let* ((display (truetype-face-display font)) (glyph-id (display-draw-glyph-id display))) (multiple-value-bind (arr left top dx dy) (glyph-pixarray font (code-char glyph-index)) (with-slots (fixed-width) font (when (and (numberp fixed-width) (/= fixed-width dx)) (setf fixed-width t) (#-hef warn #+hef cerror #+hef "Ignore it." "Font ~A is fixed width, but the glyph width appears to vary. Disabling fixed width optimization for this font. ~A vs ~A" font dx fixed-width)) (when (and (numberp fixed-width) (font-fixed-width-p font)) (setf fixed-width dx))) (when (= (array-dimension arr 0) 0) (setf arr (make-array (list 1 1) :element-type '(unsigned-byte 8) :initial-element 0))) (xlib::render-add-glyph (display-the-glyph-set display) glyph-id :data arr :x-origin (- left) :y-origin top :x-advance dx :y-advance dy) (let ((right (+ left (array-dimension arr 1)))) (glyph-info glyph-id dx dy left right top))))) (defmethod print-object ((object truetype-face) stream) (print-unreadable-object (object stream :type t :identity nil) (with-slots (filename size ascent descent) object (format stream "~A size=~A ~A/~A" filename size ascent descent)))) (defun font-glyph-info (font character) (with-slots (char->glyph-info) font (or (gethash character char->glyph-info) (setf (gethash character char->glyph-info) (font-generate-glyph font (char-code character)))))) (defun font-glyph-id (font character) (glyph-info-id (font-glyph-info font character))) (defmethod clim-clx::font-ascent ((font truetype-face)) (truetype-face-ascent font)) (defmethod clim-clx::font-descent ((font truetype-face)) (truetype-face-descent font)) (defmethod clim-clx::font-glyph-width ((font truetype-face) char) (glyph-info-width (font-glyph-info font char))) (defmethod clim-clx::font-glyph-left ((font truetype-face) char) (glyph-info-left (font-glyph-info font char))) (defmethod clim-clx::font-glyph-right ((font truetype-face) char) (glyph-info-right (font-glyph-info font char))) ;;; Simple custom cache for glyph IDs and widths. Much faster than ;;; using the char->glyph-info hash table directly. (defun make-gcache () (let ((array (make-array 512 :adjustable nil :fill-pointer nil))) (loop for i from 0 below 256 do (setf (aref array i) (1+ i))) array)) (declaim (inline gcache-get)) (defun gcache-get (cache key-number) (declare (optimize (speed 3)) (type (simple-array t (512)))) (let ((hash (logand (the fixnum key-number) #xFF))) ; hello. (and (= key-number (the fixnum (svref cache hash))) (svref cache (+ 256 hash))))) (defun gcache-set (cache key-number value) (let ((hash (logand key-number #xFF))) (setf (svref cache hash) key-number (svref cache (+ 256 hash)) value))) (defmethod clim-clx::font-text-extents ((font truetype-face) string &key (start 0) (end (length string)) translate) ;; -> (width ascent descent left right ;; font-ascent font-descent direction ;; first-not-done) (declare (optimize (speed 3)) (ignore translate)) (let ((width ;; We could work a little harder and eliminate generic arithmetic ;; here. It might shave a few percent off a draw-text benchmark. ;; Rather silly to obsess over the array access considering that. (macrolet ((compute () `(loop with width-cache = (slot-value font 'glyph-width-cache) for i from start below end as char = (aref string i) as code = (char-code char) sum (or (gcache-get width-cache code) (gcache-set width-cache code (clim-clx::font-glyph-width font char))) #+NIL (clim-clx::font-glyph-width font char)))) (if (numberp (slot-value font 'fixed-width)) (* (slot-value font 'fixed-width) (- end start)) (typecase string (simple-string (locally (declare (type simple-string string)) (compute))) (string (locally (declare (type string string)) (compute))) (t (compute))))))) (values width (clim-clx::font-ascent font) (clim-clx::font-descent font) (clim-clx::font-glyph-left font (char string start)) (- width (- (clim-clx::font-glyph-width font (char string (1- end))) (clim-clx::font-glyph-right font (char string (1- end))))) (clim-clx::font-ascent font) (clim-clx::font-descent font) 0 end))) (defun drawable-picture (drawable) (or (getf (xlib:drawable-plist drawable) 'picture) (setf (getf (xlib:drawable-plist drawable) 'picture) (xlib::render-create-picture drawable :format (xlib::find-window-picture-format (xlib:drawable-root drawable)))))) (defun gcontext-picture (drawable gcontext) (flet ((update-foreground (picture) ;; FIXME! This makes assumptions about pixel format, and breaks ;; on e.g. 16 bpp displays. ;; It would be better to store xrender-friendly color values in ;; medium-gcontext, at the same time we set the gcontext ;; foreground. That way we don't need to know the pixel format. (let ((fg (the xlib:card32 (xlib:gcontext-foreground gcontext)))) (xlib::render-fill-rectangle picture :src (list (ash (ldb (byte 8 16) fg) 8) (ash (ldb (byte 8 8) fg) 8) (ash (ldb (byte 8 0) fg) 8) #xFFFF) 0 0 1 1)))) (let* ((fg (xlib:gcontext-foreground gcontext)) (picture-info (or (getf (xlib:gcontext-plist gcontext) 'picture) (setf (getf (xlib:gcontext-plist gcontext) 'picture) (let* ((pixmap (xlib:create-pixmap :drawable drawable :depth (xlib:drawable-depth drawable) :width 1 :height 1)) (picture (xlib::render-create-picture pixmap :format (xlib::find-window-picture-format (xlib:drawable-root drawable)) :repeat :on))) (update-foreground picture) (list fg picture pixmap)))))) (unless (eql fg (first picture-info)) (update-foreground (second picture-info)) (setf (first picture-info) fg)) (cdr picture-info)))) ;;; Arbitrary restriction: No more than 65536 glyphs cached on a ;;; single display. I don't think that's unreasonable. Extending ;;; this from 16 to 32 bits is straightforward, at a slight loss ;;; in performance. (let ((buffer (make-array 1024 :element-type '(unsigned-byte 16) ; TODO: thread safety :adjustable nil :fill-pointer nil))) (defun clim-clx::font-draw-glyphs (font #|(font truetype-face)|# mirror gc x y string #|x0 y0 x1 y1|# &key start end translate) (declare (optimize (speed 3)) (type #-sbcl (integer 0 #.array-dimension-limit) #+sbcl sb-int:index start end) (type string string)) (when (< (length buffer) (- end start)) (setf buffer (make-array (* 256 (ceiling (- end start) 256)) :element-type '(unsigned-byte 16) :adjustable nil :fill-pointer nil))) (let ((display (xlib:drawable-display mirror))) (destructuring-bind (source-picture source-pixmap) (gcontext-picture mirror gc) (let* ((cache (slot-value font 'glyph-id-cache)) (glyph-ids buffer)) (loop for i from start below end ; TODO: Read optimization notes. Fix. Repeat. for i* upfrom 0 as char = (aref string i) as code = (char-code char) do (setf (aref buffer i*) (the (unsigned-byte 16) (or (gcache-get cache code) (gcache-set cache code (font-glyph-id font char)))))) ;; Debugging - show the text rectangle ;(setf (xlib:gcontext-foreground gc) #xFF0000) ;(xlib:draw-rectangle mirror gc x0 y0 (- x1 x0) (- y1 y0)) ;; Sync the picture-clip-mask with that of the gcontext. (unless (eq (xlib::picture-clip-mask (drawable-picture mirror)) (xlib::gcontext-clip-mask gc)) (setf (xlib::picture-clip-mask (drawable-picture mirror)) (xlib::gcontext-clip-mask gc))) (xlib::render-composite-glyphs (drawable-picture mirror) (display-the-glyph-set display) source-picture x y glyph-ids :end (- end start))))))) (defparameter *sizes* '(:normal 12 :small 10 :very-small 8 :tiny 8 :large 14 :very-large 18 :huge 24)) (defparameter *vera-families/faces* '(((:fix :roman) . "VeraMono.ttf") ((:fix :italic) . "VeraMoIt.ttf") ((:fix (:bold :italic)) . "VeraMoBI.ttf") ((:fix (:italic :bold)) . "VeraMoBI.ttf") ((:fix :bold) . "VeraMoBd.ttf") ((:serif :roman) . "VeraSe.ttf") ((:serif :italic) . "VeraSe.ttf") ((:serif (:bold :italic)) . "VeraSeBd.ttf") ((:serif (:italic :bold)) . "VeraSeBd.ttf") ((:serif :bold) . "VeraSeBd.ttf") ((:sans-serif :roman) . "Vera.ttf") ((:sans-serif :italic) . "VeraIt.ttf") ((:sans-serif (:bold :italic)) . "VeraBI.ttf") ((:sans-serif (:italic :bold)) . "VeraBI.ttf") ((:sans-serif :bold) . "VeraBd.ttf"))) ;;; Here are alternate mappings for the DejaVu family of fonts, which ;;; are a derivative of Vera with improved unicode coverage. (defparameter *dejavu-families/faces* '(((:FIX :ROMAN) . "DejaVuSansMono.ttf") ((:FIX :ITALIC) . "DejaVuSansMono-Oblique.ttf") ((:FIX (:BOLD :ITALIC)) . "DejaVuSansMono-BoldOblique.ttf") ((:FIX (:ITALIC :BOLD)) . "DejaVuSansMono-BoldOblique.ttf") ((:FIX :BOLD) . "DejaVuSansMono-Bold.ttf") ((:SERIF :ROMAN) . "DejaVuSerif.ttf") ((:SERIF :ITALIC) . "DejaVuSerif-Italic.ttf") ((:SERIF (:BOLD :ITALIC)) . "DejaVuSerif-BoldOblique.ttf") ((:SERIF (:ITALIC :BOLD)) . "DejaVuSerif-BoldOblique.ttf") ((:SERIF :BOLD) . "DejaVuSerif-Bold.ttf") ((:SANS-SERIF :ROMAN) . "DejaVuSans.ttf") ((:SANS-SERIF :ITALIC) . "DejaVuSans-Oblique.ttf") ((:SANS-SERIF (:BOLD :ITALIC)) . "DejaVuSans-BoldOblique.ttf") ((:SANS-SERIF (:ITALIC :BOLD)) . "DejaVuSans-BoldOblique.ttf") ((:SANS-SERIF :BOLD) . "DejaVuSans-Bold.ttf"))) (defparameter *families/faces* *dejavu-families/faces*) (defparameter *truetype-font-path* #p"/usr/share/fonts/truetype/ttf-dejavu/") (fmakunbound 'clim-clx::text-style-to-x-font) (defstruct truetype-device-font-name (font-file (error "missing argument")) (size (error "missing argument"))) (defstruct fontconfig-font-name (string (error "missing argument")) (size (error "missing argument")) (options nil) (device-name nil)) (defmethod clim-clx::text-style-to-X-font :around ((port clim-clx::clx-port) (text-style climi::device-font-text-style)) (let ((display (slot-value port 'clim-clx::display)) (font-name (climi::device-font-name text-style))) (typecase font-name (truetype-device-font-name (make-truetype-face display (namestring (truetype-device-font-name-font-file font-name)) (truetype-device-font-name-size font-name))) (fontconfig-font-name (clim-clx::text-style-to-X-font port (or (fontconfig-font-name-device-name font-name) (setf (fontconfig-font-name-device-name font-name) (make-device-font-text-style port (make-truetype-device-font-name :font-file (find-fontconfig-font (format nil "~A-~A~{:~A~}" (namestring (fontconfig-font-name-string font-name)) (fontconfig-font-name-size font-name) (fontconfig-font-name-options font-name))) :size (fontconfig-font-name-size font-name)))))))))) (defmethod text-style-mapping :around ((port clim-clx::clx-port) (text-style climi::device-font-text-style) &optional character-set) (values (gethash text-style (clim-clx::port-text-style-mappings port)))) (defmethod (setf text-style-mapping) :around (value (port clim-clx::clx-port) (text-style climi::device-font-text-style) &optional character-set) (setf (gethash text-style (clim-clx::port-text-style-mappings port)) value)) (defparameter *display-face-hash* (make-hash-table :test #'equal)) (define-condition missing-font (simple-error) ((filename :reader missing-font-filename :initarg :filename)) (:report (lambda (condition stream) (format stream "Cannot access ~W~%Your *truetype-font-path* is currently ~W~%The following files should exist:~&~{ ~A~^~%~}" (missing-font-filename condition) *truetype-font-path* (mapcar #'cdr *families/faces*))))) (defun invoke-with-truetype-path-restart (continuation) (restart-case (funcall continuation) (change-font-path (new-path) :report (lambda (stream) (format stream "Retry with alternate truetype font path")) :interactive (lambda () (format t "Enter new value: ") (list (read-line))) (setf *truetype-font-path* new-path) (invoke-with-truetype-path-restart continuation)))) (let (lookaside) (defmethod clim-clx::text-style-to-X-font :around ((port clim-clx::clx-port) (text-style standard-text-style)) (flet ((f () (multiple-value-bind (family face size) (clim:text-style-components text-style) (let ((display (clim-clx::clx-port-display port))) (setf face (or face :roman)) (setf family (or family :fix)) (setf size (or size :normal)) (when (eq family :fixed) (setf family :fix)) (cond (size (setf size (getf *sizes* size size)) (let ((val (gethash (list display family face size) *display-face-hash*))) (if val val (setf (gethash (list display family face size) *display-face-hash*) (let* ((font-path-relative (cdr (assoc (list family face) *families/faces* :test #'equal))) (font-path (namestring (merge-pathnames font-path-relative *truetype-font-path*)))) (unless (and font-path (probe-file font-path)) (error 'missing-font :filename font-path)) (make-truetype-face display font-path size)))))) (t (call-next-method))))))) (cdr (if (eq (car lookaside) text-style) lookaside (setf lookaside (cons text-style (invoke-with-truetype-path-restart #'f)))))))) (defmethod clim-clx::text-style-to-X-font ((port clim-clx::clx-port) text-style) (error "You lost: ~S." text-style)) ;;;;;; (in-package :clim-clx) (defmethod text-style-ascent (text-style (medium clx-medium)) (let ((font (text-style-to-X-font (port medium) text-style))) (clim-clx::font-ascent font))) (defmethod text-style-descent (text-style (medium clx-medium)) (let ((font (text-style-to-X-font (port medium) text-style))) (clim-clx::font-descent font))) (defmethod text-style-height (text-style (medium clx-medium)) (let ((font (text-style-to-X-font (port medium) text-style))) (+ (clim-clx::font-ascent font) (clim-clx::font-descent font)))) (defmethod text-style-character-width (text-style (medium clx-medium) char) (clim-clx::font-glyph-width (text-style-to-X-font (port medium) text-style) char)) (defmethod text-style-width (text-style (medium clx-medium)) (text-style-character-width text-style medium #\m)) (defmethod text-size ((medium clx-medium) string &key text-style (start 0) end) (declare (optimize (speed 3))) (when (characterp string) (setf string (make-string 1 :initial-element string))) (check-type string string) (unless end (setf end (length string))) (check-type start #-sbcl (integer 0 #.array-dimension-limit) #+sbcl sb-int:index) (check-type end #-sbcl (integer 0 #.array-dimension-limit) #+sbcl sb-int:index) (unless text-style (setf text-style (medium-text-style medium))) (let ((xfont (text-style-to-X-font (port medium) text-style))) (cond ((= start end) (values 0 0 0 0 0)) (t (let ((position-newline (macrolet ((p (type) `(locally (declare (type ,type string)) (position #\newline string :start start)))) (typecase string (simple-base-string (p simple-base-string)) #+SBCL (sb-kernel::simple-character-string (p sb-kernel::simple-character-string)) #+SBCL (sb-kernel::character-string (p sb-kernel::character-string)) (simple-string (p simple-string)) (string (p string)))))) (cond ((not (null position-newline)) (multiple-value-bind (width ascent descent left right font-ascent font-descent direction first-not-done) (font-text-extents xfont string :start start :end position-newline :translate #'translate) (declare (ignorable left right font-ascent font-descent direction first-not-done)) (multiple-value-bind (w h x y baseline) (text-size medium string :text-style text-style :start (1+ position-newline) :end end) (values (max w width) (+ ascent descent h) x (+ ascent descent y) (+ ascent descent baseline))))) (t (multiple-value-bind (width ascent descent left right font-ascent font-descent direction first-not-done) (font-text-extents xfont string :start start :end end :translate #'translate) (declare (ignorable left right font-ascent font-descent direction first-not-done)) (values width (+ ascent descent) width 0 ascent)) )))))) ) (defmethod climi::text-bounding-rectangle* ((medium clx-medium) string &key text-style (start 0) end) (when (characterp string) (setf string (make-string 1 :initial-element string))) (unless end (setf end (length string))) (unless text-style (setf text-style (medium-text-style medium))) (let ((xfont (text-style-to-X-font (port medium) text-style))) (cond ((= start end) (values 0 0 0 0)) (t (let ((position-newline (position #\newline string :start start))) (cond ((not (null position-newline)) (multiple-value-bind (width ascent descent left right font-ascent font-descent direction first-not-done) (font-text-extents xfont string :start start :end position-newline :translate #'translate) (declare (ignorable left right font-ascent font-descent direction first-not-done)) (multiple-value-bind (minx miny maxx maxy) (climi::text-bounding-rectangle* medium string :text-style text-style :start (1+ position-newline) :end end) (values (min minx left) (- ascent) (max maxx right) (+ descent maxy))))) (t (multiple-value-bind (width ascent descent left right font-ascent font-descent direction first-not-done) (font-text-extents xfont string :start start :end end :translate #'translate) (declare (ignore width direction first-not-done)) ;; FIXME: Potential style points: ;; * (min 0 left), (max width right) ;; * font-ascent / ascent (values left (- font-ascent) right font-descent))))))))) (defmethod make-medium-gcontext* (medium foreground background line-style text-style (ink color) clipping-region) (let* ((drawable (sheet-mirror (medium-sheet medium))) (port (port medium))) (let ((gc (xlib:create-gcontext :drawable drawable))) (let ((fn (text-style-to-X-font port text-style))) (if (typep fn 'xlib:font) (setf (xlib:gcontext-font gc) fn))) (setf (xlib:gcontext-foreground gc) (X-pixel port ink) ) gc))) (defmethod medium-draw-text* ((medium clx-medium) string x y start end align-x align-y toward-x toward-y transform-glyphs) (declare (ignore toward-x toward-y transform-glyphs)) (with-transformed-position ((sheet-native-transformation (medium-sheet medium)) x y) (with-clx-graphics (medium) (when (characterp string) (setq string (make-string 1 :initial-element string))) (when (null end) (setq end (length string))) (multiple-value-bind (text-width text-height x-cursor y-cursor baseline) (text-size medium string :start start :end end) (declare (ignore x-cursor y-cursor)) (unless (and (eq align-x :left) (eq align-y :baseline)) (setq x (- x (ecase align-x (:left 0) (:center (round text-width 2)) (:right text-width)))) (setq y (ecase align-y (:top (+ y baseline)) (:center (+ y baseline (- (floor text-height 2)))) (:baseline y) (:bottom (+ y baseline (- text-height)))))) (let ((x (round-coordinate x)) (y (round-coordinate y))) (when (and (<= #x-8000 x #x7FFF) (<= #x-8000 y #x7FFF)) (font-draw-glyphs (text-style-to-X-font (port medium) (medium-text-style medium)) mirror gc x y string #| x (- y baseline) (+ x text-width) (+ y (- text-height baseline )) |# :start start :end end :translate #'translate))))))) (defmethod (setf medium-text-style) :before (text-style (medium clx-medium)) (with-slots (gc) medium (when gc (let ((old-text-style (medium-text-style medium))) (unless (eq text-style old-text-style) (let ((fn (text-style-to-X-font (port medium) (medium-text-style medium)))) (when (typep fn 'xlib:font) (setf (xlib:gcontext-font gc) fn)))))))) ;;; ;;; This fixes the worst offenders making the assumption that drawing ;;; would be idempotent. ;;; (defmethod clim:handle-repaint :around ((s clim:sheet-with-medium-mixin) r) (let ((m (clim:sheet-medium s)) (r (clim:bounding-rectangle (clim:region-intersection r (clim:sheet-region s))))) (unless (eql r clim:+nowhere+) (clim:with-drawing-options (m :clipping-region r) ;; This causes applications which want to do a double-buffered repaint, ;; such as the logic cube, to flicker. On the other hand, it also ;; stops things such as the listener wholine from overexposing their ;; text. Who is responsible for clearing to the background color before ;; repainting? ;(clim:draw-design m r :ink clim:+background-ink+) (call-next-method s r) ;; FIXME: Shouldn't McCLIM always do this? (medium-force-output (sheet-medium s)))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Experimental/pprint/0000755000175000017500000000000011347763412020760 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Experimental/pprint/pprint.lisp0000644000175000017500000006642307661645263023207 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: PP2; -*- ;;; --------------------------------------------------------------------------- ;;; Title: PPRINT for McCLIM ;;; Created: 2003-05-18 ;;; Author: Gilbert Baumann ;;; License: LGPL (See file COPYING for details). ;;; $Id: pprint.lisp,v 1.2 2003/05/18 08:56:19 gilbert Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2003 by Gilbert Baumann ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;;; Notes ;; - INVOKE-WITH-LOGICAL-BLOCK ;; ;; - The specification is explict about depth abbreviation and dotted ;; So the common implementation should share this. Specifically that ;; is the DESCEND-INTO and the implementation of POP and ;; EXIT-IF-EXHAUSTED. Whether DESCEND-INTO might also be worth ;; protocolizing is an open question. Although a case can be made ;; for also protocolizing that. ;; - Hefner wants nifty unreadable objects therefore we might think ;; about protolizing print-unreadable-object too. ;; - How we can integrate this into a _practically_ closed source lisp ;; like ACL or Lispworks is uncertain. But looking at the macro ;; expansion both seem to use XP so the source is there and we could ;; figure out which functions need to be adviced / replaced. ;; - I have no clue how *PRINT-CIRCLE* and *PRINT-SHARE* are ;; implemented, we need to figure that out. (defpackage :pp2 (:use :clim :clim-lisp) (:import-from :SB-PRETTY #:INVOKE-WITH-LOGICAL-BLOCK #:STREAM-PPRINT-TAB #:STREAM-PPRINT-NEWLINE #:STREAM-PPRINT-INDENT)) (in-package :pp2) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; Patching SBCL into shape ;;;; (declaim (notinline sb-pretty::pretty-stream-p)) (defvar *orig-invoke-with-logical-block* #'invoke-with-logical-block) (defvar *orig-pretty-stream-p* #'sb-pretty::pretty-stream-p) (progn ;;eval-when (compile eval load) (fmakunbound 'sb-pretty::pretty-stream-p) (defgeneric sb-pretty::pretty-stream-p (stream)) (defmethod sb-pretty::pretty-stream-p (stream) (funcall *orig-pretty-stream-p* stream))) (fmakunbound 'stream-pprint-newline) (defgeneric stream-pprint-newline (stream kind)) (defmethod stream-pprint-newline (stream kind) (when (sb-pretty::print-pretty-on-stream-p stream) (sb-pretty::enqueue-newline stream kind))) (fmakunbound 'stream-pprint-indent) (defgeneric stream-pprint-indent (stream relative-to n)) (defmethod stream-pprint-indent (stream relative-to n) (when (sb-pretty::print-pretty-on-stream-p stream) (sb-pretty::enqueue-indent stream relative-to n))) (fmakunbound 'stream-pprint-tab) (defgeneric stream-pprint-tab (stream kind colnum colinc)) (defmethod stream-pprint-tab (stream kind colnum colinc) (when (sb-pretty::print-pretty-on-stream-p stream) (sb-pretty::enqueue-tab stream kind colnum colinc))) (fmakunbound 'invoke-with-logical-block) (defgeneric invoke-with-logical-block (stream continuation object &key prefix per-line-prefix suffix)) (defmethod invoke-with-logical-block (stream continuation object &rest args &key prefix per-line-prefix suffix) (apply *orig-invoke-with-logical-block* stream continuation object args)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; ;;;; (define-application-frame foo () () (:pointer-documentation t) (:panes (io :interactor :width 600 :height 1000 ;;:text-style (make-text-style :sans-serif :roman :normal) )) (:layouts (default io))) (defun foo () (run-frame-top-level(make-application-frame'foo))) (defparameter *my-dispatch* (copy-pprint-dispatch nil)) (set-pprint-dispatch 'string (lambda (stream thing) (let ((*print-pretty* nil)) (with-drawing-options (stream :ink +blue+) (prin1 thing stream)))) 0 *my-dispatch*) (defparameter *thing* '(defun pprint-tab (kind colnum colinc &optional stream) "If STREAM (which defaults to *STANDARD-OUTPUT*) is a pretty-printing stream, perform tabbing based on KIND, otherwise do nothing. KIND can be one of: :LINE - Tab to column COLNUM. If already past COLNUM tab to the next multiple of COLINC. :SECTION - Same as :LINE, but count from the start of the current section, not the start of the line. :LINE-RELATIVE - Output COLNUM spaces, then tab to the next multiple of COLINC. :SECTION-RELATIVE - Same as :LINE-RELATIVE, but count from the start of the current section, not the start of the line." (declare (type (member :line :section :line-relative :section-relative) kind) (type unsigned-byte colnum colinc) (type (or stream (member t nil)) stream) (values null)) (let ((stream (case stream ((t) *terminal-io*) ((nil) *standard-output*) (t stream)))) (stream-pprint-tab stream kind colnum colinc)) nil)) (defparameter *thing* '(defun invoke-with-logical-block (stream continuation object &key prefix per-line-prefix (suffix "")) (declare (type function continuation)) (with-pretty-stream (stream stream) (if (listp object) (descend-into (stream) (let ((count 0)) (start-logical-block stream (the (or null string) (or prefix per-line-prefix)) (if per-line-prefix t nil) (the string suffix)) (block .block. (flet ((pp-pop () (unless (listp object) (write-string ". " stream) (output-object object stream) (return-from .block. nil)) (when (and (not *print-readably*) (eql count *print-length*)) (write-string "..." stream) (return-from .block. nil)) (when (and object (plusp count) (check-for-circularity object)) (write-string ". " stream) (output-object object stream) (return-from .block. nil)) (incf count) (pop object))) (funcall continuation stream #'pp-pop #'(lambda () (when (null object) (return-from .block. nil)))) )) ;; FIXME: Don't we need UNWIND-PROTECT to ensure this ;; always gets executed? (end-logical-block stream))) (output-object object stream))))) (define-foo-command com-foo () (let ((*print-case* :downcase) (*print-pprint-dispatch* *my-dispatch*)) (with-text-style (*standard-output* (make-text-style :sans-serif :roman :normal)) (pprint *thing*) ))) (define-foo-command com-bar () (let ((*print-pretty* t)) (describe *package*))) (define-foo-command com-pascal () (cl-user::pascal-write '(defun sqt (n &aux sqt) (declare (float n) (float sqt)) (setq sqt 1.0) (loop (when (< (abs (- (* sqt sqt) n)) 1.0E-4) (return nil)) (setq sqt (/ (+ sqt (/ n sqt)) 2.0))) sqt))) (define-foo-command com-paskal () (with-text-style (*standard-output* #+NIL(make-text-style :serif :roman :normal) (make-device-font-text-style (port *standard-output*) "-*-times-medium-r-*-*-*-140-*-*-*-*-iso8859-15")) (cl-user::pascal-write '(defun sqt (n &aux sqt) (declare (float n) (float sqt)) (setq sqt 1.0) (loop (when (< (abs (- (* sqt sqt) n)) 1.0E-4) (return nil)) (setq sqt (/ (+ sqt (/ n sqt)) 2.0)) (setq sqt (/ (+ sqt (/ n sqt)) 2.0)) (setq sqt (/ (+ sqt (/ n sqt)) 2.0)) (print "hallo") (if (< x 10) (print "dadadidum")) ) sqt)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; ;;;; ;;;; (defvar *pretty-printing-in-effect-p* nil) (defmethod invoke-with-logical-block ((stream extended-output-stream) continuation object &key prefix per-line-prefix (suffix "")) (labels ((doit (stream object) (if (listp object) (sb-kernel:descend-into (stream) (let ((count 0)) (start-logical-block stream (the (or null string) (or prefix per-line-prefix)) (if per-line-prefix t nil) (the string suffix)) (block .block. (flet ((pp-pop () (unless (listp object) (write-string ". " stream) (prin1 object stream) (return-from .block. nil)) (when (and (not *print-readably*) (eql count *print-length*)) (write-string "..." stream) (return-from .block. nil)) (when (and object (plusp count) (sb-pretty::check-for-circularity object)) (write-string ". " stream) (prin1 object stream) (return-from .block. nil)) (incf count) (pop object))) (funcall continuation stream #'pp-pop #'(lambda () (when (null object) (return-from .block. nil)))) )) ;; FIXME: Don't we need UNWIND-PROTECT to ensure this ;; always gets executed? (end-logical-block stream suffix))) (prin1 object stream)))) (cond (*pretty-printing-in-effect-p* (with-output-as-presentation (stream object (clim:presentation-type-of object)) (doit stream object))) (t (let ((*pretty-printing-in-effect-p* t) (*phase* *phase*)) (with-end-of-line-action (stream :allow) (multiple-value-bind (cx cy) (stream-cursor-position stream) (with-end-of-page-action (stream :allow) (start-phase-1 stream) (with-output-recording-options (stream :record nil :draw nil) (doit stream object))) (start-phase-2 stream cx cy) (with-output-as-presentation (stream object (clim:presentation-type-of object)) (doit stream object))))))))) (defmethod sb-pretty::pretty-stream-p ((stream extended-output-stream)) t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; Items ;;;; (defvar *items*) (defvar *last-observerd-x*) (defvar *phase* :illegal) (defvar *level* 0) (defvar *pointer* 0) (defvar *block-stack* nil) (defclass item () ((x :initarg :x :reader item-x))) (defclass newline (item) ((kind :initarg :kind :reader newline-kind) (level :initarg :level :reader newline-level) (preceeding-section :initform nil :accessor newline-preceeding-section) (following-section :initform nil :accessor newline-following-section) (containing-section :initform nil :accessor newline-containing-section) (taken-p :initform nil :accessor newline-taken-p) )) (defclass indent (item) ((relative-to :initarg :relative-to :reader indent-relative-to) (amount :initarg :amount :reader indent-amount))) (defmethod print-object ((object indent) stream) (print-unreadable-object (object stream :type t :identity nil) (format stream "~S ~S ~S" (item-x object) (indent-relative-to object) (indent-amount object)))) (defmethod print-object ((object newline) stream) (print-unreadable-object (object stream :type t :identity nil) (format stream "~S ~S ~S ~S,~S,~S" (item-x object) (newline-kind object) (newline-level object) (newline-preceeding-section object) (newline-following-section object) (newline-containing-section object)))) (defmethod print-object ((object item) stream) (print-unreadable-object (object stream :type t :identity nil) (format stream "~S" (item-x object)))) (defclass block-start (item) ((level :initarg :level :reader block-level) (x0 :accessor block-x0) (ind :accessor block-ind) (linear-newline-taken-p :initform nil :accessor block-linear-newline-taken-p) )) (defclass block-end (item) ((level :initarg :level :reader block-level))) ;;;; (defun start-logical-block (stream prefix per-line-p suffix) (when prefix (write-string prefix stream)) (ecase *phase* (:collect (incf *level*) (push (make-instance 'block-start :level *level* :x (stream-cursor-position stream)) *items*)) (:doit (unless (typep (aref *items* *pointer*) 'block-start) (error "You're not playing by the rules.")) (push (aref *items* *pointer*) *block-stack*) (setf (block-x0 (car *block-stack*)) (stream-cursor-position stream)) (setf (block-ind (car *block-stack*)) (stream-cursor-position stream)) (incf *pointer*) )) ;; ) (defun end-logical-block (stream suffix) (ecase *phase* (:collect (push (make-instance 'block-end :level *level* :x (stream-cursor-position stream)) *items*) (decf *level*)) (:doit (unless (typep (aref *items* *pointer*) 'block-end) (error "You're not playing by the rules.")) (pop *block-stack*) (incf *pointer*) )) (write-string suffix stream)) (defparameter *print-w* 500) (defparameter *debug-p* nil) (defmethod stream-pprint-newline ((stream extended-output-stream) kind) (when *pretty-printing-in-effect-p* (ecase *phase* (:collect (push (make-instance 'newline :x (stream-cursor-position stream) :level *level* :kind kind) *items*)) (:doit (unless (typep (aref *items* *pointer*) 'newline) (error "You're not playing by the rules.")) (labels ((dobreak () (setf (newline-taken-p (aref *items* *pointer*)) t) (terpri stream) (multiple-value-bind (x y) (stream-cursor-position stream) (setf (stream-cursor-position stream) (values (block-ind (car *block-stack*)) y))))) (case kind (:fill (when *debug-p* (princ "{f}")) (let* ((i (car (newline-following-section (aref *items* *pointer*)))) (j (cdr (newline-following-section (aref *items* *pointer*)))) (w (- (item-x (aref *items* j)) (item-x (aref *items* i))))) (cond ((or (some #'(lambda (x) (typecase x (newline (newline-taken-p x)))) (subseq *items* (car (newline-preceeding-section (aref *items* *pointer*))) (cdr (newline-preceeding-section (aref *items* *pointer*))))) (>= (+ (stream-cursor-position stream) w) *print-w*)) (dobreak)) (t ) ))) (:mandatory (dobreak)) (:linear (let* ((i (car (newline-containing-section (aref *items* *pointer*)))) (j (cdr (newline-containing-section (aref *items* *pointer*)))) (w (- (item-x (aref *items* j)) (item-x (aref *items* i))))) #|| ; (princ "{l") (princ i) (princ ".")(princ j)(princ ".")(princ w) (princ "}") ||# (when *debug-p* (let ((*print-pretty* nil)) (princ "{L") (princ w) (princ ":") (princ (stream-cursor-position stream)) (princ (cons i j)) (princ ".") (princ (newline-level (aref *items* *pointer*))) (princ "}"))) (cond ((or #+NIL (not (section-fits-p i j (stream-cursor-position stream))) (>=;;(+ (stream-cursor-position stream) w) (+ (block-x0 (car *block-stack*)) w) *print-w*) #+NIL (some #'(lambda (x) (typecase x (newline (newline-taken-p x)))) (subseq *items* i j)) ;;(block-linear-newline-taken-p(car *block-stack*)) ) (setf (block-linear-newline-taken-p(car *block-stack*)) t) (dobreak)) (t nil)))))) (incf *pointer*) )))) (defun fill-newline-breaks-p (*pointer* x0) (let* ((i (car (newline-following-section (aref *items* *pointer*)))) (j (cdr (newline-following-section (aref *items* *pointer*)))) (w (- (item-x (aref *items* j)) (item-x (aref *items* i))))) (or (some #'(lambda (x) (typecase x (newline (newline-taken-p x)))) (subseq *items* (car (newline-preceeding-section (aref *items* *pointer*))) (cdr (newline-preceeding-section (aref *items* *pointer*))))) (not (section-fits-p i j x0)) (>= (+ x0 w) *print-w*)))) (defvar *yet* nil) (defun section-fits-p (i j x0) (cond ((member (cons i j) *yet* :test #'equal) t) (t (let ((*yet* (cons (cons i j) *yet*))) (let ((w (- (item-x (aref *items* j)) (item-x (aref *items* i)))) (dx (- (item-x (aref *items* i)) x0))) (block foo (when (< (+ x0 w) *print-w*) (loop for k from i below j for q = (aref *items* k) do (typecase q (newline (case (newline-kind q) (:mandatory (return-from foo nil)) (:linear #+NIL (when (some #'(lambda (x) (typecase x (newline (newline-taken-p x)))) (subseq *items* (car (newline-containing-section q)) (cdr (newline-containing-section q)))) (return nil))) (:fill (when (fill-newline-breaks-p k (+ (item-x q) dx)) (return-from foo nil))))))) t))))))) (defmethod stream-pprint-indent ((stream extended-output-stream) relative-to amount) (when *pretty-printing-in-effect-p* (ecase *phase* (:collect (push (make-instance 'indent :relative-to relative-to :amount amount :x (stream-cursor-position stream)) *items*)) (:doit (case relative-to (:current (setf (block-ind (car *block-stack*)) (+ (stream-cursor-position stream) (* amount (text-size stream "m"))))) (:block (setf (block-ind (car *block-stack*)) (+ (block-x0 (car *block-stack*)) (* amount (text-size stream "m")))))) (incf *pointer*) )))) ;;;; ;;;; (defun start-phase-1 (stream) (setf *items* nil) (setf *last-observerd-x* (stream-cursor-position stream)) (setf *phase* :collect) ) (defun start-phase-2 (stream cx cy) (setf *items* (coerce (reverse *items*) 'vector)) ;; (let ((sections nil)) (loop for i from 0 for q across *items* do (typecase q (newline (setf (newline-preceeding-section q) (find-preceeding-section i)) (setf (newline-following-section q) (find-following-section i))))) (loop for i from 0 for q across *items* do (typecase q (newline ;; we do this by the book ... (let ((min (cons 0 (length *items*)))) (loop for k across *items* do (typecase k (newline (labels ((consider (x) (when (and (< (car x) i) (< i (cdr x)) (< (- (cdr x) (car x)) (- (cdr min) (car min)))) (setf min x)))) (consider (newline-preceeding-section k)) (consider (newline-following-section k)))))) (setf (newline-containing-section q) min))))) ) (setf *items* (coerce (append (coerce *items* 'list) (list (make-instance 'item :x (stream-cursor-position stream)))) 'vector)) ;; (when *debug-p* (print *items* *trace-output*)) (setf *pointer* 0) (setf *phase* :doit) (setf (stream-cursor-position stream) (values cx cy)) ) (defun find-preceeding-section (i) (cons (1+ (loop for j from (- i 1) by -1 do (typecase (aref *items* j) (newline (when (= (newline-level (aref *items* j)) (newline-level (aref *items* i))) (return j))) (block-start (when (= (block-level (aref *items* j)) (newline-level (aref *items* i))) (return j)))))) i)) (defun find-following-section (i) (cons i (loop for j from (+ i 1) do (when (= j (length *items*)) (return j)) (typecase (aref *items* j) (newline (when (<= (newline-level (aref *items* j)) (newline-level (aref *items* i))) (return j))) )))) ;;;; ;;; OUTPUT-PRETTY-OBJECT is called by OUTPUT-OBJECT when ;;; *PRINT-PRETTY* is true. (defun sb-pretty::output-pretty-object (object stream) (cond ((and (extended-output-stream-p stream) (atom object) *print-escape*) (when *debug-p* (print object *trace-output*)) (with-output-as-presentation (stream object (clim:presentation-type-of object)) (funcall (sb-pretty::pprint-dispatch object) stream object))) (t (sb-pretty::with-pretty-stream (stream) (funcall (sb-pretty::pprint-dispatch object) stream object))))) (set-pprint-dispatch '(cons (member block)) #'(lambda (stream thing) (cond ((extended-output-stream-p stream) (surrounding-output-with-border (stream :shape :drop-shadow) (with-drawing-options (stream :ink +blue+) (pprint-linear stream thing)))) (t (pprint-linear stream thing))))) (set-pprint-dispatch '(cons (member unless when with-pretty-stream block if descend-into)) (lambda (stream thing) (pprint-logical-block (stream thing :prefix "(" :suffix ")") (cond ((extended-output-stream-p stream) (with-drawing-options (stream :ink +blue4+) (with-text-style (stream (make-device-font-text-style (port stream) "-*-helvetica-bold-r-*-*-*-120-*-*-*-*-iso8859-15")) (prin1 (pprint-pop) stream)))) (t (prin1 (pprint-pop) stream))) (write-string " " stream) (pprint-newline :miser) (prin1 (pprint-pop) stream) (write-string " " stream) (pprint-indent :block 2) (loop (pprint-exit-if-list-exhausted) (pprint-newline :mandatory stream) (prin1 (pprint-pop))))) 0 *my-dispatch*) (defmethod climi::text-style-equalp (x y) (eq x y)) ;; ;; $Log: pprint.lisp,v $ ;; Revision 1.2 2003/05/18 08:56:19 gilbert ;; - added a few notes ;; - stream-pprint-newline and stream-pprint-indent are now no-ops when ;; no pretty printing is effect as they should. ;; - it is no longer neccessary to load the file twice. ;; ;; cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Experimental/pprint/sbcl-0.8alpha.0.patch0000644000175000017500000002345707661441135024405 0ustar pdmpdmdiff -x *.fasl -x *-expr -x *.h -rc orig/sbcl-0.8alpha.0/src/code/early-pprint.lisp sbcl-0.8alpha.0/src/code/early-pprint.lisp *** orig/sbcl-0.8alpha.0/src/code/early-pprint.lisp Sat Oct 21 01:30:33 2000 --- sbcl-0.8alpha.0/src/code/early-pprint.lisp Sat May 17 02:16:01 2003 *************** *** 32,37 **** --- 32,38 ---- (defmacro pprint-logical-block ((stream-symbol object + &rest rest &key prefix per-line-prefix *************** *** 41,121 **** "Group some output into a logical block. STREAM-SYMBOL should be either a stream, T (for *TERMINAL-IO*), or NIL (for *STANDARD-OUTPUT*). The printer control variable *PRINT-LEVEL* is automatically handled." (when (and prefix per-line-prefix) (error "cannot specify both PREFIX and a PER-LINE-PREFIX values")) ! (multiple-value-bind (stream-var stream-expression) ! (case stream-symbol ! ((nil) ! (values '*standard-output* '*standard-output*)) ! ((t) ! (values '*terminal-io* '*terminal-io*)) ! (t ! (values stream-symbol ! (once-only ((stream stream-symbol)) ! `(case ,stream ! ((nil) *standard-output*) ! ((t) *terminal-io*) ! (t ,stream)))))) ! (let* ((object-var (if object (gensym) nil)) ! (block-name (gensym "PPRINT-LOGICAL-BLOCK-")) ! (count-name (gensym "PPRINT-LOGICAL-BLOCK-LENGTH-")) ! (pp-pop-name (gensym "PPRINT-POP-")) ! (body ! ;; FIXME: It looks as though PPRINT-LOGICAL-BLOCK might ! ;; expand into a boatload of code, since DESCEND-INTO is a ! ;; macro too. It might be worth looking at this to make ! ;; sure it's not too bloated, since PPRINT-LOGICAL-BLOCK ! ;; is called many times from system pretty-printing code. ! `(descend-into (,stream-var) ! (let ((,count-name 0)) ! (declare (type index ,count-name) (ignorable ,count-name)) ! (start-logical-block ,stream-var ! (the (or null string) ! ,(or prefix per-line-prefix)) ! ,(if per-line-prefix t nil) ! (the string ,suffix)) ! (block ,block-name ! (flet ((,pp-pop-name () ! ,@(when object ! `((unless (listp ,object-var) ! (write-string ". " ,stream-var) ! (output-object ,object-var ,stream-var) ! (return-from ,block-name nil)))) ! (when (and (not *print-readably*) ! (eql ,count-name *print-length*)) ! (write-string "..." ,stream-var) ! (return-from ,block-name nil)) ! ,@(when object ! `((when (and ,object-var ! (plusp ,count-name) ! (check-for-circularity ! ,object-var)) ! (write-string ". " ,stream-var) ! (output-object ,object-var ,stream-var) ! (return-from ,block-name nil)))) ! (incf ,count-name) ! ,@(when object ! `((pop ,object-var))))) ! (declare (ignorable #',pp-pop-name)) ! (macrolet ((pprint-pop () ! '(,pp-pop-name)) ! (pprint-exit-if-list-exhausted () ! ,(if object ! `'(when (null ,object-var) ! (return-from ,block-name nil)) ! `'(return-from ,block-name nil)))) ! ,@body))) ! ;; FIXME: Don't we need UNWIND-PROTECT to ensure this ! ;; always gets executed? ! (end-logical-block ,stream-var))))) ! (when object ! (setf body ! `(let ((,object-var ,object)) ! (if (listp ,object-var) ! ,body ! (output-object ,object-var ,stream-var))))) ! `(with-pretty-stream (,stream-var ,stream-expression) ! ,body)))) (defmacro pprint-exit-if-list-exhausted () #!+sb-doc --- 42,65 ---- "Group some output into a logical block. STREAM-SYMBOL should be either a stream, T (for *TERMINAL-IO*), or NIL (for *STANDARD-OUTPUT*). The printer control variable *PRINT-LEVEL* is automatically handled." + (declare (ignore suffix)) (when (and prefix per-line-prefix) (error "cannot specify both PREFIX and a PER-LINE-PREFIX values")) ! (let ((var (case stream-symbol ! ((nil) '*standard-output*) ! ((t) '*terminal-io*) ! (otherwise stream-symbol))) ! (cont (gensym "CONT.")) ! (pprint-pop-fn (gensym "PPRINT-POP-FN.")) ! (pprint-exit-if-list-exhausted-fn (gensym "PPRINT-EXIT-IF-LIST-EXHAUSTED-FN."))) ! `(labels ((,cont (,var ,pprint-pop-fn ,pprint-exit-if-list-exhausted-fn) ! (macrolet ((pprint-pop () ! `(funcall ,',pprint-pop-fn)) ! (pprint-exit-if-list-exhausted () ! `(funcall ,',pprint-exit-if-list-exhausted-fn))) ! ,@body))) ! (declare (dynamic-extent #',cont)) ! (invoke-with-logical-block ,var #',cont ,object ,@rest)))) (defmacro pprint-exit-if-list-exhausted () #!+sb-doc diff -x *.fasl -x *-expr -x *.h -rc orig/sbcl-0.8alpha.0/src/code/pprint.lisp sbcl-0.8alpha.0/src/code/pprint.lisp *** orig/sbcl-0.8alpha.0/src/code/pprint.lisp Wed Jan 8 11:59:11 2003 --- sbcl-0.8alpha.0/src/code/pprint.lisp Sat May 17 02:07:16 2003 *************** *** 179,184 **** --- 179,225 ---- ;; The line number (section-start-line 0 :type index)) + (defun invoke-with-logical-block (stream continuation object + &key prefix per-line-prefix (suffix "")) + (declare (type function continuation)) + (with-pretty-stream (stream stream) + (if (listp object) + (descend-into (stream) + (let ((count 0)) + (start-logical-block stream + (the (or null string) (or prefix per-line-prefix)) + (if per-line-prefix t nil) + (the string suffix)) + (block .block. + (flet ((pp-pop () + (unless (listp object) + (write-string ". " stream) + (output-object object stream) + (return-from .block. nil)) + (when (and (not *print-readably*) + (eql count *print-length*)) + (write-string "..." stream) + (return-from .block. nil)) + (when (and object + (plusp count) + (check-for-circularity + object)) + (write-string ". " stream) + (output-object object stream) + (return-from .block. nil)) + (incf count) + (pop object))) + (funcall continuation + stream + #'pp-pop + #'(lambda () + (when (null object) + (return-from .block. nil)))) )) + ;; FIXME: Don't we need UNWIND-PROTECT to ensure this + ;; always gets executed? + (end-logical-block stream))) + (output-object object stream)))) + (defun really-start-logical-block (stream column prefix suffix) (let* ((blocks (pretty-stream-blocks stream)) (prev-block (car blocks)) *************** *** 677,686 **** ((t) *terminal-io*) ((nil) *standard-output*) (t stream)))) ! (when (print-pretty-on-stream-p stream) ! (enqueue-newline stream kind))) nil) (defun pprint-indent (relative-to n &optional stream) #!+sb-doc "Specify the indentation to use in the current logical block if STREAM --- 718,730 ---- ((t) *terminal-io*) ((nil) *standard-output*) (t stream)))) ! (stream-pprint-newline stream kind)) nil) + (defun stream-pprint-newline (stream kind) + (when (print-pretty-on-stream-p stream) + (enqueue-newline stream kind))) + (defun pprint-indent (relative-to n &optional stream) #!+sb-doc "Specify the indentation to use in the current logical block if STREAM *************** *** 700,709 **** ((t) *terminal-io*) ((nil) *standard-output*) (t stream)))) ! (when (print-pretty-on-stream-p stream) ! (enqueue-indent stream relative-to n))) nil) (defun pprint-tab (kind colnum colinc &optional stream) #!+sb-doc "If STREAM (which defaults to *STANDARD-OUTPUT*) is a pretty-printing --- 744,756 ---- ((t) *terminal-io*) ((nil) *standard-output*) (t stream)))) ! (stream-pprint-indent stream relative-to n)) nil) + (defun stream-pprint-indent (stream relative-to n) + (when (print-pretty-on-stream-p stream) + (enqueue-indent stream relative-to n))) + (defun pprint-tab (kind colnum colinc &optional stream) #!+sb-doc "If STREAM (which defaults to *STANDARD-OUTPUT*) is a pretty-printing *************** *** 725,733 **** ((t) *terminal-io*) ((nil) *standard-output*) (t stream)))) ! (when (print-pretty-on-stream-p stream) ! (enqueue-tab stream kind colnum colinc))) nil) (defun pprint-fill (stream list &optional (colon? t) atsign?) #!+sb-doc --- 772,783 ---- ((t) *terminal-io*) ((nil) *standard-output*) (t stream)))) ! (stream-pprint-tab stream kind colnum colinc)) nil) + + (defun stream-pprint-tab (stream kind colnum colinc) + (when (print-pretty-on-stream-p stream) + (enqueue-tab stream kind colnum colinc))) (defun pprint-fill (stream list &optional (colon? t) atsign?) #!+sb-doc cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Experimental/tree-with-cross-edges/0000750000175000017500000000000011347763412023563 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Experimental/tree-with-cross-edges/tree-with-cross-edges.lisp0000640000175000017500000001776410574370352030616 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;;--------------------------------------------------------------------------- ;;; Copyright (c) 2005-2007 Robert P. Goldman and Smart Information ;;; Flow Technologies, d/b/a SIFT, LLC ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; ;;; All rights reserved. ;;; ;;;--------------------------------------------------------------------------- ;;; File Description: ;;; ;;; File for definitions of a new graph type that should allow tree ;;; style layouts with edges across in a level. [2005/05/05:rpg] ;;; ;;; History/Bugs/Notes: ;;; ;;; [2005/05/05:rpg] Created. ;;; ;;;--------------------------------------------------------------------------- (in-package "CLIM-INTERNALS") ;;;--------------------------------------------------------------------------- ;;; A graph with cross trees will have an additional type option: a ;;; cross-edge-producer ;;;--------------------------------------------------------------------------- (eval-when (:compile-toplevel :load-toplevel :execute) (define-graph-type :tree-with-cross-edges cross-tree-output-record)) (defun standard-cross-arc-drawer (stream from-node to-node x1 y1 x2 y2 &rest drawing-options &key edge-type &allow-other-keys) "The standard cross-arc-drawer simply ignores the edge-type keyword argument." (declare (ignore edge-type)) (remf drawing-options :edge-type) (apply #'standard-arc-drawer stream from-node to-node x1 y1 x2 y2 drawing-options)) (defclass cross-tree-output-record (tree-graph-output-record) ((cross-arc-drawer :initarg :cross-arc-drawer :reader cross-arc-drawer :documentation "This slot should be bound to a function that takes all the arguments accepted by a normal arc-drawer, but also an edge-type keyword argument, which it is free to ignore." :initform #'standard-cross-arc-drawer ) (cross-arc-producer :initarg :cross-arc-producer ;; by default, this just acts like a tree... :initform nil :reader cross-arc-producer :documentation "This should be bound to a function that takes a graph-node as argument, like inferior-producer, but that returns two values: a list of destination nodes and (optionally) a list of type-designators, that can be passed to the cross-arc-drawer, as the value of the :edge-type keyword argument." ) (cross-arc-drawing-options :reader cross-arc-drawing-options ) ) ) ;;;--------------------------------------------------------------------------- ;;; This is very yucky. It will be expensive on large graphs (perhaps ;;; a mixin for using a hash-table would be better), and needs some ;;; kind of good way of specifying the test in your graph class, which ;;; will be difficult... [2005/05/06:rpg] ;;;--------------------------------------------------------------------------- (defmethod lookup-node (source-node (graph graph-output-record) &key (test #'eql) (default :error)) (let ((hash-table (make-hash-table :test #'eq))) (flet ((visitedp (node) (gethash node hash-table nil)) (mark (node) (setf (gethash node hash-table) t))) (or (loop with openlist = (graph-root-nodes graph) for node = (pop openlist) while node unless (visitedp node) when (funcall test source-node (graph-node-object node)) return node end and do (mark node) (setf openlist (append openlist (graph-node-children node)))) (when (eq default :error) (error "Unable to find graph node for ~S in ~S" source-node graph)) default)))) (defmethod initialize-instance :after ((obj cross-tree-output-record) &key cross-arc-drawing-options arc-drawing-options) "A possibly reasonable default is to draw cross-arcs as if they were normal tree edge arcs." (unless cross-arc-drawing-options (setf (slot-value obj 'cross-arc-drawing-options) arc-drawing-options))) ;;; note that this could later be made into a function argument, so ;;; that programmers could customize [2005/05/06:rpg] (defgeneric cross-arc-routing (from to orientation) (:documentation "Return four values, x1, y1, x2, y2 for the arc-drawing for a cross-arc. More complex than for the tree case.")) (defun middle (dim1 dim2) (/ (+ dim1 dim2) 2)) (defmethod cross-arc-routing (from to (orientation (eql :horizontal))) (with-bounding-rectangle* (x1 y1 x2 y2) from (with-bounding-rectangle* (u1 v1 u2 v2) to (cond ((< x2 u1) ;; node entirely to the left of k (values x2 (middle y1 y2) u1 (middle v1 v2))) ((< u2 x1) ;; node entirely to the right of k ;; draw from the top or bottom to make distinguishable... (if (<= v1 y1) ;; draw from the top to the x middle of TO on the ;; bottom (values x1 y1 (middle u1 u2) v2) ;; draw from the bottom to the x middle of TO on the ;; top... (values x1 y2 (middle u1 u2) v1))) ;; overlapping in X -- as long as this is a tree, means ;; they are siblings. ((< y2 v1) ;; FROM above: middle x of FROM to middle x of TO, bottom to top... (values (middle x1 x2) y2 (middle u1 u2) v1)) ((< v2 y1) ;; TO above: middle x of FROM to middle x of TO, top to bottom... (values (middle x1 x2) y1 (middle u1 u2) v2)) (t (error "Unforeseen node positioning.")))))) ;;; copied from original layout-graph-edges and enhanced to add cross ;;; edges. (defmethod layout-graph-edges :after ((graph cross-tree-output-record) stream arc-drawer arc-drawing-options) "After the main method has drawn the tree, add the cross-edges." (declare (ignore arc-drawer arc-drawing-options)) ;;; (format excl:*initial-terminal-io* "~&Invoking after method to layout cross-edges.~%") ;;; (unless (cross-arc-producer graph) ;;; (format excl:*initial-terminal-io* "~&Uh-oh! No cross-arc-producer!~%")) (with-slots (orientation) graph ;; We tranformed the position of the nodes when we inserted them into ;; output history, so the bounding rectangles queried below will be ;; transformed. Therefore, disable the transformation now, otherwise ;; the transformation is effectively applied twice to the edges. (when (cross-arc-producer graph) (with-identity-transformation (stream) ;; for some damn reason, this graph traversal isn't working.... (traverse-graph-nodes graph (lambda (node children continuation) ;;; (format excl:*initial-terminal-io* ;;; "~&Invoking traverse function on ~S and ~S!~%" node children) (unless (eq node graph) (multiple-value-bind (source-siblings types) (funcall (cross-arc-producer graph) (graph-node-object node)) ;; there's a kind of odd loop here ;; because types might be NIL. Using ;; a built-in stepper would cause the ;; loop to terminate too soon if types ;; was nil [2005/05/06:rpg] (loop for ss in source-siblings for k = (lookup-node ss graph) for typelist = types then (cdr typelist) for type = (when typelist (car typelist)) do (multiple-value-bind (fromx fromy tox toy) (cross-arc-routing node k orientation) (apply (cross-arc-drawer graph) stream node k fromx fromy tox toy :edge-type type (cross-arc-drawing-options graph)))))) (map nil continuation children)))))))././@LongLink0000000000000000000000000000015200000000000011563 Lustar rootrootcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Experimental/tree-with-cross-edges/mcclim-tree-with-cross-edges.asdcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Experimental/tree-with-cross-edges/mcclim-tree-with-cross-edge0000640000175000017500000000302510574370352030710 0ustar pdmpdm;;;; -*- Lisp -*- ;;;--------------------------------------------------------------------------- ;;; Copyright (c) 2005-2007 Robert P. Goldman and Smart Information ;;; Flow Technologies, d/b/a SIFT, LLC ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; ;;; All rights reserved. ;;; ;;;--------------------------------------------------------------------------- ;;; File Description: ;;; ;;; A system that adds a new type of graph to the ;;; format-graph-from-roots protocol for McCLIM. ;;; ;;; ;;;--------------------------------------------------------------------------- (defpackage :mcclim-tree-with-cross-edges-system (:use :cl :asdf)) (in-package :mcclim-tree-with-cross-edges-system) (defsystem :mcclim-tree-with-cross-edges :depends-on (:mcclim) :serial t :components ((:file "tree-with-cross-edges"))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Experimental/png.lisp0000644000175000017500000003216307431353146021124 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: PNG; -*- ;;; --------------------------------------------------------------------------- ;;; Title: Reading .png Files ;;; Created: 1997-04-24 ;;; Author: Gilbert Baumann ;;; License: GPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- ;;; (c) copyright 1997-2001 by Gilbert Baumann ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; XXX this one is borken, we have a more current one in the closure ;;; XXX browser! (require :unzip) (defpackage :png (:use :clim-lisp)) (in-package :PNG) ;;; Image formats to support: ;;; ;;; Color Allowed Interpretation ;;; Type Bit Depths ;;; ;;; 0 1,2,4,8,16 Each pixel is a grayscale sample. ;;; 2 8,16 Each pixel is an R,G,B triple. ;;; 3 1,2,4,8 Each pixel is a palette index; a PLTE chunk must appear. ;;; 4 8,16 Each pixel is a grayscale sample, followed by an alpha sample. ;;; 6 8,16 Each pixel is an R,G,B triple, followed by an alpha sample. ;;; (defconstant *png-magic* '#(137 80 78 71 13 10 26 10) "The first eight bytes of a png file.") (defstruct png-image ihdr idat plte) (defstruct ihdr width height bit-depth color-type compression-method filter-method interlace-method) ;; CODE DUPLICATION ALERT! killed+yanked from images.lisp (defun full-read-byte-sequence (sequence input &key (start 0) (end (length sequence))) (unless (<= end start) (do ((i 0 n) (n (read-sequence sequence input :start 0) (read-sequence sequence input :start n))) ((or (= i n) (>= n end)) (when (= i n) (error "EOF during ~S." 'full-read-byte-sequence)))))) (defun read-png-signature-p (source) "Checks for PNG signature." ;; Returns non-NIL if the first eight bytes read from 'source' is the valid PNG header, NIL otherwise. ;; If eof occurs while reading from source NIL is returned (dotimes (i (length *png-magic*) t) (when (not (eql (read-byte source nil 256) (aref *png-magic* i))) (return nil)))) (defun read-chunk (source) "Read a PNG chunk from 'source' and return the chunk type, a four character string, and a vector containing the data bytes. The CRC is not included into the data bytes. If eof occurs return NIL." ;;TODO: check for CRC errors (let ((length (bu:read-unsigned-byte-32 source nil nil))) (cond (length (let* ((type (bu:read-fixed-ascii-string source 4)) (data (make-array length :element-type '(unsigned-byte 8) :initial-element 0))) (full-read-byte-sequence data source) (bu:read-unsigned-byte-32 source);the crc (values type data) )) (t nil) ))) (defun decode-ihdr (data) "Decode an IHDR chunk from data." (declare (type (vector (unsigned-byte 8)) data)) (make-ihdr :width (bu:decode-unsigned-byte-32 data 0) :height (bu:decode-unsigned-byte-32 data 4) :bit-depth (aref data 8) :color-type (aref data 9) :compression-method (aref data 10) :filter-method (aref data 11) :interlace-method (aref data 12))) (defun decode-plte (data) "Decode a PLTE chunk from the byte vector 'data'." (declare (type (vector (unsigned-byte 8)) data)) (assert (zerop (mod (length data) 3))) (let* ((len (floor (length data) 3)) (palette (make-array len))) (loop for i from 0 to (1- len) do (setf (aref palette i) (vector (aref data (+ (* i 3) 0)) (aref data (+ (* i 3) 1)) (aref data (+ (* i 3) 2)) 255)) ) palette)) (defun decode-trns (palette data) (dotimes (i (length data)) (setf (svref (aref palette i) 3) (aref data i)))) (defun read-png-image (input) (unless (read-png-signature-p input) (error "~A is probably no PNG file." input)) (let ((idat '#()) (plte nil) (ihdr nil)) (do ((x (multiple-value-list (read-chunk input)) (multiple-value-list (read-chunk input)))) ((or (null (car x)) (string= (car x) "IEND")) (cond ((null (car x)) (error "png file lacks an IEND chunk")))) (let ((data (cadr x)) (type (car x))) (let ((*print-array* nil)) (cond ((string= type "IHDR") (setq ihdr (decode-ihdr data)) ) ((string= type "PLTE") (setq plte (decode-plte data)) ) ((and plte (string= type "tRNS")) (decode-trns plte data) ) ((string= type "tEXt") (let ((p (position 0 data))) (format nil "~%;Text: `~A' = `~A'." (map 'string #'code-char (subseq data 0 p)) (map 'string #'code-char (subseq data (+ p 1)))))) #|| ; ((string= type "zTXt") (let ((p (position 0 data))) (format nil "~%;zText: `~A' = `~A'." (map 'string #'code-char (subseq data 0 p)) (map 'string #'code-char (png::rfc1951-uncompress-octects (subseq data (+ p 4))) )))) ||# ((string= type "IDAT") (setf idat (concatenate '(simple-array (unsigned-byte 8)) idat data))) (t ) )))) ;; ;; XXX this is sub-optimal ;; (make-png-image :plte plte :idat (let ((i (unzip:make-inflating-stream (unzip:make-octet-input-stream idat) :format :zlib :element-type '(unsigned-byte 8)))) (unzip:with-output-to-octet-vector (o) (do ((x (read-byte i nil :eof) (read-byte i nil :eof))) ((eq x :eof)) (write-byte x o)))) :ihdr ihdr) )) (defun png-image-row-length (im) (let ((width (ihdr-width (png-image-ihdr im))) (bit-depth (ihdr-bit-depth (png-image-ihdr im))) (color-type (ihdr-color-type (png-image-ihdr im)))) (+ 1 (ceiling (* width (ecase color-type (0 bit-depth) (2 (* 3 bit-depth)) (3 bit-depth) (4 (* 2 bit-depth)) (6 (* 4 bit-depth)))) 8)) )) (defun paeth-predictor (a b c) (let* ((p (- (+ a b) c)) ;initial estimate (pa (abs (- p a))) ;distances to a, b, c (pb (abs (- p b))) (pc (abs (- p c)))) ;; return nearest of a,b,c, ;; breaking ties in order a,b,c. (cond ((and (<= pa pb) (<= pa pc)) a) ((<= pb pc) b) (t c) ) )) (defun apply-png-filter (filter data j j0 len bpp) (dotimes (x len) (let ((raw (aref data (+ j x))) (above (if j0 (aref data (+ j0 x)) 0)) (left (if (>= (- x bpp) 0) (aref data (+ j x (- bpp))) 0)) (left-above (if (and j0 (>= (- x bpp) 0)) (aref data (+ j0 x (- bpp))) 0))) (setf (aref data (+ j x)) (ecase filter (0 raw) (1 (logand #xFF (+ raw left))) (2 (logand #xFF (+ raw above))) (3 (logand #xFF (+ raw (floor (+ left above) 2)))) (4 (logand #xFF (+ raw (paeth-predictor left above left-above)) ))))))) (defun png-image-bits-per-pixel (im) (let ((bit-depth (ihdr-bit-depth (png-image-ihdr im))) (color-type (ihdr-color-type (png-image-ihdr im)))) (ecase color-type (0 bit-depth) (2 (* 3 bit-depth)) (3 bit-depth) (4 (* 2 bit-depth)) (6 (* 4 bit-depth))))) (defun png-image-bytes-per-pixel (im) (ceiling (png-image-bits-per-pixel im) 8)) (defsubst get-sample (data i j bit-depth) (ecase bit-depth (1 (ldb (byte 1 (- 7 (mod i 8))) (aref data (+ (floor i 8) j)))) (2 (ldb (byte 2 (* 2 (- 3 (mod i 4)))) (aref data (+ (floor i 4) j)))) (4 (ldb (byte 4 (* 4 (- 1 (mod i 2)))) (aref data (+ (floor i 2) j)))) (8 (aref data (+ i j))) (16 (logior (ash (aref data (+ (* 2 i) j)) 8) (aref data (+ (* 2 i) 1 j)))) )) (defsubst get-sample* (data i j bit-depth) (ecase bit-depth (1 (* 255 (get-sample data i j bit-depth))) (2 (* 85 (get-sample data i j bit-depth))) (4 (* 17 (get-sample data i j bit-depth))) (8 (get-sample data i j bit-depth)) (16 (ldb (byte 8 8) (get-sample data i j bit-depth))) )) (defun render-filtered-row (im bit-depth color-type data j y x0 dx width pw ph put-pixel) (cu:declared-type-variants (bit-depth (member 1) (member 2) (member 4) (member 8) (member 16)) (cu:declared-type-variants (color-type (member 0) (member 2) (member 3) (member 4) (member 6)) (do ((x x0 (+ x dx)) (i 0 (+ i 1))) ((>= x width)) (ecase color-type (0 (let ((v (get-sample* data i (+ j 1) bit-depth))) (funcall put-pixel x y v v v 255 pw ph))) (2 (let ((r (get-sample* data (+ 0 (* 3 i)) (+ j 1) bit-depth)) (g (get-sample* data (+ 1 (* 3 i)) (+ j 1) bit-depth)) (b (get-sample* data (+ 2 (* 3 i)) (+ j 1) bit-depth))) (funcall put-pixel x y r g b 255 pw ph))) (3 (let* ((i (get-sample data i (+ j 1) bit-depth)) (p (aref (png-image-plte im) i))) (funcall put-pixel x y (aref p 0) (aref p 1) (aref p 2) (aref p 3) pw ph))) (4 (let ((v (get-sample* data (+ 0 (* i 2)) (+ j 1) bit-depth)) (a (get-sample* data (+ 1 (* i 2)) (+ j 1) bit-depth))) (funcall put-pixel x y v v v a pw ph))) (6 (let ((r (get-sample* data (+ 0 (* 4 i)) (+ j 1) bit-depth)) (g (get-sample* data (+ 1 (* 4 i)) (+ j 1) bit-depth)) (b (get-sample* data (+ 2 (* 4 i)) (+ j 1) bit-depth)) (a (get-sample* data (+ 3 (* 4 i)) (+ j 1) bit-depth))) (funcall put-pixel x y r g b a pw ph))) ) )))) (defun render-png-image-to-aimage (im) (let* ((bpp (png-image-bytes-per-pixel im)) (data (png-image-idat im)) (bit-depth (ihdr-bit-depth (png-image-ihdr im))) (width (ihdr-width (png-image-ihdr im))) (height (ihdr-height (png-image-ihdr im))) (color-type (ihdr-color-type (png-image-ihdr im))) (res (make-array (list height width 4) :element-type '(unsigned-byte 8)))) (labels ((put-pixel (x y r g b a pw ph) pw ph a (setf (aref res y x 0) r (aref res y x 1) g (aref res y x 2) b (aref res y x 3) a))) (case (ihdr-interlace-method (png-image-ihdr im)) (0 (let ((row-len (png-image-row-length im))) (do ((y 0 (+ y 1)) (j 0 (+ j row-len)) (j0 nil j)) ((>= j (length data))) (apply-png-filter (aref data j) data (+ j 1) (if j0 (+ j0 1) nil) (1- row-len) bpp) (render-filtered-row im bit-depth color-type data j y 0 1 width 1 1 #'put-pixel)))) (1 (let (j0 (j 0)) (do ((pass 7 (- pass 1))) ((< pass 1)) (let* ((y0 (aref '#(0 1 0 2 0 4 0 0) pass)) (x0 (aref '#(0 0 1 0 2 0 4 0) pass)) (dy (aref '#(1 2 2 4 4 8 8 8) pass)) (ph (aref '#(1 1 2 2 4 4 8 8) pass)) (dx (aref '#(1 1 2 2 4 4 8 8) pass)) (pw (aref '#(1 1 1 2 2 4 4 8) pass)) ) (let ((row-len (+ 1 (ceiling (* (png-image-bits-per-pixel im) (ceiling (- width x0) dx)) 8)))) (setf j0 nil) (when (> row-len 1) (do ((y y0 (+ y dy))) ((>= y height)) (apply-png-filter (aref data j) data (+ j 1) (if j0 (+ j0 1) nil) (1- row-len) bpp) (render-filtered-row im bit-depth color-type data j y x0 dx width pw ph #'put-pixel) (psetf j (+ j row-len) j0 j)))))) (assert (= j (length data))) )) (t (error "Unknown interlace method: ~D." (ihdr-interlace-method (png-image-ihdr im)))) )) res)) (defun png-stream-to-aimage (stream) (render-png-image-to-aimage (read-png-image stream))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Experimental/pixel-format.lisp0000644000175000017500000007161507435065660022761 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-INTERNALS; -*- ;;; -------------------------------------------------------------------------------------- ;;; Title: Pixel translation ;;; Created: 2001-07-14 ;;; Author: Gilbert Baumann ;;; License: LGPL (See file COPYING for details). ;;; $Id: pixel-format.lisp,v 1.2 2002/02/21 03:38:24 gilbert Exp $ ;;; -------------------------------------------------------------------------------------- ;;; (c) copyright 2001 by Gilbert Baumann ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;;; Changes ;; $Log: pixel-format.lisp,v $ ;; Revision 1.2 2002/02/21 03:38:24 gilbert ;; Uses DEFINE-PROTOCOL-CLASS now. ;; ;; COMPOSE-PIXEL ;; New function for the lazy. ;; ;;;; (in-package :clim-internals) (defparameter *code-optimization* '(optimize (safety 0) (space 0) (speed 3) (debug 0)) "Code optimization level within pixel translation code.") ;; A pixel format is the representation of such an easy concept as an ;; RGBA quadruple. Such an representation is called a »sample« here. ;; Things are made harder by various formats for this information and ;; by the possible need to dither colors on some devices. ;; We define a new [protocol] class named PIXEL-FORMAT and their ;; subclasses INPUT-PIXEL-FORMAT, which denotes a pixel format ;; suitable to converting a sample to an RGBA quadruple and ;; PIXEL-OUTPUT-FORMAT suitable for converting an RGBA quadruple to a ;; sample. IO-PIXEL-FORMAT then is the union of both. ;; Some pixel formats may dither and thus [output] conversion may ;; depend on the x/y coördinate pair of the pixel. Others are ;; »uniform«, that is they do not depend on the coördinate of the ;; pixel. ;; What we finally want to achieve is to have some function: ;; CONVERT-PIXELS input-array input-format output-array output-format ;; Which converts pixels stored in some format to pixels stored in ;; some other format. And: This functions should be as fast as ;; possible. We achieve the speed by not calling some generic function ;; on the pixel-format for each pixel to do the conversion, but by ;; compiling the actual conversion code. Compilation takes place in ;; run-time, which allows us to write rather general code and still ;; adopt to all those weird X11 visual classes. ;; So we have: ;; PIXEL-FORMAT [class] ;; INPUT-PIXEL-FORMAT [class] ;; OUTPUT-PIXEL-FORMAT [class] ;; IO-PIXEL-FORMAT [class] (define-protocol-class pixel-format () ((composer :initform nil))) (define-protocol-class input-pixel-format (pixel-format) ()) (define-protocol-class output-pixel-format (pixel-format) ()) (define-protocol-class io-pixel-format (input-pixel-format output-pixel-format) ()) (define-protocol-class uniform-pixel-format () () ;; Mixin class for uniform pixel formats ) (define-protocol-class non-uniform-pixel-format () () ;; Mixin class for non-uniform pixel formats ) ;; and their predicates ;; The protocol (defgeneric pixel-decomposing-code (pixel-format) ;; Convert a sample to an RGBA quadruple. ;; ;; Returns code, which represents F. ;; F: context sample -> r g b a ) (defgeneric pixel-composing-code (pixel-format) ;; Convert an RGBA quadruple to a sample. ;; ;; Returns code, which represents F. ;; F: context R G B A x y -> sample ) (defgeneric pixel-format-element-type (pixel-format) ;; Returns *the* element-type used for arrays containing images made ;; out of pixel in this particular format. ) (defgeneric pixel-format-maximum-component-values (pixel-format) ;; Returns four values ;; - maximum value of red component ;; - maximum value of green component ;; - maximum value of blue component ;; - maximum value of alpha component ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; Some Utilities ;;;; (defun pixel-format-red-max (pixel-format) (nth-value 0 (pixel-format-maximum-component-values pixel-format))) (defun pixel-format-green-max (pixel-format) (nth-value 1 (pixel-format-maximum-component-values pixel-format))) (defun pixel-format-blue-max (pixel-format) (nth-value 2 (pixel-format-maximum-component-values pixel-format))) (defun pixel-format-alpha-max (pixel-format) (nth-value 3 (pixel-format-maximum-component-values pixel-format))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; Direct Pixel Formats ;;;; ;;;; True Color (defvar *make-pixel-format-instance/unique-table* (make-hash-table :test #'equal)) (defclass true-color-pixel-format (io-pixel-format uniform-pixel-format) ((red-byte :reader true-color-pixel-format-red-byte :initarg :red-byte) (green-byte :reader true-color-pixel-format-green-byte :initarg :green-byte) (blue-byte :reader true-color-pixel-format-blue-byte :initarg :blue-byte) (alpha-byte :reader true-color-pixel-format-alpha-byte :initarg :alpha-byte) (red-max :initarg :red-max) (green-max :initarg :green-max) (blue-max :initarg :blue-max) (alpha-max :initarg :alpha-max) (element-type :reader pixel-format-element-type :initarg :element-type))) (defmethod pixel-format-maximum-component-values ((pixel-format true-color-pixel-format)) (with-slots (red-max green-max blue-max alpha-max) pixel-format (values red-max green-max blue-max alpha-max))) (defun make-true-color-pixel-format (&key (red-byte (error "~S is a required argument" :red-byte)) (green-byte (error "~S is a required argument" :green-byte)) (blue-byte (error "~S is a required argument" :blue-byte)) (alpha-byte (byte 0 0)) (red-max (1- (expt 2 (byte-size red-byte)))) (green-max (1- (expt 2 (byte-size green-byte)))) (blue-max (1- (expt 2 (byte-size blue-byte)))) (alpha-max (1- (expt 2 (byte-size alpha-byte)))) (element-type `(unsigned-byte ,(max (+ (byte-size red-byte) (byte-position red-byte)) (+ (byte-size green-byte) (byte-position green-byte)) (+ (byte-size blue-byte) (byte-position blue-byte)) (+ (byte-size alpha-byte) (byte-position alpha-byte)))))) (make-pixel-format-instance 'true-color-pixel-format :red-byte red-byte :green-byte green-byte :blue-byte blue-byte :alpha-byte alpha-byte :red-max red-max :green-max green-max :blue-max blue-max :alpha-max alpha-max :element-type element-type)) (defun make-pixel-format-instance (&rest args) (or (gethash args *make-pixel-format-instance/unique-table*) (setf (gethash args *make-pixel-format-instance/unique-table*) (apply #'make-instance args)))) (defmethod pixel-decomposing-code ((pf true-color-pixel-format)) (with-slots (red-byte green-byte blue-byte alpha-byte red-max green-max blue-max alpha-max element-type) pf `(lambda (context sample) (declare (ignore context) (type ,element-type sample)) (values (ldb (byte ,(byte-size red-byte) ,(byte-position red-byte)) sample) (ldb (byte ,(byte-size green-byte) ,(byte-position green-byte)) sample) (ldb (byte ,(byte-size blue-byte) ,(byte-position blue-byte)) sample) ,(if (= 0 (byte-size alpha-byte)) 0 `(ldb (byte ,(byte-size alpha-byte) ,(byte-position alpha-byte)) sample)))) )) (defmethod pixel-composing-code ((pf true-color-pixel-format)) (with-slots ((red-max red-max) (green-max green-max) (blue-max blue-max) (alpha-max alpha-max) red-byte green-byte blue-byte alpha-byte element-type) pf `(lambda (context r g b a x y) (declare (ignore x y) (ignore context) (ignorable a) (type (integer 0 ,red-max) r) (type (integer 0 ,green-max) g) (type (integer 0 ,blue-max) b) (type (integer 0 ,alpha-max) a)) (the ,element-type (dpb r (byte ,(byte-size red-byte) ,(byte-position red-byte)) (dpb g (byte ,(byte-size green-byte) ,(byte-position green-byte)) (dpb b (byte ,(byte-size blue-byte) ,(byte-position blue-byte)) ,(if (= (byte-size alpha-byte) 0) ;; no alpha here 0 ;; else also deposit the alpha value `(dpb a (byte ,(byte-size alpha-byte) ,(byte-position alpha-byte)) 0))))) )))) ;;;; Gray Scale (defclass gray-scale-pixel-format (io-pixel-format uniform-pixel-format) ((gray-byte :reader gray-scale-pixel-format-gray-byte :initarg :gray-byte) (alpha-byte :reader gray-scale-pixel-format-alpha-byte :initarg :alpha-byte) (gray-max :reader gray-scale-pixel-format-gray-max :initarg :gray-max) (alpha-max :initarg :alpha-max) (element-type :reader pixel-format-element-type :initarg :element-type) )) (defmethod pixel-format-maximum-component-values ((pixel-format gray-scale-pixel-format)) (values (gray-scale-pixel-format-gray-max pixel-format) (gray-scale-pixel-format-gray-max pixel-format) (gray-scale-pixel-format-gray-max pixel-format) 0)) (defun make-gray-scale-pixel-format (&key (gray-byte (error "~S is a required argument" :gray-byte)) (alpha-byte (byte 0 0)) (gray-max (1- (expt 2 (byte-size gray-byte)))) (alpha-max (1- (expt 2 (byte-size alpha-byte)))) (element-type `(unsigned-byte ,(max (+ (byte-size gray-byte) (byte-position gray-byte)) (+ (byte-size alpha-byte) (byte-position alpha-byte)))))) (make-pixel-format-instance 'gray-scale-pixel-format :gray-byte gray-byte :alpha-byte alpha-byte :gray-max gray-max :alpha-max alpha-max :element-type element-type)) (defmethod pixel-decomposing-code ((pf gray-scale-pixel-format)) (with-slots (alpha-byte gray-byte) pf `(lambda (context sample) (declare (ignore context) (type ,(pixel-format-element-type pf) sample)) ,(cond ((= 0 (byte-size alpha-byte)) `(values sample sample sample 0)) (t `(let ((s (ldb (byte ,(byte-size gray-byte) ,(byte-position gray-byte)) sample))) (values s s s (ldb (byte ,(byte-size alpha-byte) ,(byte-position alpha-byte)) sample)))))))) (defmethod pixel-composing-code ((pf gray-scale-pixel-format)) (with-slots (gray-byte gray-max alpha-byte alpha-max) pf (let ((max gray-max)) (assert (= max (pixel-format-red-max pf) (pixel-format-green-max pf) (pixel-format-blue-max pf))) `(lambda (context r g b a x y) (declare (ignore x y context) (ignorable a) (type (integer 0 ,max) r g b) (type (integer 0 ,alpha-max) a)) (let ((lum (floor (the (integer 0 ,(* 1024 max)) (+ (* 307 r) (* 599 g) (* 118 b))) 1024))) (declare (type (integer 0 ,max) lum)) (logior (ash lum ,(byte-position gray-byte)) ,(if (> (byte-size alpha-byte) 0) `(ash a ,(byte-position alpha-byte)) 0))))))) ;;;; CLIM:COLOR (defmethod pixel-format-maximum-component-values ((pixel-format (eql 'clim:color))) (values #xFFFF #xFFFF #xFFFF 0)) (defmethod pixel-decomposing-code ((pixel-format (eql 'clim:color))) `(lambda (context sample) (declare (ignore context)) (multiple-value-bind (r g b) (color-rgb sample) (values (floor (* ,(pixel-format-red-max pixel-format) r)) (floor (* ,(pixel-format-green-max pixel-format) g)) (floor (* ,(pixel-format-blue-max pixel-format) b)) 0)))) (defmethod pixel-composing-code ((pixel-format (eql 'clim:color))) (multiple-value-bind (rmax gmax bmax) (pixel-format-maximum-component-values pixel-format) `(lambda (context r g b a x y) (declare (ignore context a x y) (type (integer 0 ,rmax) r) (type (integer 0 ,gmax) g) (type (integer 0 ,bmax) b)) (make-rgb-color (/ r ,(coerce rmax 'short-float)) (/ g ,(coerce gmax 'short-float)) (/ b ,(coerce bmax 'short-float)))))) (defmethod pixel-format-element-type ((pixel-format (eql 'clim:color))) 'clim:color) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; Dithers ;;;; (defclass color-dithering-pixel-format (output-pixel-format non-uniform-pixel-format) ((output-format :initarg :output-format) (red-max :initarg :red-max :initform 255) (green-max :initarg :green-max :initform 255) (blue-max :initarg :blue-max :initform 255) (alpha-max :initarg :alpha-max :initform 0))) (defmethod pixel-format-maximum-component-values ((pf color-dithering-pixel-format)) (with-slots (red-max green-max blue-max alpha-max) pf (values red-max green-max blue-max alpha-max))) (defconstant +dither-map+ '#2A(( 0 48 12 60 3 51 15 63) (32 16 44 28 35 19 47 31) ( 8 56 4 52 11 59 7 55) (40 24 36 20 43 27 39 23) ( 2 50 14 62 1 49 13 61) (34 18 46 30 33 17 45 29) (10 58 6 54 9 57 5 53) (42 26 38 22 41 25 37 21))) (defmethod pixel-composing-code ((pf color-dithering-pixel-format)) (with-slots (red-max green-max blue-max alpha-max output-format) pf (multiple-value-bind (ormax ogmax obmax oamax) (pixel-format-maximum-component-values output-format) `(lambda (context r g b a x y) (declare (ignorable a) (type (integer 0 ,red-max) r) (type (integer 0 ,green-max) g) (type (integer 0 ,blue-max) b) (type (integer 0 ,alpha-max) a)) (,(pixel-composing-code output-format) context (,(generic-ditherer (1+ ormax) red-max) x y r) (,(generic-ditherer (1+ ogmax) green-max) x y g) (,(generic-ditherer (1+ obmax) blue-max) x y b) ,(if (= 0 oamax) 0 `(,(generic-ditherer (1+ oamax) alpha-max) x y a)) x y))))) (defmethod pixel-format-element-type ((pf color-dithering-pixel-format)) (with-slots (output-format) pf (pixel-format-element-type output-format))) (defun generic-ditherer (m maxval) (let ((table-size (1+ maxval))) (let ((table (make-array (list 8 8 table-size)))) (dotimes (x 8) (dotimes (y 8) (dotimes (s table-size) (multiple-value-bind (c0 delta) (floor (* s (1- m)) maxval) (setf (aref table x y s) (min (1- m) (if ;; (<= (/ delta maxval) (/ (aref +dither-map+ x y) 64)) (<= (* 64 delta) (* maxval (aref +dither-map+ x y))) c0 (+ c0 1)))))))) `(lambda (x y s) (the fixnum (aref (the (simple-array t (8 8 ,table-size)) ',table) (the fixnum (logand #x7 x)) (the fixnum (logand #x7 y)) (the fixnum s) )))))) ;;; gray ditherer (defclass gray-dithering-pixel-format (output-pixel-format non-uniform-pixel-format) ((output-format :initarg :output-format) (gray-max :initarg :gray-max :initform 255) (alpha-max :initarg :alpha-max :initform 0))) (defmethod pixel-format-maximum-component-values ((pf gray-dithering-pixel-format)) (with-slots (gray-max alpha-max) pf (values gray-max gray-max gray-max alpha-max))) (defmethod pixel-composing-code ((pf gray-dithering-pixel-format)) (with-slots (gray-max alpha-max output-format) pf (multiple-value-bind (ormax ogmax obmax oamax) (pixel-format-maximum-component-values output-format) `(lambda (context r g b a x y) (declare (ignorable a) (type (integer 0 ,gray-max) r g b) (type (integer 0 ,alpha-max) a)) (let ((gray (floor (the (integer 0 ,(* 1024 gray-max)) (+ (* 307 r) (* 599 g) (* 118 b))) 1024))) (,(pixel-composing-code output-format) context (,(generic-ditherer (1+ ormax) gray-max) x y gray) (,(generic-ditherer (1+ ogmax) gray-max) x y gray) (,(generic-ditherer (1+ obmax) gray-max) x y gray) ,(if (= 0 oamax) 0 `(,(generic-ditherer (1+ oamax) alpha-max) x y a)) x y)))))) (defmethod pixel-format-element-type ((pf gray-dithering-pixel-format)) (with-slots (output-format) pf (pixel-format-element-type output-format))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; Helper for RGB-Cubes ;;;; (defclass rgb-cube-output-pixel-format (output-pixel-format uniform-pixel-format) ((cube :initarg :cube) (element-type :initarg :element-type :reader pixel-format-element-type))) (defmethod pixel-format-maximum-component-values ((pf rgb-cube-output-pixel-format)) (with-slots (cube) pf (values (1- (array-dimension cube 0)) (1- (array-dimension cube 1)) (1- (array-dimension cube 2)) 0))) (defmethod pixel-composing-code ((pf rgb-cube-output-pixel-format)) (with-slots (cube) pf `(lambda (context r g b a x y) (declare (ignore context a x y) (type (integer 0 ,(array-dimension cube 0)) r) (type (integer 0 ,(array-dimension cube 1)) g) (type (integer 0 ,(array-dimension cube 2)) b)) (aref (the ,(type-of cube) ',cube) r g b)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; Generic Pixel Translator ;;;; (defmethod pixel-translating-code (input-pixel-format output-pixel-format) ;; generic pixel translator (multiple-value-bind (irmax igmax ibmax iamax) (pixel-format-maximum-component-values input-pixel-format) (multiple-value-bind (ormax ogmax obmax oamax) (pixel-format-maximum-component-values output-pixel-format) `(lambda (input-context output-context sample x y) (multiple-value-bind (r g b a) (,(pixel-decomposing-code input-pixel-format) input-context sample) (,(pixel-composing-code output-pixel-format) output-context (,(rescaling-code irmax ormax) r) (,(rescaling-code igmax ogmax) g) (,(rescaling-code ibmax obmax) b) (,(rescaling-code iamax oamax) a) x y)))))) (defun power-of-two-p (x) (= (logcount x) 1)) (defparameter *table-threshold* 256) (defun rescaling-code (input-max output-max) `(lambda (x) ,(cond ((= input-max output-max) 'x) ((and (< output-max input-max) (power-of-two-p (1+ output-max)) (power-of-two-p (1+ input-max))) ;; This already is an approximation? `(ash x ,(- (integer-length output-max) (integer-length input-max)))) ;; ((= input-max 0) ;; This prevents a divide by zero below and takes care of ;; missing alpha-channels. `',output-max) ;; table approach ((< input-max *table-threshold*) (let ((table (make-array (1+ input-max) :element-type `(integer 0 ,output-max)))) (loop for i from 0 to input-max do (setf (aref table i) (round (* output-max i) input-max))) `(aref (the ,(type-of table) ',table) x))) ;; (t (let ((q (/ output-max input-max))) `(floor (* ,(numerator q) x) ,(denominator q))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; Common Formats ;;;; (defconstant +RGB-8-format+ (make-true-color-pixel-format :red-byte (byte 8 16) :green-byte (byte 8 8) :blue-byte (byte 8 0))) (defconstant +BGR-8-format+ (make-true-color-pixel-format :red-byte (byte 8 0) :green-byte (byte 8 8) :blue-byte (byte 8 16))) (defconstant +gray-8-format+ (make-gray-scale-pixel-format :gray-byte (byte 8 0))) (defconstant +bitarray-format+ (make-gray-scale-pixel-format :gray-byte (byte 1 0))) (defmethod print-object ((x (eql +rgb-8-format+)) sink) (declare (ignorable x)) (format sink "#.~S" '+rgb-8-format+)) (defmethod print-object ((x (eql +bgr-8-format+)) sink) (declare (ignorable x)) (format sink "#.~S" '+bgr-8-format+)) (defmethod print-object ((x (eql +gray-8-format+)) sink) (declare (ignorable x)) (format sink "#.~S" '+gray-8-format+)) (defmethod print-object ((x (eql +bitarray-format+)) sink) (declare (ignorable x)) (format sink "#.~S" '+bitarray-format+)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; TODO ;;; - A pixel format needs some notion of a context. E.g. They might ;;; be indexed pixel formats, where the pixel translating code needs ;;; some access to the palette. ;;; - A pixel format also needs something like a base type. ;;; - The (type (unsigned-byte 16) x y) is considered harmful. ;;; - For more speed still, we want [sub]array translators ;;; - There are still assumptions that components are 8-bit wide. ;;; - There still is the question, if we should allocate the colormap ;;; entries, wenn we generate the pixel translator. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #|| (defmethod pixel-format-composer ((pf output-pixel-format)) (with-slots (composer) pf (or composer (setf composer (compile nil (multiple-value-bind (rmax gmax bmax amax) (pixel-format-maximum-component-values pf) `(lambda (context r g b a x y) (declare (type (unsigned-byte 8) r g b a) (type (unsigned-byte 16) x y) ,*code-optimization*) (,(pixel-composing-code pf) context (,(rescaling-code 255 rmax) r) (,(rescaling-code 255 gmax) g) (,(rescaling-code 255 bmax) b) (,(rescaling-code 255 amax) a) x y)))))))) (defmethod compose-standard-pixel ((pf output-pixel-format) r g b a x y) (with-slots (composer) pf (funcall (or composer (pixel-format-composer pf)) nil r g b a x y))) (let ((clim-color-composer nil)) (defmethod compose-standard-pixel ((pf (eql 'clim:color)) r g b a x y) (funcall (or clim-color-composer (setf clim-color-composer (compile nil (multiple-value-bind (rmax gmax bmax amax) (pixel-format-maximum-component-values pf) `(lambda (context r g b a x y) (declare (type (unsigned-byte 8) r g b a) (type (unsigned-byte 16) x y) ,*code-optimization*) (,(pixel-composing-code pf) context (,(rescaling-code 255 rmax) r) (,(rescaling-code 255 gmax) g) (,(rescaling-code 255 bmax) b) (,(rescaling-code 255 amax) a) x y)))))) nil r g b a x y))) ||# ;;; XXX (unsigned-byte 16) considered harmful. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; Pixel Format Cache ;;;; ;; Since compilation for pixel code is considered expensive, we cache ;; binary code. We cache the following functions: ;; - compose-pixel ;; - decompose-pixel ;; - translate-pixel ;; - translate-pixels ;; The user then has the following API: ;; TRANSLATE-PIXEL input-pixel-format output-pixel-format sample -> sample' ;; TRANSLATE-PIXELS input-pixel-format output-pixel-format source-array destination-array ;; and: ;; PIXEL-TRANSLATOR input-pixel-format output-pixel-format -> (sample -> sample) ;; PIXELS-TRANSLATOR input-pixel-format output-pixel-format -> (source-array destination-array ->) ;;(defclass spreaded-pixel-format ()) ;; A special pixel format. ;; Input samples are spreaded R,G,B,A tuples ;; Output samples are multiple values. (defvar *pixel-translator-cache* (make-hash-table :test #'equal)) (defvar *pixels-translator-cache* (make-hash-table :test #'equal)) (defmethod pixel-translator (input-pixel-format output-pixel-format) (or (gethash (list input-pixel-format output-pixel-format) *pixel-translator-cache*) (setf (gethash (list input-pixel-format output-pixel-format) *pixel-translator-cache*) (compile nil `(lambda (sample x y) (declare ,*code-optimization*) (declare (type fixnum x y)) ;xxx (,(pixel-translating-code input-pixel-format output-pixel-format) nil nil sample x y)) )))) (defmethod pixels-translator (input-pixel-format output-pixel-format) (or (gethash (list input-pixel-format output-pixel-format) *pixels-translator-cache*) (setf (gethash (list input-pixel-format output-pixel-format) *pixels-translator-cache*) (compile nil `(lambda (source-array source-start source-skip dest-array dest-start dest-skip width height x0 y0) (let ((source-ptr source-start) (dest-ptr dest-start)) (loop for y from y0 below (+ y0 height) do (loop for i from 0 below width do (setf (row-major-aref dest-array (+ dest-ptr i)) (,(pixel-translating-code input-pixel-format output-pixel-format) nil nil (row-major-aref source-array (+ source-ptr i)) (+ x0 i) y))) (incf source-ptr source-skip) (incf dest-ptr dest-skip)))) )))) (defun translate-pixel (input-pixel-format output-pixel-format sample &optional (x 0) (y 0)) (funcall (pixel-translator input-pixel-format output-pixel-format) sample x y)) (defun translate-pixels (input-pixel-format input-array output-pixel-format output-array &optional (x0 0) (y0 0)) (funcall (pixels-translator input-pixel-format output-pixel-format) input-array 0 (array-dimension input-array 1) output-array 0 (array-dimension output-array 1) (array-dimension input-array 1) (array-dimension input-array 0) x0 y0)) ;;;;; (defmethod compose-pixel ((pixel-format pixel-format) red green blue opacity x y) (funcall (or (slot-value pixel-format 'composer) (setf (slot-value pixel-format 'composer) (compile nil (pixel-composing-code pixel-format)))) nil red green blue opacity x y))cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Experimental/pointer-doc-hack.lisp0000644000175000017500000004242511345155772023475 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2003 by Andy Hefner (andy.hefner@verizon.net) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; This hack gives you pretty graphical icons in the pointer documentation. (in-package :clim-internals) (defparameter *data-mouse-left* '( #2A((0 0 0 0 0 1 1 1 2 3 4 5 6 7 8 9 10 0 0 0 0 0) (0 0 0 11 12 13 14 15 16 17 18 19 20 21 22 22 23 24 25 0 0 0) (0 0 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 0 0) (0 1 44 45 46 47 48 31 49 19 50 51 19 37 52 53 54 55 41 56 57 0) (1 58 59 60 61 62 63 64 65 66 50 19 67 68 41 69 66 70 71 72 73 74) (1 75 76 77 78 79 80 81 82 36 83 83 67 68 84 85 85 16 85 86 87 88) (89 90 91 92 93 94 95 81 69 50 50 51 67 40 96 97 98 99 100 101 102 103) (104 105 106 107 108 109 110 111 112 69 82 113 113 114 115 116 117 41 23 118 102 43) (104 119 120 121 122 123 81 31 124 49 17 124 125 21 96 16 86 22 126 127 87 43) (128 129 130 121 131 132 65 113 82 53 71 133 69 112 125 41 134 135 136 56 137 25) (1 138 139 121 121 140 67 33 121 121 83 36 50 132 141 37 84 142 136 143 144 145) (146 52 147 121 121 54 83 121 148 148 121 36 50 67 53 149 116 16 126 87 150 25) (151 98 121 121 121 152 83 121 148 148 121 19 51 67 53 65 85 153 22 154 155 25) (156 97 157 121 121 55 36 121 148 148 121 33 66 71 82 114 21 41 49 115 56 25) (74 115 158 121 159 160 33 121 148 148 121 50 67 133 20 49 96 85 34 66 161 145) (162 134 36 34 163 18 66 121 148 148 121 67 164 82 40 85 41 165 121 166 167 43) (0 25 96 33 33 70 133 121 148 148 121 168 53 112 49 32 85 169 121 170 171 0) (0 25 172 116 17 17 20 121 148 148 121 113 65 124 32 16 124 173 168 174 145 0) (0 0 24 142 175 21 98 121 148 148 121 121 121 121 153 38 16 175 136 176 0 0) (0 0 176 118 134 170 177 121 148 148 148 148 148 148 121 126 178 179 180 181 0 0) (0 0 0 182 183 184 185 121 148 148 148 148 148 148 121 186 187 5 171 0 0 0) (0 0 0 0 188 136 189 121 121 121 121 121 121 121 136 143 5 176 0 0 0 0) (0 0 0 0 0 190 7 191 135 127 127 189 186 191 73 192 176 0 0 0 0 0) (0 0 0 0 0 0 0 8 7 193 193 2 9 190 194 0 0 0 0 0 0 0)) #(0 0 0 163 122 34 81 81 81 86 86 86 89 89 89 91 91 91 90 90 90 85 85 85 82 82 82 78 78 78 73 73 73 160 119 34 155 113 31 218 139 11 244 147 4 252 150 0 146 146 146 167 167 167 197 197 197 194 194 194 173 173 173 157 157 157 135 135 135 132 132 132 71 71 71 63 63 63 153 113 32 206 131 17 222 147 30 238 173 72 247 157 23 255 152 0 155 155 155 192 192 192 230 230 230 232 232 232 195 195 195 165 165 165 140 140 140 153 153 153 169 169 169 148 148 148 115 115 115 61 61 61 209 133 17 226 144 16 244 196 124 250 216 164 250 189 99 163 163 163 193 193 193 191 191 191 144 144 144 180 180 180 208 208 208 201 201 201 105 105 105 59 59 59 232 142 7 233 148 17 250 162 29 255 182 71 255 161 25 255 160 15 255 154 0 170 170 170 190 190 190 188 188 188 168 168 168 176 176 176 183 183 183 185 185 185 125 125 125 96 96 96 53 53 53 229 144 14 255 165 28 255 198 53 255 209 58 255 179 23 255 162 1 255 156 0 178 178 178 196 196 196 150 150 150 159 159 159 141 141 141 106 106 106 56 56 56 162 121 34 224 148 25 255 196 53 255 255 112 255 255 113 255 201 25 255 169 0 152 152 152 161 161 161 162 162 162 147 147 147 134 134 134 124 124 124 107 107 107 58 58 58 157 117 33 240 164 36 255 249 105 255 255 201 255 255 157 255 197 16 255 166 0 255 153 0 171 171 171 174 174 174 166 166 166 154 154 154 158 158 158 156 156 156 120 120 120 255 177 40 255 255 166 255 255 255 255 255 198 255 176 7 164 164 164 160 160 160 126 126 126 119 119 119 160 119 33 255 182 24 255 255 203 255 255 219 186 186 186 182 182 182 137 137 137 122 122 122 113 113 113 102 102 102 255 179 0 255 255 248 202 202 202 177 177 177 130 130 130 98 98 98 92 92 92 64 64 64 48 48 48 247 247 247 211 137 0 172 172 172 99 99 99 50 50 50 205 205 205 145 145 145 123 123 123 100 100 100 49 49 49 240 240 240 220 220 220 239 239 239 199 199 199 112 112 112 54 54 54 221 221 221 184 184 184 179 179 179 175 175 175 95 95 95 181 181 181 215 215 215 143 143 143 68 68 68 131 131 131 229 229 229 101 101 101 149 149 149 70 70 70 151 151 151 121 121 121 111 111 111 88 88 88 65 65 65 75 75 75 118 118 118 133 133 133 139 139 139 114 114 114 109 109 109 80 80 80 117 117 117 79 79 79 110 110 110 77 77 77 83 83 83 74 74 74))) (defparameter *data-mouse-middle* '( #2A((0 0 0 0 0 1 2 3 3 3 3 3 3 3 3 4 5 0 0 0 0 0) (0 0 0 6 7 8 9 10 10 11 12 13 10 10 10 14 15 16 1 0 0 0) (0 0 17 18 19 20 21 22 22 23 24 25 26 22 22 27 28 29 30 31 0 0) (0 32 18 33 34 35 36 22 22 37 38 39 40 41 41 42 43 44 29 45 7 0) (32 46 47 48 49 50 51 52 22 53 53 53 53 22 41 54 55 56 57 58 59 17) (32 9 60 42 61 62 63 64 22 53 53 53 53 22 22 65 65 66 65 19 67 68) (69 70 71 72 73 74 62 75 22 53 53 53 53 22 22 76 77 48 70 8 78 79) (80 48 81 73 73 82 36 83 22 53 53 53 53 22 22 84 85 29 15 86 78 31) (69 87 73 73 73 62 88 22 22 22 22 22 22 22 22 66 19 14 9 89 67 31) (32 84 73 73 90 91 88 50 92 42 57 63 54 93 87 29 94 95 96 45 97 1) (32 48 98 73 73 99 100 36 101 102 102 103 34 91 101 104 105 33 96 106 107 108) (32 109 110 73 73 43 102 101 111 112 102 103 34 101 111 112 84 66 9 67 113 1) (114 77 73 73 73 115 101 111 112 111 112 116 101 111 112 111 112 117 14 118 119 1) (120 76 121 73 73 44 101 111 101 111 112 36 101 111 101 111 112 29 122 21 45 1) (17 21 123 73 124 125 126 111 101 111 112 34 101 111 101 111 112 65 74 55 127 108) (128 94 103 74 129 130 131 112 55 101 111 101 111 112 28 101 111 132 73 133 134 31) (0 1 135 36 36 136 111 112 137 101 111 101 111 112 122 101 138 139 73 60 140 0) (0 1 47 84 51 141 111 112 92 92 101 111 112 142 143 126 144 73 145 146 108 0) (0 0 16 33 147 101 111 112 51 148 101 111 112 143 117 149 150 151 96 152 0 0) (0 0 152 86 94 112 111 112 143 84 101 111 112 60 15 126 153 154 155 156 0 0) (0 0 0 157 158 159 112 19 60 109 60 112 14 15 118 18 112 160 140 0 0 0) (0 0 0 0 161 96 162 163 33 33 33 164 8 89 96 106 160 152 0 0 0 0) (0 0 0 0 0 165 166 167 95 89 89 162 18 167 59 168 152 0 0 0 0 0) (0 0 0 0 0 0 0 169 166 170 170 171 4 165 172 0 0 0 0 0 0 0)) #(3 3 3 63 63 63 69 69 69 15 127 219 78 78 78 73 73 73 55 55 55 59 59 59 124 124 124 126 126 126 37 145 247 39 146 247 104 179 249 93 173 249 135 135 135 132 132 132 71 71 71 53 53 53 114 114 114 141 141 141 172 172 172 154 154 154 68 158 255 111 180 255 190 221 255 195 224 255 106 177 255 153 153 153 169 169 169 148 148 148 115 115 115 61 61 61 48 48 48 130 130 130 193 193 193 218 218 218 192 192 192 98 173 255 81 164 255 79 163 255 94 171 255 69 158 255 180 180 180 208 208 208 201 201 201 105 105 105 111 111 111 131 131 131 147 147 147 179 179 179 174 174 174 167 167 167 69 160 255 43 166 255 176 176 176 190 190 190 183 183 183 185 185 185 125 125 125 96 96 96 143 143 143 203 203 203 197 197 197 182 182 182 70 163 255 159 159 159 146 146 146 106 106 106 56 56 56 47 47 47 134 134 134 173 173 173 235 235 235 255 255 255 230 230 230 69 162 255 161 161 161 162 162 162 107 107 107 58 58 58 46 46 46 211 211 211 229 229 229 68 159 255 158 158 158 156 156 156 120 120 120 160 160 160 170 170 170 119 119 119 254 254 254 186 186 186 178 178 178 171 171 171 137 137 137 122 122 122 113 113 113 102 102 102 234 234 234 202 202 202 188 188 188 193 210 255 196 196 196 195 195 195 165 165 165 150 150 150 98 98 98 92 92 92 64 64 64 144 144 144 247 247 247 50 125 255 150 183 255 99 99 99 50 50 50 205 205 205 194 194 194 145 145 145 123 123 123 100 100 100 49 49 49 240 240 240 163 163 163 220 220 220 239 239 239 199 199 199 194 211 255 112 112 112 54 54 54 221 221 221 209 227 255 50 126 255 198 242 255 175 175 175 95 95 95 152 152 152 202 220 255 187 187 187 56 141 255 252 255 255 68 68 68 195 212 255 164 164 164 155 155 155 61 154 255 181 181 181 101 101 101 149 149 149 168 168 168 197 215 255 58 145 255 196 240 255 70 70 70 52 130 255 156 191 255 88 88 88 65 65 65 75 75 75 118 118 118 133 133 133 91 91 91 80 80 80 117 117 117 129 129 129 127 127 127 79 79 79 85 85 85 110 110 110 77 77 77 82 82 82 83 83 83 81 81 81 74 74 74))) (defparameter *data-mouse-right* '( #2A((0 0 0 0 0 1 2 3 4 5 6 7 8 9 10 10 10 0 0 0 0 0) (0 0 0 11 12 13 14 15 16 17 18 19 20 21 22 22 22 10 10 0 0 0) (0 0 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 10 0 0) (0 40 24 41 42 43 30 44 45 19 42 46 19 34 47 48 49 50 51 52 10 0) (40 53 54 44 55 56 17 29 57 58 42 19 59 60 61 62 63 64 65 66 39 10) (40 14 67 68 69 18 70 34 71 33 72 72 59 60 73 74 75 76 77 78 39 10) (79 80 20 81 82 31 18 17 83 42 42 46 59 84 73 85 86 87 88 89 90 10) (91 44 92 82 82 93 30 34 94 83 71 56 56 95 73 73 96 97 98 99 90 10) (79 100 82 82 82 18 57 34 101 45 17 101 100 21 73 73 102 103 104 105 106 10) (40 107 82 82 108 109 57 56 71 68 110 70 83 94 100 111 73 73 112 89 39 10) (40 44 113 82 82 114 59 115 115 115 115 115 115 115 116 34 117 41 35 22 39 10) (40 118 119 82 82 120 72 115 10 10 10 10 10 10 115 26 107 16 14 121 122 1) (123 124 82 82 82 125 72 115 10 10 10 10 10 10 10 115 126 127 128 129 130 1) (131 132 133 82 82 134 33 115 10 10 115 115 115 10 10 115 21 111 45 27 135 1) (23 27 136 82 137 138 30 115 10 10 115 115 115 10 10 115 139 126 31 58 140 141) (142 143 33 31 144 18 58 115 10 10 10 10 10 10 10 115 111 55 82 145 146 147) (0 1 139 30 30 148 70 115 10 10 10 10 10 10 115 29 126 149 82 67 150 0) (0 1 54 107 17 17 20 115 10 10 10 10 10 115 29 16 101 93 151 152 141 0) (0 0 153 41 154 21 124 115 10 10 115 10 10 10 115 155 16 154 156 157 0 0) (0 0 157 158 143 67 159 115 10 10 115 115 10 10 10 160 161 53 162 163 0 0) (0 0 0 3 164 165 28 115 10 10 115 155 115 10 10 115 166 7 150 0 0 0) (0 0 0 0 167 156 168 115 115 115 115 15 13 115 115 115 7 157 0 0 0 0) (0 0 0 0 0 169 9 170 171 172 172 168 24 170 173 174 157 0 0 0 0 0) (0 0 0 0 0 0 0 175 9 176 176 4 177 169 178 0 0 0 0 0 0 0)) #(3 3 3 63 63 63 69 69 69 75 75 75 81 81 81 86 86 86 89 89 89 91 91 91 90 90 90 85 85 85 90 6 216 55 55 55 59 59 59 124 124 124 126 126 126 127 127 127 146 146 146 167 167 167 197 197 197 194 194 194 173 173 173 157 157 157 136 57 255 53 53 53 114 114 114 141 141 141 172 172 172 154 154 154 139 139 139 155 155 155 192 192 192 230 230 230 232 232 232 195 195 195 165 165 165 143 45 255 147 53 255 157 93 255 147 75 255 114 20 255 48 48 48 130 130 130 193 193 193 218 218 218 147 147 147 163 163 163 191 191 191 143 52 254 175 110 253 202 160 254 198 159 255 143 67 254 112 23 246 111 111 111 131 131 131 179 179 179 174 174 174 170 170 170 190 190 190 188 188 188 168 168 168 145 62 253 168 102 252 180 122 253 180 124 253 185 139 253 126 41 255 143 143 143 180 180 180 203 203 203 182 182 182 178 178 178 196 196 196 153 92 255 151 86 253 147 67 253 141 56 253 162 99 254 149 81 254 47 47 47 134 134 134 235 235 235 255 255 255 176 176 176 169 169 169 153 91 255 152 82 255 144 62 255 141 58 255 136 56 255 115 21 255 46 46 46 211 211 211 229 229 229 171 171 171 166 166 166 153 88 255 148 74 255 141 57 255 132 47 255 160 160 160 164 164 164 151 91 253 150 85 255 143 55 255 133 51 255 114 21 255 158 158 158 254 254 254 186 186 186 185 185 185 148 148 148 143 51 254 234 234 234 202 202 202 220 202 247 177 177 177 150 150 150 144 144 144 247 247 247 208 208 208 106 106 106 99 99 99 50 50 50 162 162 162 205 205 205 159 159 159 145 145 145 135 135 135 123 123 123 100 100 100 49 49 49 161 161 161 240 240 240 201 201 201 105 105 105 220 220 220 239 239 239 199 199 199 152 152 152 112 112 112 64 64 64 54 54 54 137 137 137 221 221 221 175 175 175 95 95 95 61 61 61 183 183 183 215 215 215 68 68 68 181 181 181 101 101 101 71 71 71 149 149 149 140 140 140 113 113 113 70 70 70 120 120 120 151 151 151 221 203 248 121 121 121 88 88 88 65 65 65 118 118 118 133 133 133 109 109 109 80 80 80 117 117 117 79 79 79 110 110 110 122 122 122 119 119 119 96 96 96 77 77 77 82 82 82 83 83 83 78 78 78 74 74 74))) (defun kludge-design (data) (let* ((colormap (second data)) (designs (make-array (/ (length colormap ) 3)))) (loop for i from 0 below (/ (length colormap) 3) do (setf (aref designs i) (make-rgb-color (/ (aref colormap (+ 0 (* i 3))) 256.0) (/ (aref colormap (+ 1 (* i 3))) 256.0) (/ (aref colormap (+ 2 (* i 3))) 256.0)))) (make-pattern (first data) designs))) (defparameter *icon-mouse-left* (kludge-design *data-mouse-left*)) (defparameter *icon-mouse-middle* (kludge-design *data-mouse-middle*)) (defparameter *icon-mouse-right* (kludge-design *data-mouse-right*)) (defmethod frame-print-pointer-documentation ((frame standard-application-frame) input-context stream state event) (unless state (return-from frame-print-pointer-documentation nil)) (destructuring-bind (current-modifier new-translators) state (let ((x (device-event-x event)) (y (device-event-y event)) (pstream *pointer-documentation-output*)) (if (null new-translators) (when (and (background-message pstream) (not (record-on-display pstream (background-message pstream)))) (cond ((> (get-universal-time) (+ (background-message-time pstream) *background-message-minimum-lifetime*)) (setf (background-message pstream) nil)) (t (setf (output-record-parent (background-message pstream)) nil) (stream-add-output-record pstream (background-message pstream)) (replay (background-message pstream) pstream)))) (loop for (button presentation translator context) in new-translators for name = (cadr (assoc button +button-documentation+)) for first-one = t then nil do (progn (unless first-one (stream-increment-cursor-position pstream 12 0) #+nil(write-string "; " pstream)) (unless (zerop current-modifier) (print-modifiers pstream current-modifier :short) (write-string "-" pstream)) ;; Hefner's pointer-documentation hack. (setf name (cond ((eql button +pointer-left-button+) *icon-mouse-left*) ((eql button +pointer-middle-button+) *icon-mouse-middle*) ((eql button +pointer-right-button+) *icon-mouse-right*) (t name))) (if (not (typep name 'indexed-pattern)) (format pstream "~A: " name) (multiple-value-bind (x y) (stream-cursor-position pstream) (draw-pattern* pstream name x y) (stream-increment-cursor-position pstream 24 0))) (document-presentation-translator translator presentation (input-context-type context) *application-frame* event stream x y :stream pstream :documentation-type :pointer)) )) ;finally nil #+nil (when new-translators ; (write-char #\. pstream))) ;; Wasteful to do this after doing ;; find-innermost-presentation-context above... look at doing this ;; first and then doing the innermost test. (let ((all-translators (find-applicable-translators (stream-output-history stream) input-context *application-frame* stream x y :for-menu t)) (other-modifiers nil)) (loop for (translator) in all-translators for gesture = (gesture translator) unless (eq gesture t) do (loop for (name type modifier) in gesture unless (eql modifier current-modifier) do (pushnew modifier other-modifiers))) (when other-modifiers (setf other-modifiers (sort other-modifiers #'cmp-modifiers)) (terpri pstream) (write-string "To see other commands, press " pstream) (loop for modifier-tail on other-modifiers for (modifier) = modifier-tail for count from 0 do (progn (if (null (cdr modifier-tail)) (progn (when (> count 1) (write-char #\, pstream)) (when (> count 0) (write-string " or " pstream))) (when (> count 0) (write-string ", " pstream))) (print-modifiers pstream modifier :long))) (write-char #\. pstream)))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/system-opengl.lisp0000644000175000017500000000674107636626175020530 0ustar pdmpdm;;; -*- Mode: Lisp; Package: User -*- ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com) ;;; (c) copyright 2000 by ;;; Robert Strandh (strandh@labri.u-bordeaux.fr) ;;; (c) copyright 2001 by Julien Boninfnate (boninfan@emi.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :common-lisp-user) #+excl(require :loop) (defparameter *clim-directory* (directory-namestring *load-truename*)) #+cmu (progn (unless (fboundp 'stream-read-char) (unless (ignore-errors (ext:search-list "gray-streams:")) (setf (ext:search-list "gray-streams:") '("target:pcl/" "library:subsystems/"))) (load "gray-streams:gray-streams-library")) #+nil (load (merge-pathnames "patch-cmu.lisp" *clim-directory*)) #-mk-defsystem (load "library:subsystems/defsystem")) (pushnew :CLIM *features*) #+mk-defsystem (use-package "MK") (defsystem :clim #-mk-defsystem () #+mk-defsystem :source-pathname #+mk-defsystem *clim-directory* #+mk-defsystem :source-extension #+mk-defsystem "lisp" #+mk-defsystem :components (:serial ;; First possible patches #+cmu "lisp-dep/fix-cmu" "package" "decls" #.(or #+(and :cmu :mp (not :pthread)) "lisp-dep/mp-cmu" #+excl "lisp-dep/mp-acl" #| fall back |# "lisp-dep/mp-nil") "utils" "defresource" "setf-star" "design" "X11-colors" ;; "brectangle" "coordinates" "transforms" "regions" "sheets" "pixmap" "ports" "grafts" "medium" "output" "input" "events" "repaint" "graphics" "stream-output" "recording" "stream-input" "presentations" "commands" "frames" "panes" ; "exports" "gadgets" "menu" "table-formatting" "postscript-medium" )) (defsystem :clim-opengl #-mk-defsystem () #+mk-defsystem :source-pathname #+mk-defsystem *clim-directory* #+mk-defsystem :source-extension #+mk-defsystem "lisp" #+mk-defsystem :depends-on #+mk-defsystem (:clim) #+mk-defsystem :components (:serial #-mk-defsystem :clim "opengl/opengl-x-frame-manager" "opengl/opengl-frame-manager" "opengl/opengl-x-port-before" "opengl/opengl-port" "opengl/opengl-x-port-after" "opengl/opengl-medium" "opengl/opengl-x-graft" )) (defsystem :clim-examples #-mk-defsystem () #+mk-defsystem :source-pathname #+mk-defsystem *clim-directory* #+mk-defsystem :source-extension #+mk-defsystem "lisp" #+mk-defsystem :depends-on #+mk-defsystem (:clim-opengl) #+mk-defsystem :components (:serial #-mk-defsystem :clim-clx "examples/calculator" "examples/colorslider" "examples/menutest" "examples/address-book" "examples/traffic-lights" "examples/clim-fig" "examples/postscript-test" "examples/transformations-test" )) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/dialog-views.lisp0000600000175000017500000000647210423413274020263 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2005 by Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) ;;; Classes for the gadget dialog views. Eventually. ;;; A gadget that's not in the spec but which would be useful. (defclass pop-up-menu-view (gadget-dialog-view) () (:documentation "A dialog view that presents the elements of a COMPLETION presentation type as a pop-up menu.")) (defparameter +pop-up-menu-view+ (make-instance 'pop-up-menu-view)) ;;; By storing these parameters and options from the COMPLETION ;;; presentation type in this object, we avoid having to dig them ;;; out of the presentation type on each call to select-query. That ;;; would not be possible if we are accepting a subtype of COMPLETION. (defclass av-pop-up-menu-record (standard-updating-output-record) ((pop-up-sequence :accessor pop-up-sequence :initform nil) (pop-up-test :accessor pop-up-test :initform nil) (pop-up-value-key :accessor pop-up-value-key :initform nil) (pop-up-name-key :accessor pop-up-name-key :initform nil))) (define-presentation-method accept-present-default ((type completion) stream (view pop-up-menu-view) default default-supplied-p present-p query-identifier) (declare (ignore present-p)) (unless default-supplied-p (setq default (funcall value-key (elt sequence 0)))) (let ((record (updating-output (stream :unique-id query-identifier :cache-value default :record-type 'av-pop-up-menu-record) (with-output-as-presentation (stream query-identifier 'selectable-query) (surrounding-output-with-border (stream :shape :inset :move-cursor t) (write-string (funcall name-key default) stream)))))) (setf (pop-up-sequence record) sequence) (setf (pop-up-test record) test) (setf (pop-up-value-key record) value-key) (setf (pop-up-name-key record) name-key) record)) (defmethod select-query (stream query (record av-pop-up-menu-record)) (declare (ignore stream)) (let* ((value-key (pop-up-value-key record)) (name-key (pop-up-name-key record))) (multiple-value-bind (new-value item event) (menu-choose (map 'list #'(lambda (item) `(,(funcall name-key item) :value ,(funcall value-key item))) (pop-up-sequence record))) (declare (ignore item)) (when event (setf (value query) new-value) (setf (changedp query) t))))) (defmethod deselect-query (stream query (record av-pop-up-menu-record)) (declare (ignore stream query)) nil) (defmethod finalize-query-record (query (record av-pop-up-menu-record)) (declare (ignore query)) nil) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/setf-star.lisp0000600000175000017500000000446710423413301017572 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2001 by ;;; Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) (defun setf-name-p (name) (and (listp name) (eq (car name) 'setf))) ;;; Many implementations complain if a defsetf definition and a setf function ;;; exist for the same place. Time to stop fighting that... (defun make-setf*-gfn-name (function-name) (let* ((name-sym (cadr function-name))) `(setf ,(intern (format nil ".~A-~A." (symbol-name name-sym) (symbol-name '#:star)) (symbol-package name-sym))))) (defmacro defgeneric* (fun-name lambda-list &body options) "Defines a SETF* generic function. FUN-NAME is a SETF function name. The last argument is the single argument to the function in a SETF place form; the other arguments are values collected from the SETF new value form." (unless (setf-name-p fun-name) (error "~S is not a valid name for a SETF* generic function." fun-name)) (let ((setf-name (cadr fun-name)) (args (butlast lambda-list)) (place (car (last lambda-list))) (gf (make-setf*-gfn-name fun-name))) `(progn (defsetf ,setf-name (,place) ,args `(funcall #',',gf ,,@args ,,place)) (defgeneric ,gf ,lambda-list ,@options)))) (defmacro defmethod* (name &body body) "Defines a SETF* method. NAME is a SETF function name. Otherwise, like DEFMETHOD except there must exist a corresponding DEFGENERIC* form." (unless (setf-name-p name) (error "~S is not a valid name for a SETF* generic function." name)) `(defmethod ,(make-setf*-gfn-name name) ,@body)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/menu-choose.lisp0000644000175000017500000004005611345155771020130 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2002 by Alexey Dejneka (adejneka@comail.ru) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Long time TODO (if someone wants to implement them - you are welcome): ;;; ;;; - Menu item options: :items, :type. ;;; ;;; - VIEW. ;;; ;;; - Caching. ;;; ;;; - Default item. ;;; Mid time TODO: ;;; ;;; - Documentation. ;;; ;;; - Empty menu. ;;; ;;; - :DIVIDER type menu items. (in-package :clim-internals) ;; Spec function. (defgeneric menu-choose (items &key associated-window printer presentation-type default-item text-style label cache unique-id id-test cache-value cache-test max-width max-height n-rows n-columns x-spacing y-spacing row-wise cell-align-x cell-align-y scroll-bars pointer-documentation)) ;; Spec function. (defgeneric frame-manager-menu-choose (frame-manager items &key associated-window printer presentation-type default-item text-style label cache unique-id id-test cache-value cache-test max-width max-height n-rows n-columns x-spacing y-spacing row-wise cell-align-x cell-align-y scroll-bars pointer-documentation)) ;; Spec function. (defgeneric menu-choose-from-drawer (menu presentation-type drawer &key x-position y-position cache unique-id id-test cache-value cache-test default-presentation pointer-documentation)) (defgeneric adjust-menu-size-and-position (menu &key x-position y-position) (:documentation "Adjust the size of the menu so it fits properly on the screen with regards to the menu entries. `menu' should be the menu pane. This is an internal, non-specification-defined function.")) (defun menu-item-value (menu-item) (cond ((atom menu-item) menu-item) ((atom (cdr menu-item)) (cdr menu-item)) (t (getf (cdr menu-item) :value (car menu-item))))) (defun menu-item-display (menu-item) (if (atom menu-item) menu-item (car menu-item))) (defun menu-item-options (menu-item) (if (and (consp menu-item) (consp (cdr menu-item))) (cdr menu-item) ; XXX Remove :VALUE? nil)) (defun menu-item-option (menu-item option &optional default) (if (listp menu-item) (getf (menu-item-options menu-item) option default) default)) (defun print-menu-item (menu-item &optional (stream *standard-output*)) (let ((style (getf (menu-item-options menu-item) :style '(nil nil nil)))) (with-text-style (stream style) (if (menu-item-option menu-item :active t) (princ (menu-item-display menu-item) stream) (with-drawing-options (stream :ink (compose-over (compose-in ; XXX it should be (MEDIUM-INK), ; but CLX backend is too stupid. ; -- APD, 2002-08-07 (medium-foreground stream) (make-opacity 0.5)) (medium-background stream))) (princ (menu-item-display menu-item) stream)))))) ;; Spec function. (defun draw-standard-menu (stream presentation-type items default-item &key item-printer max-width max-height n-rows n-columns x-spacing y-spacing row-wise cell-align-x cell-align-y) (declare (ignore default-item)) (orf item-printer #'print-menu-item) (format-items items :stream stream :printer (lambda (item stream) (ecase (menu-item-option item :type :item) (:item ;; This is a normal item, just output. (let ((activep (menu-item-option item :active t))) (with-presentation-type-decoded (name params options) presentation-type (let ((*allow-sensitive-inferiors* activep)) (with-text-style (stream (menu-item-option item :style '(:sans-serif nil nil))) (with-output-as-presentation (stream item `((,name ,@params) :description ,(getf (menu-item-options item) :documentation) ,@options)) (funcall item-printer item stream))))))) (:label ;; This is a static label, it should not be ;; mouse-sensitive, but not grayed out either. (with-text-style (stream (menu-item-option item :style '(:sans-serif nil nil))) (funcall item-printer item stream))) (:divider ;; FIXME: Should draw a line instead. (with-text-style (stream (menu-item-option item :style '(:sans-serif :italic nil))) (funcall item-printer item stream))))) :presentation-type nil :x-spacing x-spacing :y-spacing y-spacing :n-columns n-columns :n-rows n-rows :max-width max-width :max-height max-height :cell-align-x cell-align-x :cell-align-y (or cell-align-y :top) :row-wise row-wise)) (defclass menu-pane (clim-stream-pane) () (:default-initargs :background *3d-normal-color*)) ;; Spec macro. (defmacro with-menu ((menu &optional associated-window &key (deexpose t) label scroll-bars) &body body) (check-type menu symbol) (with-gensyms (with-menu-cont) `(flet ((,with-menu-cont (,menu) ,@body)) (declare (dynamic-extent #',with-menu-cont)) (invoke-with-menu #',with-menu-cont ,associated-window ; XXX ',deexpose ; XXX!!! ,label ,scroll-bars)))) (defun invoke-with-menu (continuation associated-window deexpose label scroll-bars) (let* ((associated-frame (if associated-window (pane-frame associated-window) *application-frame*)) (fm (frame-manager associated-frame))) (with-look-and-feel-realization (fm associated-frame) ; hmm... checkme (let* ((menu-stream (make-pane-1 fm associated-frame 'menu-pane)) (container (scrolling (:scroll-bar scroll-bars) menu-stream)) (frame (make-menu-frame (raising () (if label (labelling (:label label :name 'label :label-alignment :top) container) container)) :left nil :top nil))) (adopt-frame fm frame) (unwind-protect (progn (setf (stream-end-of-line-action menu-stream) :allow (stream-end-of-page-action menu-stream) :allow) (funcall continuation menu-stream)) (when deexpose ; Checkme as well. (disown-frame fm frame))))))) (define-presentation-type menu-item ()) (defmethod menu-choose (items &rest args &key associated-window &allow-other-keys) (let* ((associated-frame (if associated-window (pane-frame associated-window) *application-frame*)) (frame-manager (frame-manager associated-frame))) (apply #'frame-manager-menu-choose frame-manager items args))) (defmethod frame-manager-menu-choose (frame-manager items ; XXX specialize on STANDARD-FRAME-MANAGER &rest options &key associated-window printer presentation-type (default-item nil default-item-p) text-style label cache unique-id id-test cache-value cache-test max-width max-height n-rows (n-columns 1) x-spacing y-spacing row-wise cell-align-x cell-align-y (scroll-bars :vertical) ;; We provide pointer documentation by default. (pointer-documentation *pointer-documentation-output*)) (flet ((drawer (stream type) (draw-standard-menu stream type items (if default-item-p default-item (first items)) :item-printer (or printer #'print-menu-item) :max-width max-width :max-height max-height :n-rows n-rows :n-columns n-columns :x-spacing x-spacing :y-spacing y-spacing :row-wise row-wise :cell-align-x cell-align-x :cell-align-y cell-align-y))) (multiple-value-bind (object event) (with-menu (menu associated-window :label label :scroll-bars scroll-bars) (when text-style (setf (medium-text-style menu) text-style)) (letf (((stream-default-view menu) +textual-menu-view+)) (menu-choose-from-drawer menu (or presentation-type 'menu-item) #'drawer :cache cache :unique-id unique-id :id-test id-test :cache-value cache-value :cache-test cache-test :pointer-documentation pointer-documentation))) (unless (null event) ; Event is NIL if user aborted. (let ((subitems (menu-item-option object :items 'menu-item-no-items))) (if (eq subitems 'menu-item-no-items) (values (menu-item-value object) object event) (apply #'frame-manager-menu-choose frame-manager subitems options))))))) (defun max-x-y (frame) "Return the maximum X and Y coordinate values for a menu for `frame' (essentially, the screen resolution with a slight padding.)" ;; FIXME? There may be a better way. (let* ((port (port (frame-manager frame))) (graft (find-graft :port port))) (values (- (graft-width graft) 50) (- (graft-height graft) 50)))) (defun menu-size (menu frame) "Return two values, the height and width of MENU (adjusted for maximum size according to `frame')." (multiple-value-bind (max-width max-height) (max-x-y frame) (with-bounding-rectangle* (x1 y1 x2 y2) menu (declare (ignore x1 y1)) (values (min x2 max-width) (min y2 max-height))))) (defmethod adjust-menu-size-and-position ((menu menu-pane) &key x-position y-position) ;; Make sure the menu isn't higher or wider than the screen. (multiple-value-bind (menu-width menu-height) (menu-size (stream-output-history menu) *application-frame*) (change-space-requirements menu :width menu-width :height menu-height :resize-frame t) ;; If we have scroll-bars, we need to do some calibration of the ;; size of the viewport. (when (pane-viewport menu) (multiple-value-bind (viewport-width viewport-height) (menu-size (pane-viewport menu) *application-frame*) (change-space-requirements (pane-scroller menu) ;; HACK: How are you supposed to ;; change the size of the viewport? ;; I could only find this way, where ;; I calculate the size difference ;; between the viewport and the ;; scroller pane, and set the ;; scroller pane to the desired size ;; of the viewport, plus the ;; difference (to make room for ;; scroll bars). :width (+ menu-width (- (pane-current-width (pane-scroller menu)) viewport-width)) :height (+ menu-height (- (pane-current-height (pane-scroller menu)) viewport-height)) :resize-frame t))) ;; Modify the size and location of the frame as well. (let* ((top-level-pane (labels ((searching (pane) (if (typep pane 'top-level-sheet-pane) pane (searching (sheet-parent pane))))) (searching menu)))) (multiple-value-bind (frame-width frame-height) (menu-size top-level-pane *application-frame*) (multiple-value-bind (res-max-x res-max-y) (max-x-y *application-frame*) ;; Move the menu frame so that no entries are outside the visible ;; part of the screen. (let ((max-left (- res-max-x frame-width)) (max-top (- res-max-y frame-height))) ;; XXX: This is an ugly way to find the screen position of ;; the menu frame, possibly even undefined. (multiple-value-bind (left top) (with-slots (dx dy) (sheet-transformation top-level-pane) (values dx dy)) (when x-position (setf left x-position)) (when y-position (setf top y-position)) ;; Adjust for maximum position if the programmer has not ;; explicitly provided coordinates. (if (null x-position) (when (> left max-left) (setf left max-left))) (if (null y-position) (when (> top max-top) (setf top max-top))) (move-sheet top-level-pane (max left 0) (max top 0))))))))) (defmethod adjust-menu-size-and-position (menu &key &allow-other-keys) ;; Nothing. nil) ;; Spec function. (defmethod menu-choose-from-drawer (menu presentation-type drawer &key x-position y-position cache unique-id id-test cache-value cache-test default-presentation pointer-documentation) (declare (ignore cache unique-id id-test cache-value cache-test default-presentation)) (with-room-for-graphics (menu :first-quadrant nil) (funcall drawer menu presentation-type)) (adjust-menu-size-and-position menu :x-position x-position :y-position y-position) (let ((*pointer-documentation-output* pointer-documentation)) (let ((*pointer-documentation-output* pointer-documentation)) (handler-case (with-input-context (`(or ,presentation-type blank-area) :override t) (object type event) (prog1 nil (loop (read-gesture :stream menu))) (blank-area nil) (t (values object event))) (abort-gesture () nil))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/test.lisp0000644000175000017500000000405611345155772016666 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-DEMO -*- ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com) ;;; (c) copyright 2000 by ;;; Robert Strandh (strandh@labri.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-demo) (defun address-book () (declare (special frame fm port pane medium graft)) (loop for port in climi::*all-ports* do (destroy-port port)) (setq climi::*all-ports* nil) (setq frame (make-application-frame 'address-book)) ; (setq fm (frame-manager frame)) ; (setq port (port fm)) ; (setq pane (frame-standard-output frame)) ; (setq medium (sheet-medium pane)) ; (setq graft (graft frame)) (run-frame-top-level frame)) (defun test-define-application-frame () (macroexpand '(define-application-frame address-book () ;; This application has two state variables, the currently displayed ;; address and the window from which user queries should be read. ((current-address :initform nil) (interaction-pane ) (name-pane)) (:panes (interactor :interactor) (address :application :incremental-redisplay t :display-function 'display-current-address) (names :application :incremental-redisplay t :display-function 'display-names)) (:layouts (default (vertically () (horizontally () address names) interactor)))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/bordered-output.lisp0000640000175000017500000010065510705412611021014 0ustar pdmpdm;;; -*- Mode: lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2002 by Alexey Dejneka (adejneka@comail.ru) ;;; (c) copyright 2007 by Andy Hefner (ahefner@gmail.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; TODO: ;;; - Define a protocol which the graph formatter can utilize to determine ;;; where graph edges should be connected to shaped output borders. ;;; - ** Double check default value and intent of move-cursor argument. ;;; If I understand things right, move-cursor t for underlining is usually ;;; the wrong thing. ;;; FIXME: ;;; - Various functions which try to accomodate line-thickness do not ;;; attempt to consider possibility of a line-style argument. ;;; - In a perfect world we could make the default shadow ink a tranlucent ;;; ink, but the CLX backend isn't there yet. A stopgap measure could ;;; simply blend against the pane-background. ;;; - Using padding to control the rounded rectangles might be the wrong thing. ;;; ??? ;;; - Would it make more sense to draw borders as part of replay (with recording ;;; off, like a displayed record), and letting them effortlessly accomodate ;;; changes in the bounding rectangle of the contents? This would only benefit ;;; people doing unusual things with output records. How would be determine ;;; bounds of the border? (in-package :clim-internals) (defclass bordered-output-record (standard-sequence-output-record) (under record over)) (defgeneric make-bordered-output-record (stream shape record &key &allow-other-keys) (:documentation "Instantiates an output record of a class appropriate for the specified shape containing the given output record, and renders any decorations associated with the shape.")) (defgeneric draw-output-border-under (shape stream record &rest drawing-options &key &allow-other-keys) (:documentation "Draws the portion of border shape which is visible underneath the surrounded output")) (defgeneric draw-output-border-over (shape stream record &rest drawing-options &key &allow-other-keys) (:documentation "Draws the portion of border shape which is visible above the surrounded output")) ;; Keep this around just for fun, so we can list the defined border types. (defvar *border-types* nil) (defparameter *border-default-padding* 4) (defparameter *border-default-radius* 7) (defparameter *drop-shadow-default-offset* 6) ;; Defining the border edges directly by the edges of the surrounded output ;; record is wrong in the 'null bounding rectangle' case, occuring when the ;; record has no chidren, or no children with non-null bounding rectangles. ;; Intuitively, the empty border should remain centered on the cursor. (defmacro with-border-edges ((stream record) &body body) `(if (null-bounding-rectangle-p ,record) (multiple-value-bind (left top) (stream-cursor-position ,stream) (let ((right (1+ left)) (bottom (1+ top))) ,@body)) (with-bounding-rectangle* (left top right bottom) ,record ,@body))) (defmacro surrounding-output-with-border ((&optional stream &rest drawing-options &key (shape :rectangle) (move-cursor t) &allow-other-keys) &body body) (declare (ignore shape move-cursor)) (setf stream (stream-designator-symbol stream '*standard-output*)) (gen-invoke-trampoline 'invoke-surrounding-output-with-border (list stream) drawing-options body)) (defun %prepare-bordered-output-record (stream shape border inner-record drawing-options) (with-sheet-medium (medium stream) (macrolet ((capture (&body body) `(multiple-value-bind (cx cy) (stream-cursor-position stream) (with-output-to-output-record (stream) (setf (stream-cursor-position stream) (values cx cy)) ,@body)))) (let* ((border-under (with-identity-transformation (medium) (capture (apply #'draw-output-border-under shape stream inner-record drawing-options)))) (border-over (with-identity-transformation (medium) (capture (apply #'draw-output-border-over shape stream inner-record drawing-options))))) (with-slots (under record over) border (setf under border-under record inner-record over border-over) (add-output-record under border) (add-output-record record border) (add-output-record over border)) border)))) (defmethod make-bordered-output-record (stream shape inner-record &rest drawing-options) (%prepare-bordered-output-record stream shape (make-instance 'bordered-output-record) inner-record drawing-options)) ;; This should have been exported by the CLIM package, otherwise you can't ;; apply a computed list of drawing options. (defun invoke-surrounding-output-with-border (stream cont &rest drawing-options &key (shape :rectangle) (move-cursor t) &allow-other-keys) (with-keywords-removed (drawing-options (:shape :move-cursor)) (multiple-value-bind (cx cy) (stream-cursor-position stream) (let ((border (apply #'make-bordered-output-record stream shape (with-output-to-output-record (stream) ;; w-o-t-o-r moved the cursor to the origin. (setf (stream-cursor-position stream) (values cx cy)) (funcall cont stream) (setf (values cx cy) (stream-cursor-position stream))) drawing-options))) (stream-add-output-record stream border) (when (stream-drawing-p stream) (with-output-recording-options (stream :record nil) (replay border stream))) (if move-cursor ;; move-cursor is true, move cursor to lower-right corner of output. (with-bounding-rectangle* (left top right bottom) border (declare (ignore left top)) (setf (stream-cursor-position stream) (values right bottom))) ;; move-cursor is false, preserve the cursor position from after ;; the output (I think this is right, it's useful for :underline) (setf (stream-cursor-position stream) (values cx cy))) border)))) (defmethod draw-output-border-under (shape stream record &rest drawing-options &key &allow-other-keys) (declare (ignore drawing-options)) (values)) (defmacro %%line-style-for-method () `(or line-style (let ((mls (medium-line-style stream))) (make-line-style :unit (or line-unit (line-style-unit mls)) :thickness (or line-thickness (line-style-thickness mls)) :cap-shape (or line-cap-shape (line-style-cap-shape mls)) :dashes (or line-dashes (line-style-dashes mls)))))) (defmacro %%adjusting-for-padding (&body body) `(let ((left (- left padding-left)) (right (+ right padding-right)) (top (- top padding-top)) (bottom (+ bottom padding-bottom))) ,@body)) (defmacro %%adjusting-padding-for-line-style (&body body) `(let ((padding-left (+ padding-left (/ (or line-thickness 0) 2))) (padding-right (+ padding-right (/ (or line-thickness 0) 2))) (padding-top (+ padding-top (/ (or line-thickness 0) 2))) (padding-bottom (+ padding-bottom (/ (or line-thickness 0) 2)))) ,@body)) (defmacro define-border-type (shape arglist &body body) (check-type arglist list) ;; The Franz User guide implies that &key isn't needed. (pushnew '&key arglist) `(progn (pushnew ',shape *border-types*) (defmethod draw-output-border-over ((shape (eql ',shape)) stream record &rest drawing-options) (with-border-edges (stream record) (apply (lambda (,@arglist &allow-other-keys) ,@body) :stream stream :record record :left left :right right :top top :bottom bottom drawing-options))))) ;;;; Standard border types (define-border-type :rectangle (stream left top right bottom ink outline-ink filled (padding *border-default-padding*) (padding-x padding) (padding-y padding) (padding-left padding-x) (padding-right padding-x) (padding-top padding-y) (padding-bottom padding-y) line-style line-unit line-thickness line-cap-shape line-dashes) (%%adjusting-padding-for-line-style (%%adjusting-for-padding (let ((ink (or outline-ink (and (not filled) (or ink (medium-ink stream)))))) (when ink (draw-rectangle* stream left top right bottom :line-style (%%line-style-for-method) :ink ink :filled nil)))))) (defmethod draw-output-border-under ((shape (eql :rectangle)) stream record &key background ink filled (padding *border-default-padding*) (padding-x padding) (padding-y padding) (padding-left padding-x) (padding-right padding-x) (padding-top padding-y) (padding-bottom padding-y) shadow (shadow-offset *drop-shadow-default-offset*) line-thickness &allow-other-keys) (when (or background filled) (with-border-edges (stream record) (%%adjusting-padding-for-line-style (%%adjusting-for-padding (when (and shadow shadow-offset) (draw-rectangle* stream (+ shadow-offset left) (+ shadow-offset top) (+ shadow-offset right) (+ shadow-offset bottom) :ink shadow :filled t)) (draw-rectangle* stream left top right bottom :ink (or background ink +background-ink+) :filled t)))))) (define-border-type :oval (stream left top right bottom (ink (medium-ink stream)) outline-ink (padding *border-default-padding*) (padding-x padding) (padding-y padding) (padding-left padding-x) (padding-right padding-x) (padding-top padding-y) (padding-bottom padding-y) line-style line-unit line-thickness line-cap-shape line-dashes) (%%adjusting-padding-for-line-style (%%adjusting-for-padding (when ink (draw-oval* stream (/ (+ left right) 2) (/ (+ top bottom) 2) (/ (- right left) 2) (/ (- bottom top) 2) :line-style (%%line-style-for-method) :ink (or outline-ink ink) :filled nil))))) (defmethod draw-output-border-under ((shape (eql :oval)) stream record &key background ink filled line-thickness (shadow-offset *drop-shadow-default-offset*) shadow (padding *border-default-padding*) (padding-x padding) (padding-y padding) (padding-left padding-x) (padding-right padding-x) (padding-top padding-y) (padding-bottom padding-y) &allow-other-keys) (when (or filled background) (with-border-edges (stream record) (%%adjusting-padding-for-line-style (%%adjusting-for-padding (when shadow (draw-oval* stream (+ shadow-offset (/ (+ left right) 2)) (+ shadow-offset (/ (+ top bottom) 2)) (/ (- right left) 2) (/ (- bottom top) 2) :ink shadow :filled t)) (draw-oval* stream (/ (+ left right) 2) (/ (+ top bottom) 2) (/ (- right left) 2) (/ (- bottom top) 2) :ink (or background ink +background-ink+) :filled t)))))) ;;; A filled :drop-shadow is almost identical to :rectangle with a ;;; :shadow keyword. So, just use :rectangle instead. (define-border-type :drop-shadow (stream left top right bottom (filled nil) (shadow-offset 3) outline-ink background (ink (medium-ink stream)) (padding *border-default-padding*) (padding-x padding) (padding-y padding) (padding-left padding-x) (padding-right padding-x) (padding-top padding-y) (padding-bottom padding-y) line-style line-unit line-thickness line-cap-shape line-dashes) (%%adjusting-padding-for-line-style (%%adjusting-for-padding (draw-rectangle* stream left top right bottom :line-style (%%line-style-for-method) :ink (or outline-ink ink) :filled nil) ;; If the user has (wisely) chosen my more modern "filled" style, ;; we'll simply draw two rectangles, one offset from the other, ;; to provide a solid background color and shadow. ;; Note that the background keyword implies :filled t. (unless (or filled background) (when (< shadow-offset 0) ; FIXME! (setf shadow-offset 0)) (draw-rectangle* stream right (+ top shadow-offset) (+ right shadow-offset) bottom :ink (or outline-ink ink) :filled t) (draw-rectangle* stream (+ left shadow-offset) bottom (+ right shadow-offset) (+ bottom shadow-offset) :ink (or outline-ink ink) :filled t))))) (defmethod draw-output-border-under ((shape (eql :drop-shadow)) stream record &key (filled nil) (shadow-offset *drop-shadow-default-offset*) background outline-ink shadow (ink +foreground-ink+) line-thickness (padding *border-default-padding*) (padding-x padding) (padding-y padding) (padding-left padding-x) (padding-right padding-x) (padding-top padding-y) (padding-bottom padding-y)) (with-border-edges (stream record) (%%adjusting-padding-for-line-style (%%adjusting-for-padding (when (or filled background) (let* ((fill-color (or background +background-ink+)) (shadow-color (or shadow outline-ink ink +background-ink+))) (draw-rectangle* stream (+ shadow-offset left) (+ shadow-offset top) (+ shadow-offset right) (+ shadow-offset bottom) :filled t :ink shadow-color) (draw-rectangle* stream left top right bottom :filled t :ink fill-color))))))) (define-border-type :underline (stream record (ink (medium-ink stream)) line-style line-unit line-thickness line-cap-shape line-dashes) (let ((line-style (%%line-style-for-method))) (labels ((fn (record) (loop for child across (output-record-children record) do (typecase child (text-displayed-output-record (with-bounding-rectangle* (left top right bottom) child (declare (ignore top)) (draw-line* stream left bottom right bottom :ink ink :line-style line-style))) (updating-output-record nil) (compound-output-record (fn child)))))) (fn record)))) (define-border-type :inset (stream left top right bottom (padding *border-default-padding*) (padding-x padding) (padding-y padding) (padding-left padding-x) (padding-right padding-x) (padding-top padding-y) (padding-bottom padding-y)) (%%adjusting-for-padding (let ((dark *3d-dark-color*) (light *3d-light-color*)) (flet ((draw (left-edge right-edge bottom-edge top-edge light dark) (draw-line* stream left-edge bottom-edge left-edge top-edge :ink dark) (draw-line* stream left-edge top-edge right-edge top-edge :ink dark) (draw-line* stream right-edge bottom-edge right-edge top-edge :ink light) (draw-line* stream left-edge bottom-edge right-edge bottom-edge :ink light))) (draw left right bottom top light dark) (draw (1+ left) (1- right) (1- bottom) (1+ top) light dark))))) ;;; Padding defaults to radius. I'm not sure if this is right, but it lets you do ;;; things like forcing the radius on one side to zero, flattening that side, ;;; and stopping the edge from jamming against the output (saving you the trouble ;;; of having to manually hack the padding on one side to compensate). If someone ;;; can think of a better approach to defaulting the radius and padding arguments, ;;; do share. (define-border-type :rounded (stream left top right bottom (radius *border-default-radius*) (radius-x radius) (radius-y radius) (radius-left radius-x) (radius-right radius-x) (radius-top radius-y) (radius-bottom radius-y) (padding radius) (padding-x padding) (padding-y padding) (padding-left padding-x) (padding-right padding-x) (padding-top padding-y) (padding-bottom padding-y) ink filled outline-ink line-style line-unit line-thickness line-cap-shape line-dashes) (%%adjusting-padding-for-line-style (%%adjusting-for-padding (let ((ink (or outline-ink (and (not filled) (or ink +foreground-ink+))))) (when ink (draw-rounded-rectangle* stream left top right bottom :radius-left radius-left ; padding-left :radius-right radius-right ; padding-right :radius-top radius-top ; padding-top :radius-bottom radius-bottom ; padding-bottom :ink ink :filled nil :line-style (%%line-style-for-method))))))) (defmethod draw-output-border-under ((shape (eql :rounded)) stream record &key (radius *border-default-radius*) (radius-x radius) (radius-y radius) (radius-left radius-x) (radius-right radius-x) (radius-top radius-y) (radius-bottom radius-y) (padding radius) (padding-x padding) (padding-y padding) (padding-left padding-x) (padding-right padding-x) (padding-top padding-y) (padding-bottom padding-y) ink filled background shadow (shadow-offset *drop-shadow-default-offset*) line-thickness) (with-border-edges (stream record) (%%adjusting-padding-for-line-style (%%adjusting-for-padding (when (or filled background) (when (and shadow shadow-offset) (draw-rounded-rectangle* stream (+ left shadow-offset) (+ top shadow-offset) (+ shadow-offset right) (+ shadow-offset bottom) :radius-left radius-left :radius-right radius-right :radius-top radius-top :radius-bottom radius-bottom :ink shadow :filled t)) (let ((ink (or background ink +background-ink+))) (draw-rounded-rectangle* stream left top right bottom :radius-left radius-left :radius-right radius-right :radius-top radius-top :radius-bottom radius-bottom :ink ink :filled t))))))) (define-border-type :ellipse (stream left top right bottom (padding *border-default-radius*) (padding-x padding) (padding-y padding) (padding-left padding-x) (padding-right padding-x) (padding-top padding-y) (padding-bottom padding-y) ink outline-ink filled circle line-style line-unit min-radius (min-radius-x min-radius) (min-radius-y min-radius) line-thickness line-cap-shape line-dashes) (%%adjusting-padding-for-line-style (%%adjusting-for-padding (let ((ink (or outline-ink (and (not filled) (or ink +foreground-ink+))))) (when ink (let* ((cx (/ (+ right left) 2)) (cy (/ (+ top bottom) 2)) (radius-x (- right cx)) (radius-y (- bottom cy)) (radius-x (if circle (sqrt (+ (* radius-x radius-x) (* radius-y radius-y))) radius-x)) (radius-y (if circle radius-x radius-y)) (fx (/ radius-x (cos (/ pi 4)))) (fy (/ radius-y (sin (/ pi 4)))) (fx (max fx (or min-radius-x 0))) (fy (max fy (or min-radius-y 0)))) (draw-ellipse* stream cx cy fx 0 0 fy :filled nil :ink ink :line-style (%%line-style-for-method)))))))) (defmethod draw-output-border-under ((shape (eql :ellipse)) stream record &key (padding *border-default-radius*) (padding-x padding) (padding-y padding) (padding-left padding-x) (padding-right padding-x) (padding-top padding-y) (padding-bottom padding-y) ink background filled circle min-radius shadow (shadow-offset *drop-shadow-default-offset*) (min-radius-x min-radius) (min-radius-y min-radius) line-thickness) (with-border-edges (stream record) (%%adjusting-padding-for-line-style (%%adjusting-for-padding (let ((ink (or background (and filled (or ink +background-ink+))))) (when ink (let* ((cx (/ (+ right left) 2)) (cy (/ (+ top bottom) 2)) (radius-x (- right cx)) (radius-y (- bottom cy)) (radius-x (if circle (sqrt (+ (* radius-x radius-x) (* radius-y radius-y))) radius-x)) (radius-y (if circle radius-x radius-y)) (fx (/ radius-x (cos (/ pi 4)))) (fy (/ radius-y (sin (/ pi 4)))) (fx (max fx (or min-radius-x 0))) (fy (max fy (or min-radius-y 0))) ) (when (and shadow shadow-offset) (draw-ellipse* stream (+ cx shadow-offset) (+ cy shadow-offset) fx 0 0 fy :filled t :ink shadow)) (draw-ellipse* stream cx cy fx 0 0 fy :filled t :ink ink)))))))) (defmethod highlight-output-record ((record bordered-output-record) stream state) (format *trace-output* "b-o-r ~A ~A ~A~%" record stream state) (call-next-method)) ;;; Suppress highlighting of the border decoration itself: (defmethod highlight-output-record-tree ((record bordered-output-record) stream state) (highlight-output-record-tree (slot-value record 'record) stream state)) ;;;; Highlighting of bordered output records (defclass highlighting-bordered-output-record (bordered-output-record) ((shape :reader shape :initarg :shape) (drawing-options :reader drawing-options :initarg :drawing-options :initform nil))) (defmethod highlight-output-record-tree ((record highlighting-bordered-output-record) stream state) ;; Was this border created with the required options for highlighting? (if (and (member state '(:highlight :unhighlight)) (or (getf (drawing-options record) :highlight-background) (getf (drawing-options record) :highlight-outline))) (highlight-output-record record stream state) (call-next-method))) (defmethod highlight-output-record ((record highlighting-bordered-output-record) stream state) (let ((drawing-options (drawing-options record))) (destructuring-bind (&key background outline-ink highlight-background highlight-outline &allow-other-keys) drawing-options (if (and (member state '(:highlight :unhighlight)) (or highlight-background highlight-outline)) (flet ((redraw (new-drawing-options) (clear-output-record record) (%prepare-bordered-output-record stream (shape record) record (slot-value record 'record) new-drawing-options) ;; Great, this again.. (queue-repaint stream (make-instance 'window-repaint-event :sheet stream :region (transform-region (sheet-native-transformation stream) record))))) (ecase state (:highlight (with-keywords-removed (drawing-options (:background :outline-ink)) (redraw (list* :background (or (and (eql t highlight-background) (highlight-shade (or background (getf drawing-options :ink) +background-ink+))) highlight-background background) :outline-ink (or (and (eql t highlight-outline) (highlight-shade (or outline-ink (getf drawing-options :ink) +foreground-ink+))) highlight-outline outline-ink) drawing-options)))) (:unhighlight (redraw drawing-options)))) (call-next-method))))) (defmacro define-default-highlighting-method (shape) `(defmethod make-bordered-output-record (stream (shape (eql ,shape)) inner-record &rest drawing-options) (%prepare-bordered-output-record stream shape (make-instance 'highlighting-bordered-output-record :shape shape :drawing-options drawing-options) inner-record drawing-options))) (define-default-highlighting-method :rectangle) (define-default-highlighting-method :oval) (define-default-highlighting-method :drop-shadow) (define-default-highlighting-method :rounded) (define-default-highlighting-method :ellipse) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Goatee/0000755000175000017500000000000011347763424016216 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Goatee/goatee-test.lisp0000644000175000017500000000470607465403207021333 0ustar pdmpdm;;; -*- Mode: Lisp; Package: GOATEE -*- ;;; (c) copyright 2002 by Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :goatee) ;;; Puts up a single line of text for editing. These basic commands work: ;;; self insertion of characters ;;; C-f, C-b for moving forwards and backwards ;;; C-a, C-e for beginning of line, end of line ;;; C-d for "forward deletion" ;;; #\delete or #\rubout for "backwards deletion" ;;; M-C-b drops into a break loop. ;;; ;;; Run with (clim-demo::run-test 'goatee-test) (define-application-frame goatee-test () ((goatee-area :accessor goatee-area :initarg :goatee-area)) (:panes (tester :interactor :width 640)) (:layouts (default (vertically () tester))) (:top-level (goatee-test-top-level))) (defun goatee-test-top-level (frame &key command-parser command-unparser partial-command-parser prompt) (declare (ignore command-parser command-unparser partial-command-parser)) (let ((*standard-output* (frame-standard-output frame)) (*standard-input* (frame-standard-input frame)) (*print-pretty* nil) ) (multiple-value-bind (cx cy) (stream-cursor-position *standard-output*) (setf (cursor-visibility (stream-text-cursor *standard-input*)) nil) (stream-add-output-record *standard-output* (setf (goatee-area frame) (make-instance 'simple-screen-area :area-stream *standard-output* :buffer (make-instance 'editable-buffer :initial-contents "The fox jumped over the goatee.") :x-position cx :y-position cy)))) (loop (let ((gesture (read-gesture :stream *standard-input*))) (execute-gesture-command gesture (goatee-area frame) *simple-area-gesture-table*))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Goatee/dbl-list.lisp0000644000175000017500000000603007527637070020622 0ustar pdmpdm;;; -*- Mode: Lisp; Package: GOATEE -*- ;;; (c) copyright 2002 by Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :goatee) ;;; Mostly implements dbl-list-head (defclass dbl-super () ((next :accessor next :initarg :next :initform nil))) (defgeneric prev (dbl-list)) (defmethod prev ((dbl-list dbl-super)) nil) (defclass dbl-list (dbl-super) ((prev :accessor prev :initarg :prev :initform nil))) (defgeneric dbl-insert-after (new-element dbl-list)) (defmethod dbl-insert-after ((new-element dbl-list) (dbl-list dbl-super)) (setf (prev new-element) dbl-list) (setf (next new-element) (next dbl-list)) (when (next dbl-list) (setf (prev (next dbl-list)) new-element)) (setf (next dbl-list) new-element) new-element) (defgeneric dbl-insert-before (new-element dbl-list)) (defmethod dbl-insert-before ((new-element dbl-list) (dbl-list dbl-list)) (setf (next new-element) dbl-list) (setf (prev new-element) (prev dbl-list)) (when (prev dbl-list) (setf (next (prev dbl-list)) new-element)) (setf (prev dbl-list) new-element) new-element) (defgeneric dbl-remove (element)) (defmethod dbl-remove ((element dbl-list)) (when (prev element) (setf (next (prev element)) (next element))) (when (next element) (setf (prev (next element)) (prev element))) nil) (defgeneric dbl-kill-after (element) (:documentation "Remove all elements after element.")) (defmethod dbl-kill-after ((element dbl-super)) (let ((next (next element))) (when next (setf (prev next) nil)) (setf (next element) nil) element)) (defclass dbl-list-head (dbl-super) ()) (defmethod dbl-head ((dbl-list dbl-list-head)) (next dbl-list)) (defmethod (setf dbl-head) (val (dbl-list dbl-list-head)) (setf (next dbl-list) val)) (defclass dbl-list-cell (dbl-list) ((contents :accessor contents :initarg :contents :initform nil))) (defun make-dbl-list () (make-instance 'dbl-list-head)) (defun insert-obj-before (obj dbl-list) (let ((cell (make-instance 'dbl-list-cell :contents obj))) (dbl-insert-before cell dbl-list))) (defun insert-obj-after (obj dbl-list) (let ((cell (make-instance 'dbl-list-cell :contents obj))) (dbl-insert-after cell dbl-list))) (defun dbl-list-elements (dbl-list) (loop for dbl = (dbl-head dbl-list) then (next dbl) while dbl collect (contents dbl))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Goatee/presentation-history.lisp0000640000175000017500000000531310561555374023317 0ustar pdmpdm;;; -*- Mode: Lisp; Package: GOATEE -*- ;;; (c) copyright 2004 by Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; presentation (input) histories. hack hack hack (in-package :goatee) (defvar *last-yank-command* nil) ;;; We story the presentation type and history here for yank-next ;;; because the accept that established the original history may not ;;; be active anymore after rescanning the input. (defvar *last-history-type* nil) (defvar *last-history* nil) (defun insert-ptype-history (object type) (multiple-value-bind (line pos) (point* *buffer*) (multiple-value-bind (printed-rep accept-object) (present-acceptably-to-string object type +textual-view+ ; XXX type) ;; XXX accept-object (insert *buffer* printed-rep :line line :pos pos)))) (defun cmd-history-yank-next (&key &allow-other-keys) (let* ((accepting-type climi::*active-history-type*) (history (and accepting-type (presentation-type-history accepting-type)))) (when history (multiple-value-bind (object type) (climi::presentation-history-next history accepting-type) (when type (clear-buffer *buffer*) (insert-ptype-history object type)))))) (defun cmd-history-yank-previous (&key &allow-other-keys) (let* ((accepting-type climi::*active-history-type*) (history (and accepting-type (presentation-type-history accepting-type)))) (when history (multiple-value-bind (object type) (climi::presentation-history-previous history accepting-type) (when type (clear-buffer *buffer*) (insert-ptype-history object type)))))) (add-gesture-command-to-table '(#\p :meta) 'cmd-history-yank-previous *simple-area-gesture-table*) (add-gesture-command-to-table '(#\n :meta) 'cmd-history-yank-next *simple-area-gesture-table*) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Goatee/kill-ring.lisp0000644000175000017500000001016010003303615020751 0ustar pdmpdm;;; -*- Mode: Lisp; Package: GOATEE -*- ;;; (c) copyright 2002 by Andreas Fuchs ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :goatee) ;; Kill Ring is the place where killed regions go. We probably need to ;; have better semantics for killing after/before motion (like emacs ;; does - have two consecutive `kill-line's append the second killed ;; line to the first and open another element in the kill ring if ;; there was motion or other activity between the two kills). I have ;; tried to emulate this behaviour with *kill-ring-open-new*. (defclass ring (dbl-list-head) ((last-access :accessor last-access :documentation "Pointer to the element that was accessed last." :initform nil) (end :accessor end :initform nil :documentation "Last element in the list.")) (:documentation "A LIFO double-list whose last element's next-value is the ring's first element.")) (defclass ring-cell (dbl-list-cell) ((head :accessor head :initarg :head :initform nil))) (defun make-ring () (make-instance 'ring)) (defmethod forward ((r ring)) "Move forward in a ring." (let ((next-element (next (or (last-access r) r)))) (setf (last-access r) (or next-element (dbl-head r))))) (defmethod backward ((r ring)) "Move backward in a ring." (let ((prev-element (if (last-access r) (prev (last-access r)) (end r)))) (setf (last-access r) (if (eq prev-element r) (end r) prev-element)))) (defun ring-obj-insert (obj ring) "Insert an object into a Ring." (let ((cell (make-instance 'ring-cell :head ring :contents obj))) (dbl-insert-after cell ring))) (defmethod dbl-kill-after :after ((element ring-cell)) (setf (end (head element)) element) (setf (last-access (head element)) nil)) (defmethod dbl-remove :after ((element ring-cell)) (when (eq (end (head element)) element) (setf (end (head element)) element)) (setf (last-access (head element)) nil)) (defmethod dbl-insert-after :after ((element ring-cell) (ring ring)) (when (eq (end ring) nil) (setf (end ring) element))) (defun kill-region (ring buf start end) (copy-or-kill-region ring buf start end :copy nil)) (defun copy-region (ring buf start end) (copy-or-kill-region ring buf start end :copy t)) (defun copy-or-kill-region (ring buf start end &key copy) (let ((copy-buffer (make-instance 'editable-buffer))) (map-over-region #'(lambda (line pos) (insert copy-buffer (char-ref* buf line pos))) buf start end) (unless copy (delete-region buf start end)) (ring-obj-insert copy-buffer ring))) (defun yank (ring buffer yank-extent) (yank-1 ring buffer #'dbl-head yank-extent)) (defun yank-next (ring buffer yank-extent) (delete-region buffer (bp-start yank-extent) (bp-end yank-extent)) (yank-1 ring buffer #'forward yank-extent)) (defun yank-prev (ring buffer yank-extent) (delete-region buffer (bp-start yank-extent) (bp-end yank-extent)) (yank-1 ring buffer #'backward yank-extent)) (defun yank-1 (ring buffer operation yank-extent) (let ((to-insert (buffer-string (contents (funcall operation ring))))) (insert buffer to-insert :position (bp-end yank-extent)))) (defmacro with-object-on-ring ((object ring) &body body) (climi::with-gensyms (ring-var cell-var) `(let* ((,ring-var ,ring) (,cell-var (ring-obj-insert ,object ,ring-var))) (unwind-protect (progn ,@body) (goatee::dbl-remove ,cell-var))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Goatee/editable-area.lisp0000644000175000017500000001170707537052736021577 0ustar pdmpdm(in-package :goatee) ;;; A mixin for buffers that can be displayed in editable areas (defclass displayable-buffer () ((editable-areas :accessor editable-areas :initarg :editable-areas))) (defclass editable-area () ((buffer :reader buffer :initarg :buffer) (frame-begin-mark :accessor frame-begin-mark) ;XXX obsolete (last-tick :accessor last-tick :initarg :last-tick :documentation "buffer tick") (lines :accessor lines :initarg :lines :initform (make-instance 'dbl-list-head) :documentation "Lines in the area, as opposed to the lines in the buffer.") (area-bp-start :accessor area-bp-start :initarg :area-bp-start :documentation "buffer pointer to line in buffer that's at the top of the area. The bp is not necessarily at the beginning of the line.") (area-bp-end :accessor area-bp-end :initarg :area-bp-end :documentation "buffer pointer to line in buffer that's at the bottom of the area. The bp is not necessarily at the beginning of the line.") (last-line :accessor last-line :initarg :last-line :initform nil) (last-command :accessor last-command :initform nil) (goal-column :accessor goal-column :initform nil :documentation "Goal column for next-line command when moving over a short line")) (:documentation "An abstract superclass for the on-screen area devoted to Goatee editing. Roughly equivalent to a window in GNU Emacs.")) (defmethod initialize-instance :after ((obj editable-area) &key initial-contents) (when initial-contents (if (slot-boundp obj 'buffer) (error "Only one of :buffer and :initial-contents may be supplied") (setf (slot-value obj 'buffer) (make-instance 'editable-buffer :initial-contents initial-contents))))) (defgeneric area-first-line (area)) (defmethod area-first-line ((area editable-area)) (dbl-head (lines area))) #+nil(progn (defmethod (setf buffer) ((new-buf displayable-buffer) (win editable-area)) (when (slot-boundp win 'buffer) (remove-mark frame-begin-mark)) (setf (slot-value win 'buffer) new-buf) (pushnew win (editable-areas new-buf)) (frame-window-to-point win) (add-new-lines win) new-buf) (defconstant +point-frame-ratio+ 1/2) (defgeneric frame-window-to-point (window)) ;;;XXX How to deal with line wrap? (defmethod frame-window-to-point ((win window)) (with-accessors ((buffer buffer) (frame-begin-mark frame-begin-mark)) win (let* ((lines-to-start (floor (* (rows win) +point-frame-ratio+))) (window-start (loop for lines from 0 for prev-eol = (point buffer) then (position-backward buffer #\newline prev-eol ) while (and prev-eol (<= lines lines-to-start)) finally (return (or prev-eol 0))))) (if (and (slot-boundp win 'frame-begin-mark) frame-begin-mark) (progn (remove-mark frame-begin-mark) (setf frame-begin-mark (insert-mark buffer frame-begin-mark window-start))) (setf frame-begin-mark (insert-mark-using-class buffer 'fixed-mark window-start)))))) (defclass line-mark (fixed-mark) ((last-update :accessor last-update :initarg :last-update))) ) (defclass editable-area-line (dbl-list) ((buffer-line :accessor buffer-line :initarg :buffer-line) (last-tick :accessor last-tick :initarg :last-tick) (editable-area :accessor editable-area :initarg :editable-area :documentation "backpointer"))) ;;; XXX mostly garbage at the moment... #+nil (defmethod add-new-lines ((win window)) (with-accessors ((buf buffer) (line-marks line-marks) (lines lines)) win (setf (dbl-head line-marks) nil) (setf (dbl-head lines) nil) (let ((start-line-pos (at (frame-begin-mark win)))) (loop for line-count from 0 below (rows win) for line-pos = start-line-pos then (position-forward buffer #\Newline (1+ prev-line-pos)) for prev-line-pos = 0 then line-pos while line-pos for line-mark = (insert-mark-using-class 'line-mark (1+ line-pos) :last-update (update-counter win)) for prev-line-mark-dbl = line-marks then line-mark-dbl for line-mark-dbl = (insert-obj-after line-mark prev-line-mark-dbl) for line = (make-instance 'line :mark line-mark :last-update (update-counter win)) for prev-line-dbl = lines then line-dbl for line-dbl = (insert-obj-after line prev-line-dbl))) (loop for line-dbl = (dbl-head lines) then (next line-dbl) while line-dbl for line = (contents line-dbl) do (let* ((start-line (at (mark line))) (end-line (if (next line-dbl) (1- (at (mark (contents (next line-dbl))))) (position-forward buffer #\Newline (1+ start-line)))) (line-length (- start-line end-line)) (chars (make-array line-length :element-type 'character :adjustable t :fill-pointer line-length))) (buffer-string-into buffer chars :start2 start-line :end2 end-line) (setf (chars line) chars))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Goatee/editing-stream.lisp0000644000175000017500000003647511345155773022042 0ustar pdmpdm;;; -*- Mode: Lisp; Package: GOATEE -*- ;;; (c) copyright 2002 by Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :goatee) ;;; Interface between input-editing-streams and Goatee areas. (defclass editing-stream-snapshot () ((buffer :reader stream-input-buffer :initform (make-array 16 :adjustable t :fill-pointer 0)) (insertion-pointer :accessor stream-insertion-pointer :initform 0) (scan-pointer :accessor stream-scan-pointer :initform 0))) (defclass goatee-input-editing-mixin () ((area :accessor area :initarg :area) (snapshot :accessor snapshot :initarg :snapshot :initform (make-instance 'editing-stream-snapshot)))) (defmethod cursor-visibility ((stream goatee-input-editing-mixin)) (cursor-visibility (area stream))) (defmethod (setf cursor-visibility) (visibility (stream goatee-input-editing-mixin)) (setf (cursor-visibility (area stream)) visibility)) (defclass noise-extent (extent) () (:documentation "Characters within the extent are input editor noise strings. Eventually these should be read-only and atomic.")) (defclass accept-result-extent (extent) ((object :accessor object :initarg :object) (result-type :accessor result-type :initarg :result-type)) (:documentation "The extent is read with a single read-gesture; result is returned.")) ;;; Stream is the encapsulated stream (defmethod initialize-instance :after ((obj goatee-input-editing-mixin) &rest args &key stream (initial-contents "") (cursor-visibility t) (background-ink (medium-background stream)) single-line) (multiple-value-bind (cx cy) (stream-cursor-position stream) (let ((max-width (- (stream-text-margin stream) cx))) ;; XXX hack to give area a fixed size rectangle that can be highlighted (with-output-recording-options (stream :record t) (draw-rectangle* stream cx cy (+ cx max-width) (+ cy (stream-line-height stream)) :ink background-ink :filled t)) (climi::with-keywords-removed (args (:initial-contents :single-line)) (setf (area obj) (apply #'make-instance 'simple-screen-area :area-stream stream :buffer (make-instance 'editable-buffer :initial-contents initial-contents :newline-character (if single-line nil #\Newline)) :x-position cx :y-position cy :cursor-visibility cursor-visibility :max-width max-width :allow-other-keys t args))) ;; XXX Really add it here? (stream-add-output-record stream (area obj)) #+nil (redisplay-area (area obj)) ;; initialize input-editing-stream state to conform to our reality (make-input-editing-stream-snapshot obj (area obj))))) (defvar climi::*noise-string-start*) (defvar climi::*noise-string*) (defun make-input-editing-stream-snapshot (snapshot area) (let ((buffer (buffer area)) (input-buffer (stream-input-buffer snapshot))) (multiple-value-bind (point-line point-pos) (point* buffer) (setf (fill-pointer input-buffer) 0) (map-over-region #'(lambda (line pos) (let ((noise nil)) (map-over-extents-at-location* #'(lambda (extent line pos) (cond ((typep extent 'noise-extent) (if (and (eq line (line (bp-start extent))) (eql pos (pos (bp-start extent)))) (setq noise climi::*noise-string-start*) (setq noise climi::*noise-string*))) ((typep extent 'accept-result-extent) (if (and (eq line (line (bp-start extent))) (eql pos (pos (bp-start extent)))) (setq noise extent) (setq noise climi::*noise-string*))))) line pos :start-state :closed :end-state :open) (vector-push-extend (or noise (char-ref line pos)) input-buffer))) buffer (buffer-start buffer) (buffer-end buffer)) (setf (stream-insertion-pointer snapshot) (offset-location* buffer point-line point-pos))))) (defmethod update-input-editing-stream ((stream goatee-input-editing-mixin)) (let ((area (area stream)) (snapshot (snapshot stream))) (make-input-editing-stream-snapshot snapshot area) (let ((first-mismatch (mismatch (stream-input-buffer snapshot) (stream-input-buffer stream))) (snapshot-buffer (stream-input-buffer snapshot)) (stream-buffer (stream-input-buffer stream))) (setf (stream-insertion-pointer stream) (stream-insertion-pointer snapshot)) (when (< (car (array-dimensions stream-buffer)) (fill-pointer snapshot-buffer)) (adjust-array stream-buffer (fill-pointer snapshot-buffer))) (setf (fill-pointer stream-buffer) (fill-pointer snapshot-buffer)) (when (and first-mismatch (>= (fill-pointer snapshot-buffer) first-mismatch)) (replace stream-buffer snapshot-buffer :start1 first-mismatch :start2 first-mismatch)) first-mismatch))) (defmethod stream-process-gesture ((stream goatee-input-editing-mixin) gesture type) (declare (ignore type)) (when (activation-gesture-p gesture) (setf (stream-insertion-pointer stream) (fill-pointer (stream-input-buffer stream))) (set-editing-stream-insertion-pointer stream (stream-insertion-pointer stream)) (setf (climi::activation-gesture stream) gesture) (rescan-if-necessary stream) (return-from stream-process-gesture gesture)) (let ((area (area stream)) (snapshot (snapshot stream))) (execute-gesture-command gesture area *simple-area-gesture-table*) (make-input-editing-stream-snapshot snapshot area) (let ((first-mismatch (mismatch (stream-input-buffer snapshot) (stream-input-buffer stream)))) (unwind-protect (cond ((null first-mismatch) ;; No change actually took place, event though IP may have ;; moved. nil) ((< first-mismatch (stream-scan-pointer stream)) ;; Throw out. Buffer is still updated by protect forms (immediate-rescan stream)) ((and (eql first-mismatch (1- (stream-insertion-pointer snapshot))) (eql (aref (stream-input-buffer snapshot) first-mismatch) gesture)) ;; As best we can tell an insertion happened: one gesture was ;; entered it was inserted in the buffer. There may be other ;; changes above IP, but we don't care. gesture) (t ;; Other random changes, but we want to allow more editing ;; before scanning them. (queue-rescan stream) nil)) (let ((snapshot-buffer (stream-input-buffer snapshot)) (stream-buffer (stream-input-buffer stream))) (setf (stream-insertion-pointer stream) (stream-insertion-pointer snapshot)) (when (< (car (array-dimensions stream-buffer)) (fill-pointer snapshot-buffer)) (adjust-array stream-buffer (fill-pointer snapshot-buffer))) (setf (fill-pointer stream-buffer) (fill-pointer snapshot-buffer)) (when (and first-mismatch (>= (fill-pointer snapshot-buffer) first-mismatch)) (replace stream-buffer snapshot-buffer :start1 first-mismatch :start2 first-mismatch))))))) (defun reposition-stream-cursor (stream) "Moves the cursor somewhere clear of Goatee's editing area." (let ((max-y 0)) (map-over-output-records #'(lambda (r) (setf max-y (max max-y (bounding-rectangle-max-y r)))) (stream-output-history stream)) (setf (stream-cursor-position stream) (values 0 max-y)))) (defmethod climi::finalize ((stream goatee-input-editing-mixin) input-sensitizer) (call-next-method) (setf (cursor-visibility (cursor (area stream))) nil) (let ((real-stream (encapsulating-stream-stream stream)) (record (area stream))) (when input-sensitizer (erase-output-record record real-stream) (funcall input-sensitizer real-stream #'(lambda () (stream-add-output-record real-stream record) (when (stream-drawing-p real-stream) #+nil (format *trace-output* "Redisplaying ~S~&" record) (replay record real-stream))))) (reposition-stream-cursor real-stream))) ;;; Hopefully only used on small buffers. (defun location*-offset (buffer offset) (loop for line = (dbl-head (lines buffer)) then (next line) for size = (and line (size line)) while line summing size into total-offset do (when (>= total-offset offset) (let ((pos (- size (- total-offset offset)))) (if (> pos (line-last-point line)) (return (values (next line) 0)) (return (values line pos))))) finally (error 'goatee-error :format-control "Offset ~S is greater than the ~ size of buffer ~S" :format-arguments (list offset buffer)))) (defun offset-location* (buffer line pos) (loop with end-line = (location* (buffer-end buffer)) for buf-line = (location* (buffer-start buffer)) then (next buf-line) until (or (eq buf-line line) (eq buf-line end-line)) summing (size buf-line) into total-offset finally (progn (unless (eq buf-line line) (error 'goatee-error :format "Location line ~S pos ~S isn't in buffer ~S" :format-arguments (list line pos buffer))) (return (+ total-offset pos))))) (defgeneric set-editing-stream-insertion-pointer (stream pointer)) (defmethod set-editing-stream-insertion-pointer ((stream goatee-input-editing-mixin) pointer) (let* ((area (area stream)) (buffer (buffer area))) (setf (point* buffer) (location*-offset buffer pointer)) (redisplay-area area))) (defmethod (setf stream-insertion-pointer) :after ((new-value integer) (stream goatee-input-editing-mixin)) (set-editing-stream-insertion-pointer stream new-value)) (defun %replace-input (stream new-input start end buffer-start rescan rescan-supplied-p extent-class &rest extent-args) (let* ((scan-pointer (stream-scan-pointer stream)) (area (area stream)) (buf (buffer area)) (del-chars (- scan-pointer buffer-start))) (when (stream-rescanning-p stream) (return-from %replace-input nil)) (if (<= 0 del-chars) (progn (with-point (buf) (multiple-value-bind (line pos) (location*-offset buf buffer-start) (when (> del-chars 0) (delete-char buf del-chars :line line :pos pos)) ;; location should be preserved across the delete-char, but ;; it would be safest to use a buffer pointer or something... (let ((extent (and extent-class (apply #'make-instance extent-class :start-line line :start-pos pos extent-args)))) (insert buf new-input :line line :pos pos :start start :end end) (when extent (setf (start-state extent) :open) (setf (end-state extent) :open)) (make-input-editing-stream-snapshot stream area) ;; If not rescanning, adjust scan pointer to point after new ;; input (if (and rescan-supplied-p (null rescan)) (setf (stream-scan-pointer stream) (offset-location* buf (line (point buf)) (pos (point buf)))) (queue-rescan stream))))) ;; XXX Redundant with make-input-editing-stream-snapshot? (setf (stream-insertion-pointer stream) (offset-location* buf (line (point buf)) (pos (point buf)))) (redisplay-area area)) (warn "replace-input stream ~S: buffer-start ~S is greater than ~ scan-pointer ~S. Don't know how to deal with that." stream buffer-start scan-pointer)))) (defvar climi::*current-input-stream*) (defvar climi::*current-input-position*) (defmethod replace-input ((stream goatee-input-editing-mixin) new-input &key (start 0) (end (length new-input)) (buffer-start nil buffer-start-supplied-p) (rescan nil rescan-supplied-p)) (unless buffer-start-supplied-p (if (eq stream climi::*current-input-stream*) (setq buffer-start climi::*current-input-position*) (setq buffer-start 0))) (%replace-input stream new-input start end buffer-start rescan rescan-supplied-p nil)) (defun present-acceptably-to-string (object type view for-context-type) (flet ((present-it (acceptably) (present-to-string object type :view view :acceptably acceptably :for-context-type for-context-type))) (let* ((acceptably t) (printed-rep nil)) (handler-case (setq printed-rep (present-it t)) (error () (setq acceptably nil) (setq printed-rep (present-it nil)))) (values printed-rep (if acceptably nil object))))) (defmethod presentation-replace-input ((stream goatee-input-editing-mixin) object type view &key (buffer-start nil buffer-start-supplied-p) (rescan nil rescan-supplied-p) query-identifier (for-context-type type)) (declare (ignore query-identifier)) (multiple-value-bind (printed-rep accept-object) (present-acceptably-to-string object type view for-context-type) (unless buffer-start-supplied-p (if (eq stream climi::*current-input-stream*) (setq buffer-start climi::*current-input-position*) (setq buffer-start 0))) (apply #'%replace-input stream printed-rep 0 (length printed-rep) buffer-start rescan rescan-supplied-p (if accept-object `(accept-result-extent :object ,accept-object :result-type ,type) '(nil))))) ;;; There used to be complicated logic here to support output when ;;; rescanning, but it seems to be very hairy to get right in ;;; combination with read-gesture's behavior upon seeing noise ;;; strings, especially with respect to peek and unread-gesture. So, just ;;; suppress printing the noise string unless we're at the end of the ;;; buffer and can't screw anything up. (defmethod input-editor-format ((stream goatee-input-editing-mixin) format-string &rest format-args) (let* ((scan-pointer (stream-scan-pointer stream)) (area (area stream)) (buf (buffer area)) (output (apply #'format nil format-string format-args))) (when (stream-rescanning-p stream) (return-from input-editor-format nil)) (multiple-value-bind (line pos) (location*-offset buf scan-pointer) (let ((extent (make-instance 'noise-extent :start-line line :start-pos pos))) (with-point (buf) (insert buf output :line line :pos pos)) (setf (start-state extent) :open) (setf (end-state extent) :open) (setf (stream-scan-pointer stream) (offset-location* buf (line (bp-end extent)) (pos (bp-end extent)))) (make-input-editing-stream-snapshot stream area) (redisplay-area area)))) nil) (defmethod redraw-input-buffer ((stream goatee-input-editing-mixin) &optional (start-position 0)) (declare (ignore start-position)) (redisplay-area (area stream))) (defmethod erase-input-buffer ((stream goatee-input-editing-mixin) &optional (start-position 0)) (declare (ignore start-position)) (clear-output-record (area stream))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Goatee/buffer.lisp0000644000175000017500000004375410136747166020375 0ustar pdmpdm;;; -*- Mode: Lisp; Package: GOATEE -*- ;;; (c) copyright 2002 by Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :goatee) (defclass location () ((line :accessor line :initarg :line) (pos :accessor pos :initarg :pos)) (:documentation "A location in a buffer.")) (defmethod location* ((bp location)) (values (line bp) (pos bp))) (defgeneric* (setf location*) (line pos bp)) (defmethod* (setf location*) (line pos (bp location)) (setf (values (line bp) (pos bp)) (values line pos))) ;;; Is this too massive a hack? (defgeneric copy-location (location)) (defmethod copy-location ((loc location)) (make-instance (class-of loc) :line (line loc) :pos (pos loc))) ;;; basic-buffer must implement: ;;; lines - returns the lines of a buffer ;;; tick - a counter incremented after *any* change to a buffer ;;; size ;;; buffer-insert* ;;; buffer-delete-char* ;;; buffer-open-line* ;;; buffer-close-line* ;;; ;;; All modifications to a buffer are done through those 4 generic ;;; functions, so subclasses can update themselves via ;;;;before/after/around methods on them. (defclass basic-buffer () () (:documentation "basic-buffer is a protocol class that specifies basic insert and delete operations on a buffer of text (generally).")) (defclass basic-buffer-mixin (basic-buffer) ((lines :accessor lines :initarg :lines) (tick :accessor tick :initarg :tick) (size :reader size :initform 0) (newline-character :accessor newline-character :initarg :newline-character :documentation "The character that ends a line. NIL means that the buffer will only have one line.")) (:default-initargs :lines (make-instance 'dbl-list-head) :tick 0 :newline-character #\Newline)) (define-condition buffer-bounds-error (goatee-error) ((buffer :reader buffer-bounds-error-buffer :initarg :buffer :initform nil) (line :reader buffer-bounds-error-line :initarg :line :initform nil) (pos :reader buffer-bounds-error-pos :initarg :pos :initform nil)) (:report (lambda (condition stream) (format stream "In buffer ~S, position line ~S pos ~S is ~ out of bounds" (buffer-bounds-error-buffer condition) (buffer-bounds-error-line condition) (buffer-bounds-error-pos condition))))) (defclass buffer-line (flexivector dbl-list) ((buffer :accessor buffer :initarg :buffer) (tick :accessor tick :initarg :tick :initform 0))) (defgeneric make-buffer-line (buffer &rest initargs) (:documentation "Creates line instances for a buffer")) (defmethod make-buffer-line ((buffer basic-buffer-mixin) &rest initargs) (apply #'make-instance 'buffer-line :buffer buffer initargs)) (defmethod initialize-instance :after ((obj basic-buffer-mixin) &key) (dbl-insert-after (make-buffer-line obj :tick (incf (tick obj))) (lines obj))) (defgeneric first-line-p (line) (:documentation "Returns true if line is the first line in a buffer")) (defmethod first-line-p ((line buffer-line)) (not (typep (prev line) 'buffer-line))) (defgeneric last-line-p (line) (:documentation "Returns true if line is the last line in a buffer")) (defmethod last-line-p ((line buffer-line)) (null (next line))) (defgeneric char-ref (buffer position)) (defmethod char-ref ((buf basic-buffer) position) (char-ref (line position) (pos position))) (defmethod char-ref* ((buf basic-buffer) line pos) (char-ref line pos)) (defgeneric buffer-open-line* (buffer line pos) (:documentation "Insert a newline at POS in LINE, creating a new line that contains LINEs contents from POS to the end of LINE. Returns the position (spread) of the beginning of the new line")) (defmethod buffer-open-line* ((buf basic-buffer-mixin) (line buffer-line) pos) (let ((len (size line))) (if (<= pos len) ;XXX throw an error? (let ((new-line (make-buffer-line buf :buffer buf :initial-store (flexivector-string line :start pos) :tick (incf (tick buf))))) ;; delete to end of line (delete-char line (- (size line) pos) :position pos) (insert line (newline-character buf) :position pos) (setf (tick line) (incf (tick buf))) (dbl-insert-after new-line line) (incf (slot-value buf 'size)) (values new-line 0)) (error 'buffer-bounds-error :buffer buf :line line :pos pos)))) (defgeneric buffer-insert* (buffer thing line pos &key) (:documentation "Insert a THING (character or string) into BUFFER.")) (defmethod buffer-insert* ((buffer basic-buffer-mixin) (c character) line pos &key) (when (or (> pos (line-last-point line)) (< pos 0)) (error 'buffer-bounds-error :buffer buffer :line line :pos pos)) (insert line c :position pos) (incf (slot-value buffer 'size)) (setf (tick line) (incf (tick buffer))) (values line (1+ pos))) (defmethod buffer-insert* ((buffer basic-buffer-mixin) (s string) line pos &key (start 0) (end (length s))) (when (or (> pos (line-last-point line)) (< pos 0)) (error 'buffer-bounds-error :buffer buffer :line line :pos pos)) (let ((len (- end start))) (insert line s :position pos :start start :end end) (incf (slot-value buffer 'size) len) (setf (tick line) (incf (tick buffer))) (values line (+ pos len)))) (defgeneric buffer-close-line* (buffer line direction) (:documentation "If DIRECTION is positive, delete the newline at the end of line, bring the following line's contents onto line, and delete the following line. If DIRECTION is negative, first move back one line, then do the deletion." )) (defmethod buffer-close-line* ((buffer basic-buffer-mixin) line direction) (multiple-value-bind (this-line next-line) (if (< 0 direction) (values line (next line)) (values (prev line) line)) (unless (typep this-line 'dbl-list) (error 'buffer-bounds-error :buffer buffer :line nil :pos 0)) (let ((line-size (size this-line)) (newline-character (newline-character buffer))) (if (eql (char-ref this-line (1- line-size)) newline-character) (progn (delete-char this-line 1 :position (1- line-size)) (decf (slot-value buffer 'size)) (when next-line (loop for i from 0 below (size next-line) for j from (1- line-size) do (insert this-line (char-ref next-line i) :position j)) (dbl-remove next-line)) (setf (tick this-line) (incf (tick buffer))) (values this-line (1- line-size))) (error 'buffer-bounds-error :buffer buffer :line this-line :pos line-size))))) (defgeneric buffer-delete-char* (buffer line pos n) (:documentation "Delete characters from a line. Can not delete the final newline or characters before the beginning of the line")) (defmethod buffer-delete-char* ((buffer basic-buffer-mixin) line pos n) (multiple-value-prog1 (if (>= n 0) (progn (when (> (+ pos n) (line-last-point line)) (error 'buffer-bounds-error :buffer buffer :line line :pos pos)) (delete-char line n :position pos) (decf (slot-value buffer 'size) n) (values line pos)) (progn (when (< (+ pos n) 0) (error 'buffer-bounds-error :buffer buffer :line line :pos pos)) (delete-char line n :position pos) (incf (slot-value buffer 'size) n) (values line (+ pos n)))) (setf (tick line) (incf (tick buffer))))) ;;; The need for these should go away once we have real buffer pointers... ;;; ... but we'll keep 'em around; these might be useful for basic-buffers even ;;; though they're overridden by methods on editable-buffer. (defmethod beginning-of-buffer* ((buf basic-buffer)) (values (dbl-head (lines buf)) 0)) (defmethod end-of-buffer* ((buf basic-buffer)) (loop for line = (dbl-head (lines buf)) then (next line) while (next line) finally (return (end-of-line* buf :line line)))) ;;; Buffer pointers and the bp-buffer-mixin that maintains them. (defclass bp-buffer-mixin () ()) (defclass bp-buffer-line (buffer-line) ((bps :accessor bps :initarg :bps :initform nil))) (defmethod make-buffer-line ((buffer bp-buffer-mixin) &rest initargs) (apply #'make-instance 'bp-buffer-line :buffer buffer initargs)) (defclass buffer-pointer (location) () (:documentation "Buffer pointer that moves with insertions at its location")) (defmethod initialize-instance :after ((obj buffer-pointer) &key) (when (slot-boundp obj 'line) (push obj (bps (line obj))))) (defmethod (setf line) (new-line (bp buffer-pointer)) (let* ((was-bound (slot-boundp bp 'line)) (old-line (and was-bound (line bp)))) (when (and was-bound old-line (not (eq old-line new-line))) (setf (bps old-line) (delete bp (bps old-line)))) (prog1 (call-next-method) (when (and new-line (not (and was-bound (eq old-line new-line)))) (push bp (bps (line bp))))))) (defgeneric update-for-insert (bp pos delta)) (defmethod update-for-insert ((bp buffer-pointer) pos delta) (when (>= (pos bp) pos) (incf (pos bp) delta))) (defclass fixed-buffer-pointer (buffer-pointer) () (:documentation "Buffer pointer that doesn't move with insertions at its location")) (defmethod update-for-insert ((bp fixed-buffer-pointer) pos delta) (when (> (pos bp) pos) (incf (pos bp) delta))) (defmethod buffer-insert* :after ((buffer basic-buffer-mixin) (c character) line pos &key) (loop for bp in (bps line) do (update-for-insert bp pos 1))) (defmethod buffer-insert* :after ((buffer basic-buffer-mixin) (s string) line pos &key (start 0) (end (length s))) (loop with len = (- end start) for bp in (bps line) do (update-for-insert bp pos len))) (defmethod buffer-delete-char* :after ((buffer bp-buffer-mixin) line pos n) (cond ((> n 0) (loop for bp in (bps line) when (> (pos bp) pos) do (setf (pos bp) (max pos (- (pos bp) n))))) ((< n 0) (loop with new-pos = (+ pos n) for bp in (bps line) do (cond ((>= (pos bp) pos) (incf (pos bp) n)) ((> (pos bp) new-pos) (setf (pos bp) new-pos))))))) (defmethod buffer-open-line* :around ((buf bp-buffer-mixin) (line bp-buffer-line) pos) (multiple-value-bind (new-line new-pos) (call-next-method) (loop for bp in (bps line) if (typecase bp (fixed-buffer-pointer (> (pos bp) pos)) (t (>= (pos bp) pos))) do (setf (line bp) new-line (pos bp) (- (pos bp) pos)) and collect bp into new-line-bps else collect bp into old-line-bps end finally (setf (bps line) old-line-bps (bps new-line) new-line-bps)) (values new-line new-pos))) (defmethod buffer-close-line* :around ((buffer bp-buffer-mixin) (line bp-buffer-line) direction) (multiple-value-bind (this-line next-line) (if (< 0 direction) (values line (next line)) (values (prev line) line)) (multiple-value-bind (line new-pos) (call-next-method) (loop for bp in (bps next-line) do (progn (incf (pos bp) new-pos) (setf (line bp) this-line))) (values line new-pos)))) (defmacro with-buffer-pointer* ((bp-var line pos &key (class ''buffer-pointer)) &body body) "Like with-buffer-pointer, but takes line and pos as initialization arguments." (let ((bp-temp (gensym))) `(let* ((,bp-temp (make-instance ,class :line ,line :pos ,pos)) (,bp-var ,bp-temp)) (unwind-protect (progn ,@body) (setf (line ,bp-temp) nil))))) (defmacro with-buffer-pointer ((bp-var location &key (class ''buffer-pointer)) &body body) "binds bp-var to a buffer pointer initialized to location. Class is the class of the buffer pointer, defaulting to 'buffer-pointer. bp-var is deallocated when at exit from the form." (let ((line-var (gensym "LINE")) (pos-var (gensym "POS"))) `(multiple-value-bind (,line-var ,pos-var) (location* ,location) (with-buffer-pointer* (,bp-var ,line-var ,pos-var :class ,class) ,@body)))) (defclass extent () ((bp-start :reader bp-start) (bp-end :reader bp-end)) (:documentation "A delimited region in a buffer. The concept follows extents in XEmacs, though the interface is more in line with Common Lisp.")) (defmethod initialize-instance :after ((obj extent) &key start-line start-pos (end-line start-line) (end-pos start-pos) (start-state :closed) (end-state :closed)) ;; Subclasses could provide values for bp-start and bp-end through ;; initargs. (unless (slot-boundp obj 'bp-start) (setf (slot-value obj 'bp-start) (make-instance (if (eq start-state :open) 'buffer-pointer 'fixed-buffer-pointer) :line start-line :pos start-pos))) (unless (slot-boundp obj 'bp-end) (setf (slot-value obj 'bp-end) (make-instance (if (eq end-state :open) 'fixed-buffer-pointer 'buffer-pointer) :line end-line :pos end-pos))) (when (and start-line end-line) (record-extent-lines obj))) (defclass extent-buffer-mixin (bp-buffer-mixin) () (:documentation "Buffer class that maintains extents.")) (defclass extent-buffer-line (bp-buffer-line) ((extents :accessor extents :initarg :extents :initform nil :documentation "Holds any extents that contain this line, including ones that start and finish on it. Eventually the extents in this list will be kept in \"display\" order." ))) (defmethod make-buffer-line ((buffer extent-buffer-mixin) &rest initargs) (apply #'make-instance 'extent-buffer-line :buffer buffer initargs)) (defmethod record-extent-lines ((extent extent)) (loop for line = (line (bp-start extent)) then (next line) until (eq line (line (bp-end extent))) do (push extent (extents line)) finally (push extent (extents line)))) (defmethod detach-extent ((extent extent)) (loop for line = (line (bp-start extent)) then (next line) until (eq line (lines (bp-end extent))) do (setf (extents line) (delete extent (extents line))) finally (setf (extents line) (delete extent (extents line)))) (setf (line (bp-start extent)) nil) (setf (line (bp-end extent)) nil)) (defmethod start-state ((extent extent)) (if (typep (bp-start extent) 'fixed-buffer-pointer) :closed :open)) (defmethod (setf start-state) (new-val (extent extent)) (with-slots (bp-start) extent (if (eq new-val :open) (when (typep bp-start 'fixed-buffer-pointer) (setf bp-start (change-class bp-start 'buffer-pointer))) (when (not (typep bp-start 'fixed-buffer-pointer)) (setf bp-start (change-class bp-start 'fixed-buffer-pointer)))))) (defmethod end-state ((extent extent)) (if (typep (bp-end extent) 'fixed-buffer-pointer) :open :closed)) (defmethod (setf end-state) (new-val (extent extent)) (with-slots (bp-end) extent (if (eq new-val :open) (when (not (typep bp-end 'fixed-buffer-pointer)) (setf bp-end (change-class bp-end 'fixed-buffer-pointer))) (when (typep bp-end 'fixed-buffer-pointer) (setf bp-end (change-class bp-end 'buffer-pointer)))))) (defmethod buffer-open-line* :around ((buf extent-buffer-mixin) (line extent-buffer-line) pos) (declare (ignore pos)) (multiple-value-bind (new-line new-pos) (call-next-method) (loop for extent in (extents line) for bp-start = (bp-start extent) for bp-end = (bp-end extent) if (or (not (eq (line bp-start) line)) (eq (line bp-end) new-line)) collect extent into new-line-extents end if (not (eq (line bp-start) new-line)) collect extent into old-line-extents end finally (setf (extents line) old-line-extents (extents new-line) new-line-extents)) (values new-line new-pos))) (defmethod buffer-close-line* :around ((buffer extent-buffer-mixin) (line extent-buffer-line) direction) (multiple-value-bind (this-line next-line) (if (< 0 direction) (values line (next line)) (values (prev line) line)) (multiple-value-bind (line new-pos) (call-next-method) (let ((this-line-extents (extents this-line)) (next-line-extents (extents next-line))) (loop for extent in next-line-extents if (not (member extent this-line-extents :test #'eq)) collect extent into new-extents end finally (setf (extents line) (nconc this-line-extents new-extents))) (values line new-pos))))) (defun line-last-point (line) "Returns the last legal value for a position on a line, which is either before the newline, if there is one, or after the last character." (let* ((size (size line)) (last-char (if (> size 0) (char-ref line (1- size)) nil)) (newline-char (newline-character (buffer line)))) (cond ((and last-char newline-char (char= last-char newline-char)) (1- size)) (t size)))) (defmethod map-over-extents-at-location* (func (line extent-buffer-line) pos &key (start-state nil start-statep) (end-state nil end-statep)) (loop for extent in (extents line) for bp-start = (bp-start extent) for bp-end = (bp-end extent) for extent-start-state = (or (and start-statep start-state) (start-state extent)) for extent-end-state = (or (and end-statep end-state) (end-state extent)) do (let* ((start-test (if (eq extent-start-state :open) #'> #'>=)) (end-test (if (eq extent-end-state :open) #'< #'<=)) (do-func (cond ((and (eq (line bp-start) line) (eq (line bp-end) line)) (and (funcall start-test pos (pos bp-start)) (funcall end-test pos (pos bp-end)))) ((eq (line bp-start) line) (funcall start-test pos (pos bp-start))) ((eq (line bp-end) line) (funcall end-test pos (pos bp-end))) (t t)))) (when do-func (funcall func extent line pos))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Goatee/goatee-command.lisp0000640000175000017500000003314210561555374021766 0ustar pdmpdm;;; -*- Mode: Lisp; Package: GOATEE -*- ;;; (c) copyright 2002 by Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :goatee) ;;; dispatching commands and, eventually, defining commands ;;; A gesture table is a hash table keyed by keyboard gesture (and ;;; pointer gesture too?) name. The value is an alist of ;;; (modifier-bits . command-name). ;;; ;;; XXX This is looking up keysym names, not gestures. Do we care? ;;; Probably... (defparameter *simple-area-gesture-table* (make-hash-table)) (defvar *kill-ring* (make-ring)) (defvar *last-command* nil) (defvar *insert-extent* nil) ;; This doesn't match the emacs behavior exactly, but I think these make more ;; sense for working in lisp. +,*,and others are what's missing. (defparameter *word-delimiters* (concatenate 'string "() {}[]-:;,.#'`&\"" '(#\newline #\linefeed #\tab #\return)) "Characters which delimit words for the Meta-F/B/etc movement commands.") (defun add-gesture-command-to-table (gesture-spec command-name table) (multiple-value-bind (gesture-name modifier-bits) (if (atom gesture-spec) (values gesture-spec 0) (values (car gesture-spec) (apply #'make-modifier-state (cdr gesture-spec)))) (push (cons modifier-bits command-name) (gethash gesture-name table nil)))) (defgeneric lookup-gesture-command (gesture table)) (defmethod lookup-gesture-command :around (gesture table) (declare (ignore table)) (if (activation-gesture-p gesture) #'insert-activation-gesture (call-next-method))) (defmethod lookup-gesture-command ((gesture character) table) (cdr (assoc 0 (gethash gesture table nil)))) (defmethod lookup-gesture-command ((gesture key-press-event) table) (let ((modifier-state (logandc1 climi::+alt-key+ (event-modifier-state gesture)))) #+nil (format *trace-output* "lookup-gesture-command: ~S ~S~%" modifier-state (keyboard-event-character gesture)) (cdr (assoc modifier-state (gethash (or (keyboard-event-character gesture) (keyboard-event-key-name gesture)) table nil))))) (defmethod lookup-gesture-command (gesture table) (declare (ignore gesture table)) nil) (defvar *area*) (defvar *buffer*) (defvar *error-fallthrough* nil) (defmethod execute-gesture-command (gesture (area editable-area) table) (let ((command (lookup-gesture-command gesture table))) (if command (let ((*area* area) (*buffer* (buffer area))) (block error-out (handler-bind ((goatee-error #'(lambda (c) (unless *error-fallthrough* (print c *trace-output*) (beep) (return-from error-out nil))))) (funcall command :input-gesture gesture) (setf *last-command* command) (setf (last-command area) command))) (redisplay-area area))))) ;; Utilities for the word movement commands (defun move-until (movefn test) (let ((line (point* *buffer*))) (loop do (funcall movefn) until (or (not (eq line (point* *buffer*))) (funcall test (char-ref *buffer* (point *buffer*))))))) (defun move-until-test-first (movefn test) (loop for c = (char-ref *buffer* (point *buffer*)) until (funcall test c) do (funcall movefn))) (defun insert-character (&key input-gesture &allow-other-keys) (insert *buffer* input-gesture)) ;;; Will take numeric argument (defun delete-character (&key &allow-other-keys) (delete-char *buffer*)) (defun backwards-delete-character (&key &allow-other-keys) (delete-char *buffer* -1)) (defun forward-character (&key &allow-other-keys) (setf (point* *buffer*) (forward-char* *buffer* 1))) (defun backward-character (&key &allow-other-keys) (setf (point* *buffer*) (forward-char* *buffer* -1))) ;; Why must I handle both flexivector and buffer bounds errors below? (defun forward-word (&key &allow-other-keys) (handler-case (progn (move-until-test-first #'forward-character #'(lambda (c) (not (find c *word-delimiters* :test #'char=)))) (move-until-test-first #'forward-character #'(lambda (c) (find c *word-delimiters* :test #'char=)))) (buffer-bounds-error ()) (flexivector-bounds-error ()))) (defun backward-word (&key &allow-other-keys) (handler-case (progn (move-until #'backward-character #'(lambda (c) (not (find c *word-delimiters* :test #'char=)))) (move-until #'backward-character #'(lambda (c) (find c *word-delimiters* :test #'char=))) (forward-character)) (buffer-bounds-error ()) (flexivector-bounds-error ()))) (defun backwards-delete-word (&key &allow-other-keys) (flet ((current-loc () (multiple-value-bind (line pos) (point* *buffer*) (make-instance 'location :line line :pos pos)))) (let ((end-location (current-loc))) (backward-word) (kill-region *kill-ring* *buffer* (current-loc) end-location)))) (defun delete-word (&key &allow-other-keys) (flet ((current-loc () (multiple-value-bind (line pos) (point* *buffer*) (make-instance 'location :line line :pos pos)))) (let ((start-location (current-loc))) (forward-word) (kill-region *kill-ring* *buffer* start-location (current-loc))))) (defun end-line (&key &allow-other-keys) (setf (point* *buffer*) (end-of-line* *buffer*))) (defun beginning-line (&key &allow-other-keys) (setf (point* *buffer*) (beginning-of-line* *buffer*))) (defun insert-activation-gesture (&key input-gesture &allow-other-keys) (setf (point* *buffer*) (end-of-buffer* *buffer*)) (insert *buffer* input-gesture)) (defun clear-input-buffer (&key &allow-other-keys) (clear-buffer *buffer*)) (defun kill-line (&key &allow-other-keys) (multiple-value-bind (line pos) (point* *buffer*) (let* ((last-point (line-last-point line)) (start-location (make-instance 'location :line line :pos pos)) (end-location (make-instance 'location :line line :pos last-point))) (kill-region *kill-ring* *buffer* start-location end-location)))) (defun cmd-yank (&key &allow-other-keys) (multiple-value-bind (line pos) (point* *buffer*) (setf *insert-extent* (make-instance 'extent :start-line line :start-pos pos :end-state :open)) (format *trace-output* "cmd-yank: ~S, ~S~%" (pos (bp-start *insert-extent*)) (pos (bp-end *insert-extent*))) (yank *kill-ring* *buffer* *insert-extent*) (setf (slot-value *insert-extent* 'bp-end) (point *buffer*)) (setf (end-state *insert-extent*) :closed) (format *trace-output* "cmd-yank: ~S, ~S~%" (pos (bp-start *insert-extent*)) (pos (bp-end *insert-extent*))))) (defun cmd-yank-next (&key &allow-other-keys) (unless (or (eq *last-command* 'cmd-yank) (eq *last-command* 'cmd-yank-prev) (eq *last-command* 'cmd-yank-next)) ;; maybe do something better than an error? (error "Last operation was not a yank!")) (format *trace-output* "cmd-yank-next: ~S, ~S~%" (pos (bp-start *insert-extent*)) (pos (bp-end *insert-extent*))) (yank-next *kill-ring* *buffer* *insert-extent*)) (defun cmd-yank-prev (&key &allow-other-keys) (unless (or (eq *last-command* 'cmd-yank) (eq *last-command* 'cmd-yank-prev) (eq *last-command* 'cmd-yank-next)) ;; maybe do something better than an error? (error "Last operation was not a yank!")) (yank-prev *kill-ring* *buffer* *insert-extent*)) ;; Transposing (taken from climacs) (defun at-beginning-of-buffer-p (buffer) (and (first-line-p (line (point buffer))) (zerop (pos (point buffer))))) (defun at-end-of-line-p (buffer) (multiple-value-bind (line pos) (location* (point buffer)) (declare (ignore line)) (multiple-value-bind (eoline eolpos) (end-of-line* buffer) (declare (ignore eoline)) (= eolpos pos)))) (defun cmd-transpose-chars (&key &allow-other-keys) (unless (at-beginning-of-buffer-p *buffer*) (with-point (*buffer*) (when (at-end-of-line-p *buffer*) (backward-character)) (let ((object (char-ref *buffer* (point *buffer*)))) (delete-char *buffer*) (backward-character) (insert *buffer* object))))) ;; Line motion (defun up-line (&key &allow-other-keys) (move-lines -1)) (defun down-line (&key &allow-other-keys) (move-lines 1)) (defun move-lines (n) (unless (goal-column-preserving-p (last-command *area*)) (setf (goal-column *area*) (pos (point *buffer*)))) (setf (point* *buffer*) (next-line *buffer* n :pos (goal-column *area*)))) (defun goal-column-preserving-p (cmd) (member cmd '(up-line down-line))) (loop for i from (char-code #\space) to (char-code #\~) do (add-gesture-command-to-table (code-char i) 'insert-character *simple-area-gesture-table*)) ;;; people who use dead keys get to implement code for that in Goatee. (loop for i from 160 to 255 do (add-gesture-command-to-table (code-char i) 'insert-character *simple-area-gesture-table*)) (add-gesture-command-to-table #\tab 'insert-character *simple-area-gesture-table*) (add-gesture-command-to-table #\newline 'insert-character *simple-area-gesture-table*) ;; I've changed the key mapping around a bit in an attempt ;; to get things more emacs-like. --Hefner (add-gesture-command-to-table #\Backspace 'backwards-delete-character *simple-area-gesture-table*) (add-gesture-command-to-table '(#\d :control) 'delete-character *simple-area-gesture-table*) (add-gesture-command-to-table '(#\Rubout) 'delete-character *simple-area-gesture-table*) (add-gesture-command-to-table '(#\f :control) 'forward-character *simple-area-gesture-table*) (add-gesture-command-to-table '(:right) 'forward-character *simple-area-gesture-table*) (add-gesture-command-to-table '(#\b :control) 'backward-character *simple-area-gesture-table*) (add-gesture-command-to-table '(:left) 'backward-character *simple-area-gesture-table*) (add-gesture-command-to-table '(#\f :meta) 'forward-word *simple-area-gesture-table*) (add-gesture-command-to-table '(:right :meta) 'forward-word *simple-area-gesture-table*) (add-gesture-command-to-table '(:right :control) 'forward-word *simple-area-gesture-table*) (add-gesture-command-to-table '(#\b :meta) 'backward-word *simple-area-gesture-table*) (add-gesture-command-to-table '(:left :meta) 'backward-word *simple-area-gesture-table*) (add-gesture-command-to-table '(:left :control) 'backward-word *simple-area-gesture-table*) (add-gesture-command-to-table '(#\backspace :meta) 'backwards-delete-word *simple-area-gesture-table*) (add-gesture-command-to-table '(#\backspace :control) 'backwards-delete-word *simple-area-gesture-table*) (add-gesture-command-to-table '(#\d :meta) 'delete-word *simple-area-gesture-table*) (add-gesture-command-to-table '(#\rubout :meta) 'delete-word *simple-area-gesture-table*) (add-gesture-command-to-table '(#\rubout :control) 'delete-word *simple-area-gesture-table*) (add-gesture-command-to-table '(#\a :control) 'beginning-line *simple-area-gesture-table*) (add-gesture-command-to-table '(:home) 'beginning-line *simple-area-gesture-table*) (add-gesture-command-to-table '(#\e :control) 'end-line *simple-area-gesture-table*) (add-gesture-command-to-table '(:end) 'end-line *simple-area-gesture-table*) (add-gesture-command-to-table '(#\k :control) 'kill-line *simple-area-gesture-table*) (add-gesture-command-to-table '(#\u :control) 'clear-input-buffer *simple-area-gesture-table*) (add-gesture-command-to-table '(#\p :control) 'up-line *simple-area-gesture-table*) (add-gesture-command-to-table '(:up) 'up-line *simple-area-gesture-table*) (add-gesture-command-to-table '(#\n :control) 'down-line *simple-area-gesture-table*) (add-gesture-command-to-table '(:down) 'down-line *simple-area-gesture-table*) (add-gesture-command-to-table '(#\y :control) 'cmd-yank *simple-area-gesture-table*) (add-gesture-command-to-table '(#\t :control) 'cmd-transpose-chars *simple-area-gesture-table*) #+nil (add-gesture-command-to-table '(#\y :meta) 'cmd-yank-next *simple-area-gesture-table*) #+nil (add-gesture-command-to-table '(#\y :control :meta) 'cmd-yank-prev *simple-area-gesture-table*) ;;; Debugging fun (defun goatee-break (&key &allow-other-keys) (break)) (add-gesture-command-to-table '(#\b :control :meta) 'goatee-break *simple-area-gesture-table*) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Goatee/flexivector.lisp0000644000175000017500000002216707756672525021463 0ustar pdmpdm;;; -*- Mode: Lisp; Package: GOATEE -*- ;;; (c) copyright 2002 by Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :goatee) ;;; Much implementation is done in flexivector-base so we can easily ;;; create flexivectors with general elements (defclass flexivector-base () ((store :accessor store) (size :accessor size) (gap :accessor gap) (gap-size :accessor gap-size) (size-increment :accessor size-increment :initarg :size-increment :initform 32))) (defmethod initialize-instance :after ((obj flexivector-base) &key initial-store initial-contents (start 0) (end (when initial-contents (length initial-contents)))) (when (and initial-store initial-contents) (error "Only one of initial-store and initial-contents may be supplied.")) (if (or initial-store initial-contents) (let ((len (if initial-store (length initial-store) (- end start)) )) (cond (initial-contents (setf (store obj) (make-array len :element-type 'character)) (replace (store obj) initial-contents :start2 start :end2 end)) (initial-store (setf (store obj) initial-store))) (setf (size obj) len) (setf (gap obj) len) (setf (gap-size obj) 0)) (progn (setf (store obj) (make-array (size-increment obj) :element-type 'character)) (setf (size obj) 0) (setf (gap obj) 0) (setf (gap-size obj) (size-increment obj))))) (define-condition flexivector-bounds-error (goatee-error) ((flexivector :reader flexivector-bounds-error-flexivector :initarg :flexivector :initform nil) (pos :reader flexivector-bounds-error-pos :initarg :pos :initform nil)) (:report (lambda (condition stream) (format stream "Position ~S is out of bounds for flexivector ~S~ of size ~S" (flexivector-bounds-error-pos condition) (flexivector-bounds-error-flexivector condition) (size (flexivector-bounds-error-flexivector condition)))))) (defclass flexivector (flexivector-base) () (:documentation "A flexivector that stores characters")) (defmethod initialize-instance :after ((obj flexivector) &key initial-contents (start 0) (end (when initial-contents (length initial-contents)))) (if initial-contents (let ((len (- end start))) (setf (store obj) (make-array (- end start) :element-type 'character)) (replace (store obj) initial-contents :start2 start :end2 end) (setf (size obj) len) (setf (gap obj) len) (setf (gap-size obj) 0)) (progn (setf (store obj) (make-array (size-increment obj) :element-type 'character)) (setf (size obj) 0) (setf (gap obj) 0) (setf (gap-size obj) (size-increment obj))))) (defmethod print-object ((object flexivector) stream) (print-unreadable-object (object stream :type t) (write-char #\" stream) (loop for i from 0 below (size object) do (write-char (char-ref object i) stream)) (write-char #\" stream))) (defmethod char-ref ((fv flexivector) pos) (when (or (>= pos (size fv)) (< pos 0)) (error 'flexivector-bounds-error :flexivector fv :pos pos)) (if (< pos (gap fv)) (schar (store fv) pos) (schar (store fv) (+ pos (gap-size fv))))) (defgeneric gap-to-insertion-point (buf point)) (defmethod gap-to-insertion-point ((buf flexivector-base) point) (let ((gap (gap buf)) (store (store buf)) (gap-size (gap-size buf))) (cond ((eql point gap) (return-from gap-to-insertion-point nil)) ((> gap point) (replace store store :start1 (+ point gap-size) :end1 (+ gap gap-size) :start2 point :end2 gap)) (t (let ((point-in-store (+ point gap-size))) (replace store store :start1 gap :end1 (- point-in-store gap-size) :start2 (+ gap gap-size) :end2 point-in-store))))) (setf (gap buf) point)) (defgeneric ensure-point-gap (buf position len)) (defmethod ensure-point-gap ((buf flexivector-base) position len) (when (not (eql position (gap buf))) (gap-to-insertion-point buf position)) (unless (<= len (gap-size buf)) (let* ((new-gap-size (max len (size-increment buf))) (new-store-size (+ (size buf) new-gap-size)) (new-store (make-array new-store-size :element-type 'character))) (replace new-store (store buf) :end2 (gap buf)) (replace new-store (store buf) :start1 (+ (gap buf) new-gap-size) :start2 (+ (gap buf) (gap-size buf))) (setf (store buf) new-store) (setf (gap-size buf) new-gap-size)))) (defgeneric update-flexivector-for-insertion (buf len) (:documentation "Update the flexivector for an insertion at the gap (LEN is positive) or a backwards deletion at the gap (LEN is negative).")) (defmethod update-flexivector-for-insertion ((buf flexivector-base) len) (incf (size buf) len) (incf (gap buf) len) (decf (gap-size buf) len)) (defgeneric insert (vector thing &key position) (:documentation "Generalized insertion of THING into an ordered CONTAINTER at the generalized POSITION.")) (defmethod insert ((buf flexivector) (c character) &key (position 0)) "Insert character C into flexivector BUF at POSITION." (ensure-point-gap buf position 1) (setf (schar (store buf) position) c) (update-flexivector-for-insertion buf 1) buf) (defmethod insert ((buf flexivector) (str string) &key (position 0) (start 0) (end (length str))) "Insert string STR into flexivector BUF at POSITION." (let ((len (length str))) (ensure-point-gap buf position len) (replace (store buf) str :start1 position :start2 start :end2 end) (update-flexivector-for-insertion buf len)) buf) (defgeneric delete-element (buf &optional n &key position)) (defmethod delete-element ((buf flexivector-base) &optional (n 1) &key (position 0)) (ensure-point-gap buf position 0) (if (> n 0) (progn (incf (gap-size buf) n) (decf (size buf) n)) (update-flexivector-for-insertion buf n))) (defgeneric delete-char (buf &optional n &key position)) (defmethod delete-char ((buf flexivector) &optional (n 1) &key (position 0)) (delete-element buf n :position position)) (defgeneric flexivector-string (buf &key start end)) (defmethod flexivector-string ((buf flexivector) &key (start 0) (end (size buf))) (let* ((str-size (- end start)) (string (make-array str-size :element-type 'character))) (when (< start (gap buf)) (replace string (store buf) :start2 start :end2 (min end (gap buf)))) (when (> end (gap buf)) (replace string (store buf) :start1 (max 0 (- (gap buf) start)) :start2 (+ (max (gap buf) start) (gap-size buf)) :end2 (+ end (gap-size buf)))) string)) (defgeneric flexivector-string-into (buf string &key start1 end1 start2 end2)) (defmethod flexivector-string-into ((buf flexivector) string &key (start1 0) (end1 (length string)) (start2 0) (end2 (size buf))) (when (< start2 (gap buf)) (replace string (store buf) :start1 start1 :end1 end1 :start2 start2 :end2 (min end2 (gap buf)))) (when (> end2 (gap buf)) (replace string (store buf) :start1 (max start1 (- (gap buf) start2)) :end1 end1 :start2 (+ (max (gap buf) start2) (gap-size buf)) :end2 (+ end2 (gap-size buf)))) string) (defgeneric position-forward (buffer char &key position bound)) (defmethod position-forward ((buf flexivector) char &key (position 0) (bound (size buf))) (loop for pos from position below (min bound (gap buf)) do (when (eql char (schar (store buf) pos)) (return-from position-forward pos))) (when (<= bound (gap buf)) (return-from position-forward nil)) (loop for pos from (+ (gap buf) (gap-size buf)) below (+ (min bound (size buf)) (gap-size buf)) do (when (eql char (schar (store buf) pos)) (return-from position-forward (- pos (gap-size buf))))) nil) (defgeneric position-backward (buffer char &key position bound)) (defmethod position-backward ((buf flexivector) char &key (position (1- (size buf))) (bound 0)) ;; First loop only happens when (> position gap) (loop for pos from (1- (+ position (gap-size buf))) downto (+ (gap buf) (gap-size buf)) do (when (eql char (schar (store buf) pos)) (return-from position-backward (- pos (gap-size buf))))) (when (> bound (gap buf)) (return-from position-backward nil)) (loop for pos from (1- (min position (gap buf))) downto bound do (when (eql char (schar (store buf) pos)) (return-from position-backward pos))) nil) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Goatee/clim-area.lisp0000640000175000017500000006435410705412617020741 0ustar pdmpdm;;; -*- Mode: Lisp; Package: GOATEE -*- ;;; (c) copyright 2002 by Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :goatee) ;;; Need to support replay and redisplay (buffer has changed). Redisplay needs ;;; to have the idea of incremental redisplay (update screen directly) and ;;; start over from scratch. Note that this is different from the ;;; CLIM concept of incremental redisplay, which happens when commands ;;; are executed (usually). ;;; cheat and use this McCLIM internal class :) (defclass screen-area-cursor (clim-internals::cursor-mixin cursor) ((screen-line :accessor screen-line :initarg :screen-line)) (:default-initargs :appearance :solid)) (defmethod* (setf cursor-position) (nx ny (cursor screen-area-cursor)) (declare (ignore nx ny)) (when (and (cursor-state cursor) (stream-drawing-p (cursor-sheet cursor))) (error "screen-area-cursor ~S must not be visible when position is set" cursor)) (call-next-method)) (defmethod climi::cursor-height ((cursor screen-area-cursor)) (let ((line (screen-line cursor))) (+ (ascent line) (descent line)))) (defgeneric line-text-width (area line &key start end) (:documentation "The width text in line's current-contents from START to END, NOT including line wrap.")) (defclass simple-screen-area (editable-area standard-sequence-output-record) ((text-style :accessor text-style :initarg :text-style) (vertical-spacing :accessor vertical-spacing :initarg :vertical-spacing) (cursor :accessor cursor) (area-stream :accessor area-stream :initarg :area-stream) (max-width :accessor max-width :initarg :max-width :initform nil :documentation "Maximum available width for area.") (gutter-width :accessor gutter-width :initarg :gutter-width :initform 12 :documentation "Width of gutter at end of line") (foreground-ink :accessor foreground-ink :initarg :foreground-ink :documentation "Default foreground color (ink) for area") (background-ink :accessor background-ink :initarg :background-ink :documentation "Default background color (ink) for area")) (:documentation "A Goatee editable area implemented as an output record.")) (defmethod initialize-instance :after ((area simple-screen-area) &key area-stream (cursor-visibility :on)) (when (not (slot-boundp area 'text-style)) (if area-stream (setf (text-style area) (medium-text-style area-stream)) (error "One of :text-style or :area-stream must be specified."))) (when (not (slot-boundp area 'vertical-spacing)) (if area-stream (setf (vertical-spacing area) (stream-vertical-spacing area-stream)) (error "One of :vertical-spacing or :stream must be specified."))) (when (not (slot-boundp area 'cursor)) (multiple-value-bind (x y) (output-record-position area) (setf (cursor area) (make-instance 'screen-area-cursor :sheet (area-stream area) :x-position x :y-position y)))) (when (not (slot-boundp area 'max-width)) (setf (max-width area) (if area-stream (- (stream-text-margin area-stream) (output-record-position area)) ; x (* 80 9)))) (when (not (slot-boundp area 'foreground-ink)) (setf (foreground-ink area) (medium-foreground area-stream))) (when (not (slot-boundp area 'background-ink)) (setf (background-ink area) (medium-background area-stream))) (initialize-area-from-buffer area (buffer area)) (setf (cursor-visibility (cursor area)) cursor-visibility) (tree-recompute-extent area)) (defmethod cursor-visibility ((area simple-screen-area)) (cursor-visibility (cursor area))) (defmethod (setf cursor-visibility) (vis (area simple-screen-area)) (setf (cursor-visibility (cursor area)) vis)) (defmethod line-text-width ((area simple-screen-area) ;; XXX need a less implementation-dependent class (line extent-buffer-line) &key (start 0) (end (line-last-point line))) "Compute the width of a buffer line if it were to be displayed." (let ((stream (area-stream area)) (text-style (text-style area))) (loop for i from start below end for char = (char-ref line i) sum (text-size stream char :text-style text-style)))) (defmethod* (setf output-record-position) :around (nx ny (record simple-screen-area)) (multiple-value-bind (x y) (output-record-position record) (multiple-value-prog1 (call-next-method) (let ((cursor (cursor record))) (multiple-value-bind (cx cy) (cursor-position cursor) (setf (cursor-position cursor) (values (+ cx (- nx x)) (+ cy (- ny y))))))))) (defclass screen-line (editable-area-line displayed-output-record climi::basic-output-record) ((current-contents :accessor current-contents :initarg :current-contents :initform (make-array '(1) :adjustable t :fill-pointer 0 :element-type 'character) :documentation "A representation of what is, or soon will be, on the screen. This does not include the buffer line's newline") (ascent :accessor ascent :initarg :ascent) (descent :accessor descent :initarg :descent) (baseline :accessor baseline :initarg :baseline :documentation "The y coordinate of the line's baseline. This is an absolute coordinate, not relative to the output record.") (width :accessor width :initarg :width) (cursor :accessor cursor :initarg :cursor :initform nil) (line-breaks :accessor line-breaks :initform nil))) (defmethod print-object ((obj screen-line) stream) (print-unreadable-object (obj stream :type t :identity t) (with-bounding-rectangle* (x1 y1 x2 y2) obj (format stream "X ~S:~S Y ~S:~S " x1 x2 y1 y2) (write (current-contents obj) :stream stream)))) (defmethod (setf output-record-position) :around (nx ny (record screen-line)) (declare (ignore nx)) (multiple-value-bind (x y) (output-record-position record) (declare (ignore x)) (multiple-value-prog1 (call-next-method) (incf (baseline record) (- ny y))))) (defmethod (setf width) :after (width (line screen-line)) (climi::with-standard-rectangle* (:x1 x1 :y1 y1 :y2 y2) line (setf (rectangle-edges* line) (values x1 y1 (+ x1 width) y2)))) (defmethod (setf ascent) :after (ascent (line screen-line)) (climi::with-standard-rectangle* (:x1 x1 :y1 y1 :x2 x2) line (setf (rectangle-edges* line) (values x1 y1 x2 (+ y1 ascent))))) (defmethod (setf descent) :after (descent (line screen-line)) (climi::with-standard-rectangle* (:x1 x1 :y1 y1 :x2 x2) line (setf (rectangle-edges* line) (values x1 y1 x2 (+ y1 descent))))) (defun line-contents-sans-newline (buffer-line &key destination) (let* ((contents-size (line-last-point buffer-line))) ;; XXX Should check entire string for "non-printable" characters (when (and (> contents-size 0) (eql (char-ref buffer-line (1- contents-size)) #\Newline)) (decf contents-size)) (if (zerop contents-size) (if destination (progn (setf (fill-pointer destination) 0) destination) "") (if destination (progn (adjust-array destination contents-size :fill-pointer contents-size) (flexivector-string-into buffer-line destination :end2 contents-size)) (flexivector-string buffer-line :end contents-size))))) (defmethod line-text-width ((area simple-screen-area) (line screen-line) &key (start 0) (end (length (current-contents line)))) (text-size (area-stream area) (current-contents line) :start start :end end)) (defmethod initialize-instance :after ((obj screen-line) &key (current-contents nil current-contents-p)) (declare (ignore current-contents)) (when (and (not current-contents-p) (slot-boundp obj 'buffer-line)) (line-contents-sans-newline (buffer-line obj) :destination (current-contents obj))) (unless (slot-boundp obj 'width) (setf (width obj) (line-text-width (editable-area obj) obj))) (unless (slot-boundp obj 'baseline) (climi::with-standard-rectangle* (:x1 x1 :y1 y1 :x2 x2) obj (setf (rectangle-edges* obj) (values x1 y1 x2 (+ y1 (ascent obj) (descent obj)))) (setf (baseline obj) (+ y1 (ascent obj)))))) (defmethod bounding-rectangle* ((record screen-line)) (let ((cursor (cursor record))) (multiple-value-bind (x1 y1 x2 y2) (call-next-method) (values x1 y1 (if (and cursor (eq (cursor-visibility cursor) :on)) (with-slots (climi::x climi::width) cursor (max x2 (+ climi::x climi::width))) x2) (if (and cursor (eq (cursor-visibility cursor) :on)) (max y2 (+ y1 (climi::cursor-height cursor))) y2))))) (defmethod climi::map-over-output-records-1 (function (record screen-line) function-args) (declare (ignore function function-args)) nil) (defmethod map-over-output-records-overlapping-region (function (line screen-line) region &optional x-offset y-offset &rest continuation-args) (declare (ignore function region x-offset y-offset continuation-args)) nil) (defmethod map-over-output-records-containing-position (function (line screen-line) x y &optional x-offset y-offset &rest continuation-args) (declare (ignore function x y x-offset y-offset continuation-args)) nil) (defmethod foreground-ink ((line screen-line)) (foreground-ink (output-record-parent line))) (defmethod background-ink ((line screen-line)) (background-ink (output-record-parent line))) (defmethod replay-output-record ((record screen-line) stream &optional region (x-offset 0) (y-offset 0)) (declare (ignore region x-offset y-offset)) (let ((medium (sheet-medium stream)) (cursor (cursor record))) (letf (((medium-text-style medium) (text-style (output-record-parent record))) ((medium-transformation medium) +identity-transformation+) ; Is it necessary? ) (when (and cursor (cursor-state cursor)) (climi::display-cursor cursor :erase)) (multiple-value-bind (x y) (output-record-position record) (declare (ignore y)) (draw-text* stream (current-contents record) x (slot-value record 'baseline) :ink (foreground-ink record))) (when (and cursor (cursor-state cursor)) (climi::flip-screen-cursor cursor))))) (defmethod output-record-refined-position-test ((record screen-line) x y) (declare (ignore x y)) t) (defgeneric max-text-width (area) (:documentation "The width available for text in an area.")) (defmethod max-text-width ((area simple-screen-area)) (- (max-width area) (gutter-width area))) (defmethod output-record-children ((area simple-screen-area)) (loop for line = (area-first-line area) then (next line) while line collect line)) (defmethod add-output-record (child (area simple-screen-area)) (declare (ignore child)) (error "add-output-record shouldn't be called on simple-screen-area")) (defmethod delete-output-record (child (record simple-screen-area) &optional (errorp t)) (declare (ignore child errorp)) (error "delete-output-record shouldn't be called on simple-screen-area")) (defmethod clear-output-record ((record simple-screen-area)) (error "clear-output-record shouldn't be called on simple-screen-area")) (defmethod climi::map-over-output-records-1 (function (record simple-screen-area) function-args) (if function-args (loop for line = (area-first-line record) then (next line) while line do (apply function line function-args)) (loop for line = (area-first-line record) then (next line) while line do (funcall function line)))) ;;; Since lines don't overlap, we can use the same order for ;;; map-over-output-records-containing-position and ;;; map-over-output-records-overlapping-region. (defmethod map-over-output-records-containing-position (function (record simple-screen-area) x y &optional (x-offset 0) (y-offset 0) &rest function-args) (declare (ignore x-offset y-offset)) (flet ((mapper (child) (multiple-value-bind (min-x min-y max-x max-y) (output-record-hit-detection-rectangle* child) (when (and (<= min-x x max-x) (<= min-y y max-y) (output-record-refined-position-test child x y)) (apply function child function-args))))) (declare (dynamic-extent #'mapper)) (map-over-output-records #'mapper record))) (defmethod map-over-output-records-overlapping-region (function (record simple-screen-area) region &optional (x-offset 0) (y-offset 0) &rest function-args) (declare (ignore x-offset y-offset)) (flet ((mapper (child) (when (region-intersects-region-p region child) (apply function child function-args)))) (declare (dynamic-extent #'mapper)) (map-over-output-records #'mapper record))) (defmethod initialize-area-from-buffer ((area simple-screen-area) buffer) (setf (area-bp-start area) (copy-location (buffer-start buffer))) (setf (area-bp-end area) (copy-location (buffer-end buffer))) ;; XXX Stupid, but eventually will be different per line. (with-slots (vertical-spacing) area (multiple-value-bind (parent-x parent-y) (output-record-position area) (let* ((stream (area-stream area)) (ascent (text-style-ascent (text-style area) stream)) (descent (text-style-descent (text-style area) stream)) (last-buffer-line (line (area-bp-end area)))) (loop for buffer-line = (line (area-bp-start area)) then (next buffer-line) for prev-area-line = (lines area) then area-line for y = parent-y then (+ y ascent descent vertical-spacing) for area-line = (make-instance 'screen-line :x-position parent-x :y-position y :parent area :buffer-line buffer-line :last-tick (tick buffer-line) :editable-area area :ascent ascent :descent descent) do (progn (dbl-insert-after area-line prev-area-line) (line-update-cursor area-line (area-stream area))) until (eq buffer-line last-buffer-line) finally (setf (last-line area) area-line))))) area) ;;; Redisplay consists of two parts. First, the buffer is examined for new ;;; lines, deleted lines, or scrolling (eventually). Lines are moved to the ;;; right location. Any new lines are rendered. Then, individual lines are ;;; examined and incrementally updated. ;;; ;;; For these two operations we use a simple strategy. Divide the thing being ;;; updated -- area or individual line -- into unchanged stuff at its ;;; beginning, a changed middle, and unchanged stuff at the end. Then move the ;;; unchanged end into its new position, erase the middle and any of the end ;;; left behind, and draw the new middle. (defgeneric redisplay-all (area) (:documentation "Reinitialize the area's screen state, clear the area and redraw everything.")) (defmethod redisplay-all ((area simple-screen-area)) (dbl-kill-after (lines area)) (setf (line (area-bp-start area)) nil) (setf (line (area-bp-end area)) nil) (letf (((cursor-visibility (cursor area)) :off)) (initialize-area-from-buffer area (buffer area))) (with-bounding-rectangle* (x1 y1 x2 y2) area (let* ((stream (area-stream area)) (medium (sheet-medium stream))) (draw-rectangle* medium x1 y1 x2 y2 :ink (background-ink area) :filled t))) (replay area (area-stream area))) (defgeneric redisplay-area (area)) (defmethod get-area-differences ((area simple-screen-area)) (let ((buf-start (line (area-bp-start area))) (buf-end (line (area-bp-end area)))) (multiple-value-bind (unchanged area-beginning-end buffer-beginning-end) (loop for line = (area-first-line area) then (next line) for prev-line = nil then line for buffer-line = buf-start then (next buffer-line) for prev-buffer-line = nil then buffer-line if (or (null line) (not (eq (buffer-line line) buffer-line))) return (values nil prev-line prev-buffer-line) do (progn nil) ;XXX workaround CMUCL bug ; Is it still necessary? -- APD, 2002-06-25 until (eq buffer-line buf-end) ;; If there are still lines in the area list, then there was a ;; change. finally (return (values (null (next line)) line buffer-line))) (when unchanged (return-from get-area-differences (values t area-beginning-end (area-first-line area) buffer-beginning-end buf-start))) (loop for line = (last-line area) then (prev line) for prev-line = nil then line for buffer-line = buf-end then (prev buffer-line) for prev-buffer-line = nil then buffer-line if (or (eq line (lines area)) (not (eq (buffer-line line) buffer-line))) return (values nil area-beginning-end prev-line buffer-beginning-end prev-buffer-line) do (progn nil) ;XXX workaround CMUCL bug ; Is it still necessary? -- APD, 2002-06-25 until (eq buffer-line buf-start) finally (return (values nil area-beginning-end line buffer-beginning-end buffer-line)))))) (defmethod redisplay-area ((area simple-screen-area)) (let ((stream (area-stream area))) (multiple-value-bind (area-unchanged area-beginning-end area-finish-start buffer-beginning-end buffer-finish-start) (get-area-differences area) (declare (ignore area-beginning-end area-finish-start buffer-beginning-end buffer-finish-start)) ;; XXX big old hack for now. (unless area-unchanged (tree-recompute-extent area) (redisplay-all area) (return-from redisplay-area t))) (loop for line = (area-first-line area) then (next line) while line do (multiple-value-bind (line-changed dimensions-changed) (maybe-update-line-dimensions line) (declare (ignore dimensions-changed)) ;XXX (when line-changed (redisplay-line line stream)))))) (defmethod get-line-differences ((line screen-line)) "Returns: line is different (t or nil) end of current (screen) unchanged beginning start of current unchanged end end of buffer line unchanged beginning start of buffer line unchanged end." (with-slots (current-contents buffer-line) line (let* ((current-length (length current-contents)) (line-length (line-last-point buffer-line)) (min-length (min current-length line-length))) (multiple-value-bind (unchanged common-beginning) (loop for i from 0 below min-length while (char= (char current-contents i) (char-ref buffer-line i)) finally (return (values (and (eql current-length line-length) (eql min-length current-length) (eql i min-length)) i))) (when unchanged (return-from get-line-differences (values t current-length 0 line-length 0))) ;; Determine the common string at the line end (loop for i downfrom (1- current-length) for j downfrom (1- line-length) while (and (>= i 0) (>= j 0) (char= (char current-contents i) (char-ref buffer-line j))) finally (return (values nil common-beginning (1+ i) common-beginning (1+ j)))))))) (defgeneric compute-line-breaks (area line)) (defmethod compute-line-breaks ((area simple-screen-area) line) (let ((max-text-width (max-text-width area))) (when (<= (line-text-width area line) max-text-width) (return-from compute-line-breaks nil)) (loop with line-width = 0 for i from 0 below (length (current-contents line)) for char-width = (line-text-width area line :start i :end (1+ i)) if (> (+ line-width char-width) max-text-width) collect i and do (setq line-width 0) else do (incf line-width char-width) end)) ) ;;; Two steps to redisplaying a line: figure out if the ;;; ascent/descent/baseline have changed, then render the line, incrementally ;;; or not. (defmethod maybe-update-line-dimensions ((line screen-line)) "returns 2 values: contents changed, dimensions changed" (if (eql (last-tick line) (tick (buffer-line line))) (values nil nil) (values t nil))) ;;; Line's coordinates are now correct. ;;; ;;; Strategy: Split the line up into 3 parts: unchanged text at beginning of ;;; line, changed text in middle, unchanged text line at end of line. Any of ;;; these may be empty. To redisplay, move the unchanged text at the end into ;;; position, then erase and display the middle text. (defmethod redisplay-line ((line screen-line) stream) (let* ((medium (sheet-medium stream)) (style (text-style (output-record-parent line)))) (declare (ignorable style)) (with-slots (current-contents ascent descent baseline cursor buffer-line) line (multiple-value-bind (unchanged current-unchanged-from-start current-unchanged-from-end line-unchanged-from-start line-unchanged-from-end) (get-line-differences line) (when (and cursor (cursor-state cursor)) (setf (cursor-visibility cursor) :off)) (unless unchanged (let* ((area (editable-area line)) (start-width (if (> current-unchanged-from-start 0) (line-text-width area line :end current-unchanged-from-start) 0)) (line-end (line-text-width area line)) (current-unchanged-left (if (< current-unchanged-from-end (length current-contents)) (line-text-width area line :end current-unchanged-from-end) line-end)) (new-line-size (line-last-point buffer-line))) ;; Having all we need from the old contents of the line, update ;; with the new contents (when (> new-line-size (car (array-dimensions current-contents))) (adjust-array current-contents new-line-size)) (setf (fill-pointer current-contents) new-line-size) (flexivector-string-into buffer-line current-contents) (let* ((new-line-end (line-text-width area line)) (new-unchanged-left (if (< line-unchanged-from-end (length current-contents)) (line-text-width area line :end line-unchanged-from-end) new-line-end))) (when (stream-drawing-p stream) (multiple-value-bind (x y) (output-record-position line) ;; Move unchanged text at the end of line, if needed (when (and (not (eql line-unchanged-from-end new-line-size)) (not (eql current-unchanged-left new-unchanged-left))) (copy-area medium (+ current-unchanged-left x) y (- line-end current-unchanged-left) (+ ascent descent) (+ new-unchanged-left x) y)) ;; If the line is now shorter, erase the old end of line. (erase-line line medium new-line-end line-end) ;; Erase the changed middle (erase-line line medium start-width new-unchanged-left) ;; Draw the middle (when (< line-unchanged-from-start line-unchanged-from-end) (draw-text* medium current-contents (+ x start-width) baseline :start line-unchanged-from-start :end line-unchanged-from-end :ink (foreground-ink line))))) ;; Old, wrong, bounding rectangle (with-bounding-rectangle* (old-min-x old-min-y old-max-x old-max-y) line (setf (width line) new-line-end) (recompute-extent-for-changed-child (output-record-parent line) line old-min-x old-min-y old-max-x old-max-y))))) ;; Now deal with the cursor (line-update-cursor line stream) (when cursor (setf (cursor-visibility cursor) :on)))))) (defun maybe-scroll (cursor) (let ((pane (cursor-sheet cursor)) (cwidth (slot-value cursor 'climi::width)) (cheight (climi::cursor-height cursor))) (when (and (typep pane 'pane) (pane-viewport-region pane)) (multiple-value-bind (x y) (cursor-position cursor) (unless (region-contains-position-p (pane-viewport-region pane) (+ x cwidth -1) (+ y cheight -1)) (multiple-value-bind (vw vh) (bounding-rectangle-size (pane-viewport-region pane)) (let ((max-width (max (+ x cwidth) (bounding-rectangle-width pane))) (max-height (max (+ y cheight) (bounding-rectangle-height pane)))) (change-space-requirements pane :width max-width :height max-height)) (scroll-extent pane (max 0 (+ x cwidth (- vw))) (max 0 (+ y cheight (- vh)))))))))) (defmethod line-update-cursor ((line screen-line) stream) (multiple-value-bind (point-line point-pos) (point* (buffer (editable-area line))) (with-slots (cursor baseline ascent current-contents) line (let ((x (output-record-position line))) (if (eq point-line (buffer-line line)) (setf cursor (cursor (editable-area line))) (setf cursor nil)) (when cursor (let ((cursor-x (+ x (stream-string-width stream current-contents :end point-pos :text-style (text-style (editable-area line)))))) (letf (((cursor-visibility cursor) :off)) (when (and (slot-boundp cursor 'screen-line) (screen-line cursor) (not (eq line (screen-line cursor)))) (setf (cursor (screen-line cursor)) nil)) (setf (screen-line cursor) line) (setf (cursor-position cursor) (values cursor-x (- baseline ascent))) (maybe-scroll cursor)))))))) (defmethod erase-line ((line screen-line) medium left right) "Erase line from left to right (which are relative to the line origin)" (when (< left right) (multiple-value-bind (x y) (output-record-position line) (with-slots (ascent descent) line (draw-rectangle* medium (+ left x) y (+ x right) (+ y ascent descent) :ink (background-ink line) :filled t))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Goatee/editable-buffer.lisp0000644000175000017500000002632410136747166022136 0ustar pdmpdm;;; -*- Mode: Lisp; Package: GOATEE -*- ;;; (c) copyright 2002 by Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :goatee) ;;; An editable-buffer implements the semantics one would expect of an ;;; Emacs buffer. It maintains a point, where insertions and ;;; deletions take place, and provides functions to move the point around. (defclass editable-buffer (extent-buffer-mixin basic-buffer-mixin) ((point :accessor point :documentation "A buffer-pointer that maintains the current insertion point.") (buffer-start :accessor buffer-start :documentation "A fixed buffer pointer at the start of the buffer.") (buffer-end :accessor buffer-end :documentation "A buffer pointer at the end of the buffer."))) (defmethod initialize-instance :after ((obj editable-buffer) &key initial-contents (start 0) (end (when initial-contents (length initial-contents)))) (setf (point obj) (make-instance 'buffer-pointer :line (dbl-head (lines obj)) :pos 0)) (setf (buffer-start obj) (make-instance 'fixed-buffer-pointer :line (dbl-head (lines obj)) :pos 0)) (setf (buffer-end obj) (make-instance 'buffer-pointer :line (dbl-head (lines obj)) :pos 0)) (when initial-contents (insert obj initial-contents :start start :end end))) ;;; A moment of convenience, a lifetime of regret... (defmethod point* ((buf editable-buffer)) (let ((point (point buf))) (values (line point) (pos point)))) (defgeneric* (setf point*) (line pos buffer)) (defmethod* (setf point*) (line pos (buf editable-buffer)) (let ((point (slot-value buf 'point))) ;; If there's a next line, the point can't be moved past the ;; newline at the end of the line. (when (or (> pos (line-last-point line)) (< pos 0)) (error 'buffer-bounds-error :buffer buf :line line :pos pos)) (when (not (eq (line point) line)) (setf (tick line) (incf (tick buf)))) (setf (location* point) (values line pos)) (setf (tick (line point)) (incf (tick buf))) (values line pos))) (defmacro with-point ((buffer) &body body) "Saves and restores the point of buffer around body." (let ((bp-var (gensym "BP")) (buffer-var (gensym "BUFFER"))) `(let ((,buffer-var ,buffer)) (with-buffer-pointer (,bp-var (point ,buffer-var)) (unwind-protect (progn ,@body) (setf (location* (point ,buffer-var)) (location* ,bp-var))))))) ;;; Insert is the convenience function; thing can contain newline(s). (defmethod insert ((buffer editable-buffer) (c character) &key position line (pos 0)) (cond (position (setf (point* buffer) (location* position))) (line (setf (point* buffer) (values line pos)))) (let* ((pt (slot-value buffer 'point)) (line (line pt)) (pos (pos pt))) ;; point is updated by bp-buffer-mixin methods. (if (eql c (newline-character buffer)) (buffer-open-line* buffer line pos) (buffer-insert* buffer c line pos)))) (defmethod insert ((buffer editable-buffer) (s string) &key position line (pos 0) (start 0) (end (length s))) (cond (position (setf (point* buffer) (location* position))) (line (setf (point* buffer) (values line pos)))) (multiple-value-bind (line pos) (point* buffer) (loop with newline-character = (newline-character buffer) for search-start = start then (1+ found-newline) for found-newline = (position newline-character s :start search-start :end end) while found-newline do (progn (setf (values line pos) (buffer-insert* buffer s line pos :start search-start :end found-newline)) (setf (values line pos) (buffer-open-line* buffer line pos))) finally (return (buffer-insert* buffer s line pos :start search-start :end end))))) (defmethod delete-char ((buf editable-buffer) &optional (n 1) &key position line (pos 0)) (cond (position (setf (point* buf) (location* position))) (line (setf (point* buf) (values line pos)))) (multiple-value-bind (line pos) (point* buf) (if (>= n 0) (loop with remaining = n for last-point = (line-last-point line) while (> (+ remaining pos) last-point) do (let ((del-chars (- last-point pos))) (when (> del-chars 0) (buffer-delete-char* buf line pos (1- del-chars))) ;; Up against the end, this should signal an error (setf (values line pos) (buffer-close-line* buf line 1)) (decf remaining (1+ del-chars))) finally (return (buffer-delete-char* buf line pos remaining))) (loop with remaining = (- n) while (< (- pos remaining) 0) do (progn (buffer-delete-char* buf line pos (- pos)) (decf remaining (1+ pos)) (setf (values line pos) (buffer-close-line* buf line -1))) finally (return (buffer-delete-char* buf line pos (- remaining))))))) (defun adjust-fill (array new-fill) (if (> new-fill (car (array-dimensions array))) (adjust-array array new-fill :fill-pointer new-fill) (setf (fill-pointer array) new-fill)) array) (defgeneric buffer-string (buffer &key start end)) (defmethod buffer-string ((buf basic-buffer) &key start end result) (declare (ignore start end)) (let ((result (if result (adjust-fill result (size buf)) (make-string (size buf))))) (loop for line-in-string = 0 then (+ line-in-string (size line)) for line = (dbl-head (lines buf)) then (next line) while line do (flexivector-string-into line result :start1 line-in-string)) result)) (defmethod forward-char* ((buf editable-buffer) n &key (position (point buf)) line (pos 0)) (multiple-value-bind (line pos) (if line (values line pos) (location* position)) (if (>= n 0) (loop with remaining = n for current-line = line then (next current-line) for current-pos = pos then 0 for last-point = (or (and current-line (line-last-point current-line)) 0) until (or (null current-line) (<= remaining (- last-point current-pos))) do (decf remaining (max 1 (- last-point current-pos))) finally (if (null current-line) (error 'buffer-bounds-error :buffer buf) (return (values current-line (+ current-pos remaining))))) (loop for current-line = line then (and (typep (prev current-line) 'dbl-list) (prev current-line)) for last-point = (or (and current-line (line-last-point current-line)) 0) ;; previous current-pos for remaining = (- n) then (- remaining current-pos 1) for current-pos = pos then last-point until (or (null current-line) (<= remaining current-pos)) finally (if (null current-line) (error 'buffer-bounds-error :buffer buf) (return (values current-line (- current-pos remaining)))))))) (defmethod forward-char ((buf basic-buffer) n &rest key-args) (multiple-value-bind (new-line new-pos) (apply #'forward-char* buf n key-args) (make-instance 'location :line new-line :pos new-pos))) (defgeneric end-of-line* (buffer &key position line pos)) (defgeneric end-of-line (buffer &rest key-args)) (defmethod end-of-line* ((buf editable-buffer) &key (position (point buf)) line (pos 0)) (multiple-value-bind (line pos) (if line (values line pos) (location* position)) (declare (ignore pos)) (values line (line-last-point line)))) (defmethod end-of-line ((buf editable-buffer) &rest key-args) (multiple-value-bind (new-line new-pos) (apply #'end-of-line* buf key-args) (make-instance 'location :line new-line :pos new-pos))) (defgeneric beginning-of-line* (buffer &key position line pos)) (defmethod beginning-of-line* ((buf editable-buffer) &key (position (point buf)) line (pos 0)) (multiple-value-bind (line pos) (if line (values line pos) (location* position)) (declare (ignore pos)) (values line 0))) (defmethod beginning-of-buffer* ((buf editable-buffer)) (location* (buffer-start buf))) (defmethod end-of-buffer* ((buf editable-buffer)) (location* (buffer-end buf))) (defgeneric next-line (buffer &optional n &key position line pos) (:documentation "Return the line N lines from LINE, and a POS in it. If LINE is not given, uses the BUFFER's current line. If N is negative, goes backwards. POS is the position in the line to return as the second value (trimmed if beyond the actual line's maximum).")) (defmethod next-line ((buf editable-buffer) &optional (n 1) &key (position (point buf)) line (pos 0)) (let ((line (or line (location* position))) (forward (> n 0)) (times (abs n))) (loop for i upto times for cur-line = line then (if forward (next line) (prev line)) when (or (not (typep cur-line 'buffer-line)) (null cur-line)) do (error 'buffer-bounds-error :buffer buf :line line) finally (return (values cur-line (min pos (line-last-point cur-line))))))) ;;; These iteration constructs need a bit more thought. ;;; map-over-region in its current state may not do the right thing if ;;; the buffer is modified in the region, but what is the right thing? ;;; Behave as if we're moving a point? (defun map-over-region (func buf start end) (multiple-value-bind (line pos) (location* start) (loop until (and (eq line (line end)) (eql pos (pos end))) do (progn (funcall func line pos) (setf (values line pos) (forward-char* buf 1 :line line :pos pos)))))) ;;; This is cheesy, but I don't feel like optimizing the delete right now. ;; antifuchs->Moore: is this more optimized? What was the extents ;; stuff you hinted at? ;; Had to fix a bug here - would always delete to the end of line, even if ;; start/end was a region within one line. Hopefully didn't screw anything up. ;; --Hefner (defun delete-region (buf start end) (if (eql (line start) (line end)) (buffer-delete-char* buf (line start) (pos start) (- (pos end) (pos start))) (progn (buffer-delete-char* buf (line start) (pos start) (- (line-last-point (line start)) (pos start))) ;; didn't test this piece of code very well... (loop until (eql (line start) (line end)) do (progn (buffer-close-line* buf (line start) 1) (buffer-delete-char* buf (line start) (pos start) (- (line-last-point (line start)) (pos start))))) (buffer-delete-char* buf (line start) (pos start) (pos end))))) (defmethod clear-buffer ((buf editable-buffer)) (delete-region buf (buffer-start buf) (buffer-end buf)) (setf (extents (line (buffer-start buf))) nil)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Goatee/conditions.lisp0000644000175000017500000000164607465310422021257 0ustar pdmpdm;;; -*- Mode: Lisp; Package: GOATEE -*- ;;; (c) copyright 2002 by Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :goatee) (define-condition goatee-error (simple-error) ()) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/gadgets.lisp0000644000175000017500000036204411345155771017330 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2000 by ;;; Arthur Lemmens (lemmens@simplex.nl), ;;; Iban Hatchondo (hatchond@emi.u-bordeaux.fr) ;;; and Julien Boninfante (boninfan@emi.u-bordeaux.fr) ;;; (c) copyright 2001 by ;;; Lionel Salabartan (salabart@emi.u-bordeaux.fr) ;;; (c) copyright 2001 by Michael McDonald (mikemac@mikemac.com) ;;; (c) copyright 2001 by Gilbert Baumann ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) ;;;; Notes ;; There is STANDARD-GADGET in this file but not in the spec, where ;; from? Lispworks? ;; The spec says ORIENTED-GADGET-MIXIN, we call it ORIENTED-GADGET and ;; later define ORIENTED-GADGET-MIXIN with the remark "Try to be ;; compatible with Lispworks' CLIM." ;; ;; This makes me suspect, that either "ORIENTED-GADGET-MIXIN" in the ;; spec is a typo, or all other classes like e.g. ACTION-GADGET should ;; really be named e.g. ACTION-GADGET-MIXIN. Also that would make more ;; sense to me. --GB ;; We have: LABELLED-GADGET, the spec has LABELLED-GADGET-MIXIN. Typo? ;; Compatibility? ;; Why is there GADGET-LABEL-TEXT-STYLE? The spec says, that just the ;; pane's text-style should be borrowed. ;; RANGE-GADGET / RANGE-GADGET-MIXIN: same thing as with ;; ORIENTED-GADGET-MIXIN. ;; Why is there no (SETF GADGET-RANGE*) in the spec? Omission? ;; I would like to make COMPOSE-LABEL-SPACE and DRAW-LABEL* into some ;; sort of label protocol, so that application programmers can ;; programm their own sort of labels alleviateing the need for ;; something like a drawn button gadget. ;; ;; Q: Can we make it so that a mixin class can override another mixin ;; class? ;; ;; All the programmer should need to do is e.g. ;; ;; (defclass pattern-label-mixin () ;; (pattern :initarg :pattern)) ;; ;; (defmethod compose-label-space ((me pattern-label-mixin)) ;; (with-slots (pattern) me ;; (make-space-requirement :width (pattern-width pattern) ;; :height (pattern-height pattern)))) ;; ;; (defmethod draw-label ((me pattern-label-mixin) x1 y1 x2 y2) ;; (with-slots (pattern) me ;; (draw-design me (transform-region (make-translation-transformation x1 y1) ;; pattern)))) ;; ;; (defclass patterned-button (pattern-label-mixin push-button-pane) ;; ()) ;; ;; But then this probably is backwards. Specifing that :LABEL can be ;; another pane probably is much easier and would still allow for the ;; backend to choose the concrete widget class for us. ;; ;; --GB ;; - Should RADIO-BOX-PANE and CHECK-BOX-PANE use rack or box layout? ;; - :CHOICES initarg to RADIO-BOX and CHECK-BOX is from Franz' user ;; guide. ;;;; TODO ;; - the scroll-bar needs more work: ;; . dragging should not change the value, the value should only ;; be changed after releasing the mouse. ;; . it should arm/disarm ;; . it should be deactivatable ;; - the slider needs a total overhaul ;; - TEXT-FILED, TEXT-AREA dito ;; - GADGET-COLOR-MIXIN is currently kind of dangling, we should reuse ;; it for effective-gadget-foreground et al. ;; - The color of a 3Dish border should be derived from a gadget's ;; background. ;; - It seems that 3D-BORDER-MIXIN is only used for the scroll-bar, so ;; remove it ;; - Somehow engrafting the push button's medium does not work. The ;; text-style initarg does not make it to the sheets medium. ;; - make NIL a valid label, and take it into account when applying ;; spacing. ;;;; -------------------------------------------------------------------------- ;;;; ;;;; 30.3 Basic Gadget Classes ;;;; ;;; XXX I'm not sure that *application-frame* should be rebound like this. What ;;; about gadgets in accepting-values windows? An accepting-values window ;;; shouldn't be bound to *application-frame*. -- moore (defun invoke-callback (pane callback &rest more-arguments) (when callback (let ((*application-frame* (pane-frame pane))) (apply callback pane more-arguments)))) ;; ;; gadget sub-classes ;; ;; ;; gadget's colors ;; (defclass gadget-color-mixin () ((normal :type color :initform +gray80+ :initarg :normal :accessor gadget-normal-color) (highlighted :type color :initform +gray85+ :initarg :highlighted :accessor gadget-highlighted-color) (pushed-and-highlighted :type color :initform +gray75+ :initarg :pushed-and-highlighted :accessor gadget-pushed-and-highlighted-color) (current-color :type color :accessor gadget-current-color)) (:documentation "This class define the gadgets colors.")) (defmethod initialize-instance :after ((gadget gadget-color-mixin) &rest args) (declare (ignore args)) (setf (slot-value gadget 'current-color) (gadget-normal-color gadget))) (defmethod (setf gadget-current-color) :after (color (gadget gadget-color-mixin)) (declare (ignore color)) (dispatch-repaint gadget (sheet-region gadget))) #|| ;; Labelled-gadget (defgeneric draw-label (gadget label x y)) (defmethod compose-space ((pane labelled-gadget) &key width height) (declare (ignore width height)) (compose-space-aux pane (gadget-label pane))) (defmethod compose-space-aux ((pane labelled-gadget) (label string)) (with-sheet-medium (medium pane) (let ((as (text-style-ascent (gadget-label-text-style pane) pane)) (ds (text-style-descent (gadget-label-text-style pane) pane))) (multiple-value-bind (width height) (text-size medium (gadget-label pane) :text-style (gadget-label-text-style pane)) (setf height (+ as ds)) ;; FIXME remove explicit values ;; instead use spacer pane in derived classes (let ((tw (* 1.3 width)) (th (* 2.5 height))) (setf th (+ 6 height)) (make-space-requirement :width tw :height th :max-width 400 :max-height 400 :min-width tw :min-height th)))))) (defmethod draw-label ((pane labelled-gadget) (label string) x y) (draw-text* pane label x y :align-x (gadget-label-align-x pane) :align-y (gadget-label-align-y pane) :text-style (gadget-label-text-style pane))) ||# (defclass basic-gadget (permanent-medium-sheet-output-mixin ;; sheet-leaf-mixin ; <- this cannot go here... gadget-color-mixin ;; These are inherited from pane, via ;; clim-sheet-input-mixin and clim-repainting-mixin ;; immediate-sheet-input-mixin ;; immediate-repainting-mixin basic-pane gadget) ()) ;; Where is this standard-gadget from? --GB (defclass standard-gadget (basic-gadget) ()) (defgeneric armed-callback (gadget client gadget-id) (:argument-precedence-order client gadget-id gadget)) (defgeneric disarmed-callback (gadget client gadget-id) (:argument-precedence-order client gadget-id gadget)) ;; "The default methods (on standard-gadget) call the function stored ;; in gadget-armed-callback or gadget-disarmed-callback with one argument, ;; the gadget." (defmethod armed-callback ((gadget basic-gadget) client gadget-id) (declare (ignore client gadget-id)) (invoke-callback gadget (gadget-armed-callback gadget))) (defmethod disarmed-callback ((gadget basic-gadget) client gadget-id) (declare (ignore client gadget-id)) (invoke-callback gadget (gadget-disarmed-callback gadget))) ;; ;; arming and disarming gadgets ;; ;; Redrawing is supposed to be handled on an :AFTER method on arm- and ;; disarm-callback. (defmethod arm-gadget ((gadget basic-gadget) &optional (value t)) (with-slots (armed) gadget (unless (eql armed value) (setf armed value) (if value (armed-callback gadget (gadget-client gadget) (gadget-id gadget)) (disarmed-callback gadget (gadget-client gadget) (gadget-id gadget)))))) (defmethod disarm-gadget ((gadget basic-gadget)) (arm-gadget gadget nil)) ;;; ;;; Activation ;;; (defgeneric activate-gadget (gadget)) (defgeneric deactivate-gadget (gadget)) (defgeneric note-gadget-activated (client gadget)) (defgeneric note-gadget-deactivated (client gadget)) (defmethod activate-gadget ((gadget gadget)) (with-slots (active-p) gadget (unless active-p (setf active-p t) (note-gadget-activated (gadget-client gadget) gadget)))) (defmethod deactivate-gadget ((gadget gadget)) (with-slots (active-p) gadget (when active-p (setf active-p nil) (note-gadget-deactivated (gadget-client gadget) gadget)))) (defmethod note-gadget-activated (client (gadget gadget)) (declare (ignore client)) ;; Default: do nothing ) (defmethod note-gadget-deactivated (client (gadget gadget)) (declare (ignore client)) ;; Default: do nothing ) ;;; ;;; Value-gadget ;;; (defclass value-gadget (standard-gadget) ((value :initarg :value :reader gadget-value) (value-changed-callback :initarg :value-changed-callback :initform nil :reader gadget-value-changed-callback))) (defmethod (setf gadget-value) (value (gadget value-gadget) &key invoke-callback) (setf (slot-value gadget 'value) value) (when invoke-callback (value-changed-callback gadget (gadget-client gadget) (gadget-id gadget) value))) (defgeneric value-changed-callback (gadget client gadget-id value) (:argument-precedence-order client gadget-id value gadget)) (defmethod value-changed-callback ((gadget value-gadget) client gadget-id value) (declare (ignore client gadget-id)) (invoke-callback gadget (gadget-value-changed-callback gadget) value)) ;;; ;;; Action-gadget ;;; (defclass action-gadget (standard-gadget) ((activate-callback :initarg :activate-callback :initform nil :reader gadget-activate-callback))) (defgeneric activate-callback (action-gadget client gadget-id) (:argument-precedence-order client gadget-id action-gadget)) (defmethod activate-callback ((gadget action-gadget) client gadget-id) (declare (ignore client gadget-id)) (invoke-callback gadget (gadget-activate-callback gadget))) ;;; ;;; Oriented-gadget ;;; (defclass oriented-gadget () ((orientation :type (member :vertical :horizontal) :initarg :orientation :reader gadget-orientation))) (defclass oriented-gadget-mixin (oriented-gadget) ;; Try to be compatible with Lispworks' CLIM. ()) ;;;; ;;;; labelled-gadget ;;;; (defclass labelled-gadget () ((label :initarg :label :initform "" :accessor gadget-label) #+nil (align-x :initarg :align-x :accessor gadget-label-align-x) #+nil (align-y :initarg :align-y :accessor gadget-label-align-y) #+nil (text-style :initform *default-text-style* :initarg :text-style :accessor gadget-text-style))) (defclass labelled-gadget-mixin (labelled-gadget) ;; Try to be compatible with Lispworks' CLIM. ()) ;;;; ;;;; Range-gadget ;;;; (defclass range-gadget () ((min-value :initarg :min-value :accessor gadget-min-value) (max-value :initarg :max-value :accessor gadget-max-value))) (defclass range-gadget-mixin (range-gadget) ;; Try to be compatible with Lispworks' CLIM. ()) (defgeneric gadget-range (range-gadget) (:documentation "Returns the difference of the maximum and minimum value of RANGE-GADGET.")) (defmethod gadget-range ((gadget range-gadget)) (- (gadget-max-value gadget) (gadget-min-value gadget))) (defgeneric gadget-range* (range-gadget) (:documentation "Returns the minimum and maximum value of RANGE-GADGET as two values.")) (defmethod gadget-range* ((gadget range-gadget)) (values (gadget-min-value gadget) (gadget-max-value gadget))) ;;;; ------------------------------------------------------------------------------------------ ;;;; ;;;; 30.4 Abstract Gadget Classes ;;;; ;;; 30.4.1 The abstract push-button Gadget (defclass push-button (labelled-gadget-mixin action-gadget) ()) ;;; 30.4.2 The abstract toggle-button Gadget (defclass toggle-button (labelled-gadget-mixin value-gadget) () (:documentation "The value is either t either nil")) ;;; 30.4.3 The abstract menu-button Gadget (defclass menu-button (labelled-gadget-mixin value-gadget) () (:documentation "The value is a button")) ;;; 30.4.4 The abstract scroll-bar Gadget (defgeneric drag-callback (pane client gadget-id value) (:argument-precedence-order client gadget-id value pane)) (defgeneric scroll-to-top-callback (scroll-bar client gadget-id) (:argument-precedence-order client gadget-id scroll-bar)) (defgeneric scroll-to-bottom-callback (scroll-bar client gadget-id) (:argument-precedence-order client gadget-id scroll-bar)) (defgeneric scroll-up-line-callback (scroll-bar client gadget-id) (:argument-precedence-order client gadget-id scroll-bar)) (defgeneric scroll-up-page-callback (scroll-bar client gadget-id) (:argument-precedence-order client gadget-id scroll-bar)) (defgeneric scroll-down-line-callback (scroll-bar client gadget-id) (:argument-precedence-order client gadget-id scroll-bar)) (defgeneric scroll-down-page-callback (scroll-bar client gadget-id) (:argument-precedence-order client gadget-id scroll-bar)) (defclass scroll-bar (value-gadget oriented-gadget-mixin range-gadget-mixin) ((drag-callback :initarg :drag-callback :initform nil :reader scroll-bar-drag-callback) (scroll-to-bottom-callback :initarg :scroll-to-bottom-callback :initform nil :reader scroll-bar-scroll-to-bottom-callback) (scroll-to-top-callback :initarg :scroll-to-top-callback :initform nil :reader scroll-bar-scroll-to-top-callback) (scroll-down-line-callback :initarg :scroll-down-line-callback :initform nil :reader scroll-bar-scroll-down-line-callback) (scroll-up-line-callback :initarg :scroll-up-line-callback :initform nil :reader scroll-bar-scroll-up-line-callback) (scroll-down-page-callback :initarg :scroll-down-page-callback :initform nil :reader scroll-bar-scroll-down-page-callback) (scroll-up-page-callback :initarg :scroll-up-page-callback :initform nil :reader scroll-bar-scroll-up-page-callback) (thumb-size :initarg :thumb-size :initform 1/4 :accessor scroll-bar-thumb-size :documentation "The size of the scroll bar thumb (slug) in the units of the gadget value. When the scroll bar is drawn the empty region of the scroll bar and the thumb are drawn in proportion to the values of the gadget range and thumb size.")) (:default-initargs :value 0 :min-value 0 :max-value 1 :orientation :vertical)) (defmethod drag-callback ((pane scroll-bar) client gadget-id value) (declare (ignore client gadget-id)) (invoke-callback pane (scroll-bar-drag-callback pane) value)) (defmethod scroll-to-top-callback ((pane scroll-bar) client gadget-id) (declare (ignore client gadget-id)) (invoke-callback pane (scroll-bar-scroll-to-top-callback pane))) (defmethod scroll-to-bottom-callback ((pane scroll-bar) client gadget-id) (declare (ignore client gadget-id)) (invoke-callback pane (scroll-bar-scroll-to-bottom-callback pane))) (defmethod scroll-up-line-callback ((pane scroll-bar) client gadget-id) (declare (ignore client gadget-id)) (invoke-callback pane (scroll-bar-scroll-up-line-callback pane))) (defmethod scroll-up-page-callback ((pane scroll-bar) client gadget-id) (declare (ignore client gadget-id)) (invoke-callback pane (scroll-bar-scroll-up-page-callback pane))) (defmethod scroll-down-line-callback ((pane scroll-bar) client gadget-id) (declare (ignore client gadget-id)) (invoke-callback pane (scroll-bar-scroll-down-line-callback pane))) (defmethod scroll-down-page-callback ((pane scroll-bar) client gadget-id) (declare (ignore client gadget-id)) (invoke-callback pane (scroll-bar-scroll-down-page-callback pane))) ;;; 30.4.5 The abstract slider Gadget (defclass slider-gadget (labelled-gadget-mixin value-gadget oriented-gadget-mixin range-gadget-mixin gadget-color-mixin ;; value-changed-repaint-mixin ) () (:documentation "The value is a real number, and default value for orientation is :vertical, and must never be nil.")) ;;; 30.4.6 The abstract radio-box and check-box Gadgets ;; The only real different between a RADIO-BOX and a CHECK-BOX is the ;; number of allowed selections. (defclass radio-box (value-gadget oriented-gadget-mixin) () (:documentation "The value is a button") (:default-initargs :value nil)) ;; RADIO-BOX-CURRENT-SELECTION is just a synonym for GADGET-VALUE: (defmethod radio-box-current-selection ((radio-box radio-box)) (gadget-value radio-box)) (defmethod (setf radio-box-current-selection) (new-value (radio-box radio-box)) (setf (gadget-value radio-box) new-value)) (defmethod radio-box-selections ((pane radio-box)) (let ((v (radio-box-current-selection pane))) (and v (list v)))) (defmethod value-changed-callback :before (value-gadget (client radio-box) gadget-id value) (declare (ignorable value-gadget gadget-id value)) ;; Note that we ignore 'value', this is because if value is non-NIL, ;; then the toggle button was turned off, which would make no ;; toggle-button turned on => constraint "always exactly one ;; selected" missed. So simply turning this toggle button on again ;; fixes it. (unless (or (and (not value) (not (eq (gadget-value client) value-gadget))) (and value (eq (gadget-value client) value-gadget))) (setf (gadget-value client :invoke-callback t) value-gadget))) ;;;; CHECK-BOX (defclass check-box (value-gadget oriented-gadget-mixin) () (:documentation "The value is a list of buttons") (:default-initargs :value nil :orientation :vertical)) ;; CHECK-BOX-CURRENT-SELECTION is just a synonym for GADGET-VALUE: (defmethod check-box-current-selection ((check-box check-box)) (gadget-value check-box)) (defmethod (setf check-box-current-selection) (new-value (check-box check-box)) (setf (gadget-value check-box) new-value)) (defmethod value-changed-callback :before (value-gadget (client check-box) gadget-id value) (declare (ignorable gadget-id)) (if value (setf (gadget-value client :invoke-callback t) (adjoin value-gadget (gadget-value client))) (setf (gadget-value client :invoke-callback t) (remove value-gadget (gadget-value client))))) (defmethod (setf gadget-value) :after (buttons (check-box check-box) &key invoke-callback) ;; this is silly, but works ... (dolist (c (sheet-children check-box)) (unless (eq (not (null (member c buttons))) (not (null (gadget-value c)))) (setf (gadget-value c :invoke-callback invoke-callback) (member c buttons)) ))) (defmacro with-radio-box ((&rest options &key (type :one-of) (orientation :vertical) &allow-other-keys) &body body) (let ((contents (gensym "CONTENTS-")) (selected-p (gensym "SELECTED-P-")) (initial-selection (gensym "INITIAL-SELECTION-"))) `(let ((,contents nil) (,selected-p nil) (,initial-selection nil)) (declare (special ,selected-p)) (flet ((make-pane (type &rest options) (cond ((eq type 'toggle-button) (let ((pane (apply #'make-pane type :value ,selected-p :indicator-type ',type options))) (push pane ,contents) (when ,selected-p (push pane ,initial-selection)))) (t (error "oops"))))) (macrolet ((radio-box-current-selection (subform) `(let ((,',selected-p t)) (declare (special ,',selected-p)) ,(cond ((stringp subform) `(make-pane 'toggle-button :label ,subform)) (t subform))))) ,@(mapcar (lambda (form) (cond ((stringp form) `(make-pane 'toggle-button :label ,form)) (t form))) body))) (make-pane ',(if (eq type :one-of) 'radio-box 'check-box) :orientation ',orientation :current-selection ,(if (eq type :one-of) `(or (first ,initial-selection) (first ,contents)) `,initial-selection) :choices (reverse ,contents) ,@options)))) ;;; 30.4.7 The abstract list-pane and option-pane Gadgets (defclass list-pane (value-gadget) () (:documentation "The instantiable class that implements an abstract list pane, that is, a gadget whose semantics are similar to a radio box or check box, but whose visual appearance is a list of buttons.") (:default-initargs :value nil)) (defclass option-pane (value-gadget) () (:documentation "The instantiable class that implements an abstract option pane, that is, a gadget whose semantics are identical to a list pane, but whose visual appearance is a single push button which, when pressed, pops up a menu of selections.")) ;;; 30.4.8 The abstract text-field Gadget (defclass text-field (value-gadget action-gadget) ((editable-p :accessor editable-p :initarg editable-p :initform t)) (:documentation "The value is a string") (:default-initargs :value "")) (defmethod initialize-instance :after ((gadget text-field) &rest rest) (unless (getf rest :normal) (setf (slot-value gadget 'current-color) +white+ (slot-value gadget 'normal) +white+))) ;;; 30.4.9 The abstract text-editor Gadget (defclass text-editor (text-field) () (:documentation "The value is a string")) ;;;; ------------------------------------------------------------------------------------------ ;;;; ;;;; Mixin Classes for Concrete Gadgets ;;;; (defclass standard-gadget-pane (;;permanent-medium-sheet-output-mixin ;;immediate-sheet-input-mixin ;;immediate-repainting-mixin sheet-leaf-mixin standard-gadget) () (:documentation "PANE class to include in gadget pane classes.")) ;;;; Redrawing mixins (defclass arm/disarm-repaint-mixin () () (:documentation "Mixin class for gadgets, whose appearence depends on its armed state.")) (defmethod armed-callback :after ((gadget arm/disarm-repaint-mixin) client id) (declare (ignore client id)) (dispatch-repaint gadget (or (pane-viewport-region gadget) (sheet-region gadget)))) (defmethod disarmed-callback :after ((gadget arm/disarm-repaint-mixin) client id) (declare (ignore client id)) (dispatch-repaint gadget (or (pane-viewport-region gadget) (sheet-region gadget)))) (defclass value-changed-repaint-mixin () () (:documentation "Mixin class for gadgets, whose appearence depends on its value.")) (defmethod (setf gadget-value) :after (new-value (gadget value-changed-repaint-mixin) &key &allow-other-keys) (declare (ignore new-value)) (dispatch-repaint gadget (or (pane-viewport-region gadget) (sheet-region gadget)))) ;;;; Event handling mixins (defclass enter/exit-arms/disarms-mixin () () (:documentation "Mixin class for gadgets which are armed when the mouse enters and disarmed when the mouse leaves.")) (defmethod handle-event :before ((pane enter/exit-arms/disarms-mixin) (event pointer-enter-event)) (declare (ignorable event)) (arm-gadget pane)) (defmethod handle-event :after ((pane enter/exit-arms/disarms-mixin) (event pointer-exit-event)) (declare (ignorable event)) (disarm-gadget pane)) ;;;; changing-label-invokes-layout-protocol-mixin (defclass changing-label-invokes-layout-protocol-mixin () () (:documentation "Mixin class for gadgets, which want invoke the layout protocol, if the label changes.")) ;;;; Common behavior on STANDARD-GADGET-PANE and BASIC-GADGET ;; ;; When a gadget is not activated, it receives no device events. ;; (defmethod handle-event :around ((pane standard-gadget) (event device-event)) (when (gadget-active-p pane) (call-next-method))) ;; When a gadget is deactivated, it cannot be armed. ;; Glitch: upon re-activation the mouse might happen to be in the ;; gadget and thus re-arm it immediately, that is not implemented. (defmethod note-gadget-deactivated :after (client (gadget standard-gadget)) (declare (ignorable client)) (disarm-gadget gadget)) ;;;; ------------------------------------------------------------------------------------------ ;;;; ;;;; Drawing Utilities for Concrete Gadgets ;;;; ;;; Labels (defmethod compose-label-space ((gadget labelled-gadget-mixin) &key (wider 0) (higher 0)) (with-slots (label align-x align-y) gadget (let* ((as (text-style-ascent (pane-text-style gadget) gadget)) (ds (text-style-descent (pane-text-style gadget) gadget)) (w (+ (text-size gadget label :text-style (pane-text-style gadget)) wider)) (h (+ as ds higher))) (make-space-requirement :width w :min-width w :max-width w :height h :min-height h :max-height h)))) (defmethod draw-label* ((pane labelled-gadget-mixin) x1 y1 x2 y2 &key (ink +foreground-ink+)) (with-slots (align-x align-y label) pane (let ((as (text-style-ascent (pane-text-style pane) pane)) (ds (text-style-descent (pane-text-style pane) pane)) (w (text-size pane label :text-style (pane-text-style pane)))) (draw-text* pane label (case align-x ((:left) x1) ((:right) (- x2 w)) ((:center) (/ (+ x1 x2 (- w)) 2)) (otherwise x1)) ;defensive programming (case align-y ((:top) (+ y1 as)) ((:center) (/ (+ y1 y2 (- as ds)) 2)) ((:bottom) (- y2 ds)) (otherwise (/ (+ y1 y2 (- as ds)) 2))) ;defensive programming ;; Giving the text-style here shouldn't be neccessary --GB :text-style (pane-text-style pane) :ink ink)))) ;;; 3D-ish Look ;; DRAW-BORDERED-POLYGON medium point-seq &key border-width style ;; ;; -GB (labels ((line-hnf (x1 y1 x2 y2) (values (- y2 y1) (- x1 x2) (- (* x1 y2) (* y1 x2)))) (line-line-intersection (x1 y1 x2 y2 x3 y3 x4 y4) (multiple-value-bind (a1 b1 c1) (line-hnf x1 y1 x2 y2) (multiple-value-bind (a2 b2 c2) (line-hnf x3 y3 x4 y4) (let ((d (- (* a1 b2) (* b1 a2)))) (cond ((< (abs d) 1e-6) nil) (t (values (/ (- (* b2 c1) (* b1 c2)) d) (/ (- (* a1 c2) (* a2 c1)) d)))))))) (polygon-orientation (point-seq) "Determines the polygon's orientation. Returns: +1 = counter-clock-wise -1 = clock-wise The polygon should be clean from duplicate points or co-linear points. If the polygon self intersects, the orientation may not be defined, this function does not try to detect this situation and happily returns some value." ;; (let ((n (length point-seq))) (let* ((min-i 0) (min-val (point-x (elt point-seq min-i)))) ;; (loop for i from 1 below n do (when (< (point-x (elt point-seq i)) min-val) (setf min-val (point-x (elt point-seq i)) min-i i))) ;; (let ((p0 (elt point-seq (mod (+ min-i -1) n))) (p1 (elt point-seq (mod (+ min-i 0) n))) (p2 (elt point-seq (mod (+ min-i +1) n)))) (signum (- (* (- (point-x p2) (point-x p0)) (- (point-y p1) (point-y p0))) (* (- (point-x p1) (point-x p0)) (- (point-y p2) (point-y p0))))))))) (clean-polygon (point-seq) "Cleans a polygon from duplicate points and co-linear points. Furthermore tries to bring it into counter-clock-wise orientation." ;; first step: remove duplicates (setf point-seq (let ((n (length point-seq))) (loop for i from 0 below n for p0 = (elt point-seq (mod (+ i -1) n)) for p1 = (elt point-seq (mod (+ i 0) n)) unless (and (< (abs (- (point-x p0) (point-x p1))) 10e-8) (< (abs (- (point-y p0) (point-y p1))) 10e-8)) collect p1))) ;; second step: remove colinear points (setf point-seq (let ((n (length point-seq))) (loop for i from 0 below n for p0 = (elt point-seq (mod (+ i -1) n)) for p1 = (elt point-seq (mod (+ i 0) n)) for p2 = (elt point-seq (mod (+ i +1) n)) unless (< (abs (- (* (- (point-x p1) (point-x p0)) (- (point-y p2) (point-y p0))) (* (- (point-x p2) (point-x p0)) (- (point-y p1) (point-y p0))))) 10e-8) collect p1))) ;; third step: care for the orientation (if (and (not (null point-seq)) (minusp (polygon-orientation point-seq))) (reverse point-seq) point-seq) )) (defun shrink-polygon (point-seq width) (let ((point-seq (clean-polygon point-seq))) (let ((n (length point-seq))) (values point-seq (loop for i from 0 below n for p0 = (elt point-seq (mod (+ i -1) n)) for p1 = (elt point-seq (mod (+ i 0) n)) for p2 = (elt point-seq (mod (+ i +1) n)) collect (let* ((dx1 (- (point-x p1) (point-x p0))) (dy1 (- (point-y p1) (point-y p0))) (dx2 (- (point-x p2) (point-x p1))) (dy2 (- (point-y p2) (point-y p1))) ;; (m1 (/ width (sqrt (+ (* dx1 dx1) (* dy1 dy1))))) (m2 (/ width (sqrt (+ (* dx2 dx2) (* dy2 dy2))))) ;; (q0 (make-point (+ (point-x p0) (* m1 dy1)) (- (point-y p0) (* m1 dx1)))) (q1 (make-point (+ (point-x p1) (* m1 dy1)) (- (point-y p1) (* m1 dx1)))) (q2 (make-point (+ (point-x p1) (* m2 dy2)) (- (point-y p1) (* m2 dx2)))) (q3 (make-point (+ (point-x p2) (* m2 dy2)) (- (point-y p2) (* m2 dx2)))) ) ;; (multiple-value-bind (x y) (multiple-value-call #'line-line-intersection (point-position q0) (point-position q1) (point-position q2) (point-position q3)) (if x (make-point x y) (make-point 0 0))))))))) (defun draw-bordered-polygon (medium point-seq &key (border-width 2) (style :inset)) (labels ((draw-pieces (outer-points inner-points dark light) (let ((n (length outer-points))) (dotimes (i n) (let* ((p1 (elt outer-points (mod (+ i 0) n))) (p2 (elt outer-points (mod (+ i +1) n))) (q1 (elt inner-points (mod (+ i 0) n))) (q2 (elt inner-points (mod (+ i +1) n))) (p1* (transform-region +identity-transformation+ p1)) (p2* (transform-region +identity-transformation+ p2)) (a (mod (atan (- (point-y p2*) (point-y p1*)) (- (point-x p2*) (point-x p1*))) (* 2 pi)))) (draw-polygon medium (list p1 q1 q2 p2) :ink (if (<= (* 1/4 pi) a (* 5/4 pi)) dark light))))))) (let ((light *3d-light-color*) (dark *3d-dark-color*)) ;; (ecase style (:solid (multiple-value-call #'draw-pieces (shrink-polygon point-seq border-width) +black+ +black+)) (:inset (multiple-value-call #'draw-pieces (shrink-polygon point-seq border-width) dark light)) (:outset (multiple-value-call #'draw-pieces (shrink-polygon point-seq border-width) light dark)) ;; ;; Mickey Mouse is the trademark of the Walt Disney Company. ;; (:mickey-mouse-outset (multiple-value-bind (outer-points inner-points) (shrink-polygon point-seq border-width) (declare (ignore outer-points)) (multiple-value-bind (outer-points middle-points) (shrink-polygon point-seq (/ border-width 2)) (draw-pieces outer-points middle-points +white+ +black+) (draw-pieces middle-points inner-points light dark)))) (:mickey-mouse-inset (multiple-value-bind (outer-points inner-points) (shrink-polygon point-seq border-width) (declare (ignore outer-points)) (multiple-value-bind (outer-points middle-points) (shrink-polygon point-seq (/ border-width 2)) (draw-pieces outer-points middle-points dark light) (draw-pieces middle-points inner-points +black+ +white+)))) ;; (:ridge (multiple-value-bind (outer-points inner-points) (shrink-polygon point-seq border-width) (declare (ignore outer-points)) (multiple-value-bind (outer-points middle-points) (shrink-polygon point-seq (/ border-width 2)) (draw-pieces outer-points middle-points light dark) (draw-pieces middle-points inner-points dark light)))) (:groove (multiple-value-bind (outer-points inner-points) (shrink-polygon point-seq border-width) (declare (ignore outer-points)) (multiple-value-bind (outer-points middle-points) (shrink-polygon point-seq (/ border-width 2)) (draw-pieces outer-points middle-points dark light) (draw-pieces middle-points inner-points light dark)))) (:double (multiple-value-bind (outer-points inner-points) (shrink-polygon point-seq border-width) (declare (ignore outer-points)) (multiple-value-bind (outer-points imiddle-points) (shrink-polygon point-seq (* 2/3 border-width)) (declare (ignore outer-points)) (multiple-value-bind (outer-points omiddle-points) (shrink-polygon point-seq (* 1/3 border-width)) (draw-pieces outer-points omiddle-points +black+ +black+) (draw-pieces imiddle-points inner-points +black+ +black+))))))))) ) (defun draw-bordered-rectangle* (medium x1 y1 x2 y2 &rest options) (apply #'draw-bordered-polygon medium (polygon-points (make-rectangle* x1 y1 x2 y2)) options)) (defun draw-engraved-label* (pane x1 y1 x2 y2) (draw-label* pane (1+ x1) (1+ y1) (1+ x2) (1+ y2) :ink *3d-light-color*) (draw-label* pane x1 y1 x2 y2 :ink *3d-dark-color*)) ;;;; ;;;; 3D-BORDER-MIXIN Class ;;;; ;; 3D-BORDER-MIXIN class can be used to add a 3D-ish border to ;; panes. There are three new options: ;; ;; :border-width The width of the border ;; :border-style The border's style one of :inset, :outset, :groove, :ridge, :solid, ;; :double, :dotted, :dashed ;; [:dotted and :dashed are not yet implemented] ;; ;; :border-color The border's color ;; [Not implemented yet] ;; ;; [These options are modelled after CSS]. ;; ;; When using 3D-BORDER-MIXIN, one should query the pane's inner ;; region, where drawing should take place, by PANE-INNER-REGION. ;; ;; --GB (defclass 3D-border-mixin () ((border-width :initarg :border-width :initform 2) (border-style :initarg :border-style :initform :outset) (border-color :initarg :border-color :initform "???"))) (defmethod pane-inner-region ((pane 3D-border-mixin)) (with-slots (border-width) pane (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region pane) (make-rectangle* (+ x1 border-width) (+ y1 border-width) (- x2 border-width) (- y2 border-width))))) (defmethod handle-repaint :after ((pane 3D-border-mixin) region) (declare (ignore region)) (with-slots (border-width border-style) pane (draw-bordered-polygon pane (polygon-points (bounding-rectangle (sheet-region pane))) :border-width border-width :style border-style))) ;;;; ------------------------------------------------------------------------------------------ ;;;; ;;;; 30.4a Concrete Gadget Classes ;;;; ;; xxx move these! (defparameter *3d-border-thickness* 2) ;;; Common colors: (defmethod gadget-highlight-background ((gadget basic-gadget)) (compose-over (compose-in #|+paleturquoise+|# +white+ (make-opacity .5)) (pane-background gadget))) (defmethod effective-gadget-foreground ((gadget basic-gadget)) (if (gadget-active-p gadget) +foreground-ink+ (compose-over (compose-in (pane-foreground gadget) (make-opacity .5)) (pane-background gadget)))) (defmethod effective-gadget-background ((gadget basic-gadget)) (if (slot-value gadget 'armed) (gadget-highlight-background gadget) (pane-background gadget))) (defmethod effective-gadget-input-area-color ((gadget basic-gadget)) (if (gadget-active-p gadget) +lemonchiffon+ (compose-over (compose-in +lemonchiffon+ (make-opacity .5)) (pane-background gadget)))) ;;; ------------------------------------------------------------------------------------------ ;;; 30.4.1 The concrete push-button Gadget (defclass push-button-pane (push-button labelled-gadget-mixin changing-label-invokes-layout-protocol-mixin arm/disarm-repaint-mixin enter/exit-arms/disarms-mixin standard-gadget-pane) ((pressedp :initform nil) (show-as-default-p :type boolean :initform nil :initarg :show-as-default-p :accessor push-button-show-as-default-p)) (:default-initargs :text-style (make-text-style :sans-serif nil nil) :background *3d-normal-color* :align-x :center :align-y :center :x-spacing 4 :y-spacing 2)) (defmethod compose-space ((gadget push-button-pane) &key width height) (declare (ignore width height)) (space-requirement+* (space-requirement+* (compose-label-space gadget) :min-width (* 2 (pane-x-spacing gadget)) :width (* 2 (pane-x-spacing gadget)) :max-width (* 2 (pane-x-spacing gadget)) :min-height (* 2 (pane-y-spacing gadget)) :height (* 2 (pane-y-spacing gadget)) :max-height (* 2 (pane-y-spacing gadget))) :min-width (* 2 *3d-border-thickness*) :width (* 2 *3d-border-thickness*) :max-width (* 2 *3d-border-thickness*) :min-height (* 2 *3d-border-thickness*) :height (* 2 *3d-border-thickness*) :max-height (* 2 *3d-border-thickness*))) (defmethod handle-event ((pane push-button-pane) (event pointer-button-press-event)) (with-slots (pressedp) pane (setf pressedp t) (dispatch-repaint pane +everywhere+))) (defmethod handle-event ((pane push-button-pane) (event pointer-button-release-event)) (with-slots (armed pressedp) pane (setf pressedp nil) (when armed (activate-callback pane (gadget-client pane) (gadget-id pane)) (setf pressedp nil) (dispatch-repaint pane +everywhere+)))) (defmethod handle-repaint ((pane push-button-pane) region) (declare (ignore region)) (with-slots (armed pressedp) pane (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* (sheet-region pane)) (draw-rectangle* pane x1 y1 x2 y2 :ink (effective-gadget-background pane)) (draw-bordered-rectangle* pane x1 y1 x2 y2 :style (if (and pressedp armed) :inset :outset)) (multiple-value-bind (x1 y1 x2 y2) (values (+ x1 *3d-border-thickness* (pane-x-spacing pane)) (+ y1 *3d-border-thickness* (pane-y-spacing pane)) (- x2 *3d-border-thickness* (pane-x-spacing pane)) (- y2 *3d-border-thickness* (pane-y-spacing pane))) (if (gadget-active-p pane) (draw-label* pane x1 y1 x2 y2 :ink (effective-gadget-foreground pane)) (draw-engraved-label* pane x1 y1 x2 y2)))))) (defmethod deactivate-gadget :after ((gadget push-button-pane)) (dispatch-repaint gadget +everywhere+)) (defmethod activate-gadget :after ((gadget push-button-pane)) (dispatch-repaint gadget +everywhere+)) ;;; ------------------------------------------------------------------------------------------ ;;; 30.4.2 The concrete toggle-button Gadget (defclass toggle-button-pane (toggle-button ;; repaint behavior: arm/disarm-repaint-mixin value-changed-repaint-mixin ;; callback behavior: changing-label-invokes-layout-protocol-mixin ;; event handling: enter/exit-arms/disarms-mixin ;; other standard-gadget-pane) ((indicator-type :type (member :one-of :some-of) :initarg :indicator-type :reader toggle-button-indicator-type :initform :some-of) ) (:default-initargs :value nil :text-style (make-text-style :sans-serif nil nil) :align-x :left :align-y :center :x-spacing 2 :y-spacing 2 :background *3d-normal-color*)) (defmethod compose-space ((pane toggle-button-pane) &key width height) (declare (ignore width height)) (let ((sr (compose-label-space pane))) (space-requirement+* (space-requirement+* sr :min-width (* 3 (pane-x-spacing pane)) :width (* 3 (pane-x-spacing pane)) :max-width (* 3 (pane-x-spacing pane)) :min-height (* 2 (pane-y-spacing pane)) :height (* 2 (pane-y-spacing pane)) :max-height (* 2 (pane-y-spacing pane))) :min-width (space-requirement-height sr) :width (space-requirement-height sr) :max-width (space-requirement-height sr) :min-height 0 :max-height 0 :height 0))) (defmethod draw-toggle-button-indicator ((gadget standard-gadget-pane) (type (eql :one-of)) value x1 y1 x2 y2) (multiple-value-bind (cx cy) (values (/ (+ x1 x2) 2) (/ (+ y1 y2) 2)) (let ((radius (/ (- y2 y1) 2))) (draw-circle* gadget cx cy radius :start-angle (* 1/4 pi) :end-angle (* 5/4 pi) :ink *3d-dark-color*) (draw-circle* gadget cx cy radius :start-angle (* 5/4 pi) :end-angle (* 9/4 pi) :ink *3d-light-color*) (draw-circle* gadget cx cy (max 1 (- radius 2)) :ink (effective-gadget-input-area-color gadget)) (when value (draw-circle* gadget cx cy (max 1 (- radius 4)) :ink (effective-gadget-foreground gadget)))))) (defmethod draw-toggle-button-indicator ((pane standard-gadget-pane) (type (eql :some-of)) value x1 y1 x2 y2) (draw-rectangle* pane x1 y1 x2 y2 :ink (effective-gadget-input-area-color pane)) (draw-bordered-rectangle* pane x1 y1 x2 y2 :style :inset) (when value (multiple-value-bind (x1 y1 x2 y2) (values (+ x1 3) (+ y1 3) (- x2 3) (- y2 3)) (draw-line* pane x1 y1 x2 y2 :ink (effective-gadget-foreground pane) :line-thickness 2) (draw-line* pane x2 y1 x1 y2 :ink (effective-gadget-foreground pane) :line-thickness 2)))) (defmethod handle-repaint ((pane toggle-button-pane) region) (declare (ignore region)) (when (sheet-grafted-p pane) (with-special-choices (pane) (with-slots (armed) pane (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* (sheet-region pane)) (draw-rectangle* pane x1 y1 x2 y2 :ink (effective-gadget-background pane)) (let* ((as (text-style-ascent (pane-text-style pane) pane)) (ds (text-style-descent (pane-text-style pane) pane)) ) (multiple-value-bind (tx1 ty1 tx2 ty2) (values (+ x1 (pane-x-spacing pane)) (- (/ (+ y1 y2) 2) (/ (+ as ds) 2)) (+ x1 (pane-x-spacing pane) (+ as ds)) (+ (/ (+ y1 y2) 2) (/ (+ as ds) 2))) (draw-toggle-button-indicator pane (toggle-button-indicator-type pane) (gadget-value pane) tx1 ty1 tx2 ty2) (draw-label* pane (+ tx2 (pane-x-spacing pane)) y1 x2 y2 :ink (effective-gadget-foreground pane))))))))) (defmethod handle-event ((pane toggle-button-pane) (event pointer-button-release-event)) (with-slots (armed) pane (when armed (setf (gadget-value pane :invoke-callback t) (not (gadget-value pane)))))) ;;; ------------------------------------------------------------------------------------------ ;;; 30.4.3 The concrete menu-button Gadget (defclass menu-button-pane (menu-button standard-gadget-pane) () (:default-initargs :text-style (make-text-style :sans-serif nil nil) :background *3d-normal-color* :x-spacing 3 :y-spacing 2 :align-x :left :align-y :center)) (defmethod handle-repaint ((pane menu-button-pane) region) (declare (ignore region)) (with-slots (x-spacing y-spacing) pane (with-special-choices (pane) (let ((region (sheet-region pane))) (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* region) (draw-rectangle* pane x1 y1 x2 y2 :ink (effective-gadget-background pane) :filled t) (cond ((slot-value pane 'armed) (draw-bordered-rectangle* pane x1 y1 x2 y2 :style :outset :border-width *3d-border-thickness*)) (t)) (multiple-value-bind (x1 y1 x2 y2) (values (+ x1 x-spacing) (+ y1 y-spacing) (- x2 x-spacing) (- y2 y-spacing)) (if (gadget-active-p pane) (draw-label* pane x1 y1 x2 y2 :ink (effective-gadget-foreground pane)) (draw-engraved-label* pane x1 y1 x2 y2)))))))) (defmethod compose-space ((gadget menu-button-pane) &key width height) (declare (ignore width height)) (space-requirement+* (space-requirement+* (compose-label-space gadget) :min-width (* 2 (pane-x-spacing gadget)) :width (* 2 (pane-x-spacing gadget)) :max-width (* 2 (pane-x-spacing gadget)) :min-height (* 2 (pane-y-spacing gadget)) :height (* 2 (pane-y-spacing gadget)) :max-height (* 2 (pane-y-spacing gadget))) :min-width (* 2 *3d-border-thickness*) :width (* 2 *3d-border-thickness*) :max-width (* 2 *3d-border-thickness*) :min-height (* 2 *3d-border-thickness*) :height (* 2 *3d-border-thickness*) :max-height (* 2 *3d-border-thickness*))) ;;; ------------------------------------------------------------------------------------------ ;;; 30.4.4 The concrete scroll-bar Gadget (defclass scroll-bar-pane (3D-border-mixin scroll-bar) ((event-state :initform nil) (drag-dy :initform nil) ;;; poor man's incremental redisplay ;; drawn state (up-state :initform nil) (dn-state :initform nil) (tb-state :initform nil) (tb-y1 :initform nil) (tb-y2 :initform nil) ;; old drawn state (old-up-state :initform nil) (old-dn-state :initform nil) (old-tb-state :initform nil) (old-tb-y1 :initform nil) (old-tb-y2 :initform nil) ;; (all-new-p :initform t) ) (:default-initargs :border-width 2 :border-style :inset :background *3d-inner-color*)) (defmethod compose-space ((sb scroll-bar-pane) &key width height) (declare (ignore width height)) (if (eq (gadget-orientation sb) :vertical) (make-space-requirement :min-width 1 :width *scrollbar-thickness* :min-height (* 3 *scrollbar-thickness*) :height (* 4 *scrollbar-thickness*)) (make-space-requirement :min-height 1 :height *scrollbar-thickness* :min-width (* 3 *scrollbar-thickness*) :width (* 4 *scrollbar-thickness*)))) ;;;; Redisplay (defun scroll-bar/update-display (scroll-bar) (with-slots (up-state dn-state tb-state tb-y1 tb-y2 old-up-state old-dn-state old-tb-state old-tb-y1 old-tb-y2 all-new-p) scroll-bar ;; (scroll-bar/compute-display scroll-bar) ;; redraw up arrow (unless (and (not all-new-p) (eql up-state old-up-state)) (with-drawing-options (scroll-bar :transformation (scroll-bar-transformation scroll-bar)) (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-up-region scroll-bar) (draw-rectangle* scroll-bar x1 y1 x2 y2 :ink *3d-inner-color*) (let ((pg (list (make-point (/ (+ x1 x2) 2) y1) (make-point x1 y2) (make-point x2 y2)))) (case up-state (:armed (draw-polygon scroll-bar pg :ink *3d-inner-color*) (draw-bordered-polygon scroll-bar pg :style :inset :border-width 2)) (otherwise (draw-polygon scroll-bar pg :ink *3d-normal-color*) (draw-bordered-polygon scroll-bar pg :style :outset :border-width 2) ))))) ) ;; redraw dn arrow (unless (and (not all-new-p) (eql dn-state old-dn-state)) (with-drawing-options (scroll-bar :transformation (scroll-bar-transformation scroll-bar)) (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-down-region scroll-bar) (draw-rectangle* scroll-bar x1 y1 x2 y2 :ink *3d-inner-color*) (let ((pg (list (make-point (/ (+ x1 x2) 2) y2) (make-point x1 y1) (make-point x2 y1)))) (case dn-state (:armed (draw-polygon scroll-bar pg :ink *3d-inner-color*) (draw-bordered-polygon scroll-bar pg :style :inset :border-width 2)) (otherwise (draw-polygon scroll-bar pg :ink *3d-normal-color*) (draw-bordered-polygon scroll-bar pg :style :outset :border-width 2))))))) ;; thumb (unless (and (not all-new-p) (and (eql tb-state old-tb-state) (eql tb-y1 old-tb-y1) (eql tb-y2 old-tb-y2))) (cond ((and (not all-new-p) (eql tb-state old-tb-state) (numberp tb-y1) (numberp old-tb-y1) (numberp tb-y2) (numberp old-tb-y2) (= (- tb-y2 tb-y1) (- old-tb-y2 old-tb-y1))) ;; Thumb is just moving, compute old and new region (multiple-value-bind (x1 ignore.1 x2 ignore.2) (bounding-rectangle* (scroll-bar-thumb-bed-region scroll-bar)) (declare (ignore ignore.1 ignore.2)) ;; compute new and old region (with-sheet-medium (medium scroll-bar) (with-drawing-options (medium :transformation (scroll-bar-transformation scroll-bar)) (multiple-value-bind (ox1 oy1 ox2 oy2) (values x1 old-tb-y1 x2 old-tb-y2) (multiple-value-bind (nx1 ny1 nx2 ny2) (values x1 tb-y1 x2 tb-y2) (declare (ignore nx2)) (copy-area medium ox1 oy1 (- ox2 ox1) (- oy2 oy1) nx1 ny1) ;; clear left-overs from the old region (if (< oy1 ny1) (draw-rectangle* medium ox1 oy1 ox2 ny1 :ink *3d-inner-color*) (draw-rectangle* medium ox1 oy2 ox2 ny2 :ink *3d-inner-color*)))) )))) (t ;; redraw whole thumb bed and thumb all anew (with-drawing-options (scroll-bar :transformation (scroll-bar-transformation scroll-bar)) (with-bounding-rectangle* (bx1 by1 bx2 by2) (scroll-bar-thumb-bed-region scroll-bar) (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-thumb-region scroll-bar) (draw-rectangle* scroll-bar bx1 by1 bx2 y1 :ink *3d-inner-color*) (draw-rectangle* scroll-bar bx1 y2 bx2 by2 :ink *3d-inner-color*) (draw-rectangle* scroll-bar x1 y1 x2 y2 :ink *3d-normal-color*) (draw-bordered-polygon scroll-bar (polygon-points (make-rectangle* x1 y1 x2 y2)) :style :outset :border-width 2) ;;;;;; (let ((y (/ (+ y1 y2) 2))) (draw-bordered-polygon scroll-bar (polygon-points (make-rectangle* (+ x1 3) (- y 1) (- x2 3) (+ y 1))) :style :inset :border-width 1) (draw-bordered-polygon scroll-bar (polygon-points (make-rectangle* (+ x1 3) (- y 4) (- x2 3) (- y 2))) :style :inset :border-width 1) (draw-bordered-polygon scroll-bar (polygon-points (make-rectangle* (+ x1 3) (+ y 4) (- x2 3) (+ y 2))) :style :inset :border-width 1)))))))) (setf old-up-state up-state old-dn-state dn-state old-tb-state tb-state old-tb-y1 tb-y1 old-tb-y2 tb-y2 all-new-p nil) )) (defun scroll-bar/compute-display (scroll-bar) (with-slots (up-state dn-state tb-state tb-y1 tb-y2 event-state) scroll-bar (setf up-state (if (eq event-state :up-armed) :armed nil)) (setf dn-state (if (eq event-state :dn-armed) :armed nil)) (setf tb-state nil) ;we have no armed display yet (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-thumb-region scroll-bar) (declare (ignore x1 x2)) (setf tb-y1 y1 tb-y2 y2)))) ;;;; Utilities ;; We think all scroll bars as vertically oriented, therefore we have ;; SCROLL-BAR-TRANSFORMATION, which should make every scroll bar ;; look like being vertically oriented -- simplifies much code. (defmethod scroll-bar-transformation ((sb scroll-bar)) (ecase (gadget-orientation sb) (:vertical +identity-transformation+) (:horizontal (make-transformation 0 1 1 0 0 0)))) (defun translate-range-value (a mina maxa mino maxo &optional (empty-result (/ (+ mino maxo) 2))) "When \arg{a} is some value in the range from \arg{mina} to \arg{maxa}, proportionally translate the value into the range \arg{mino} to \arg{maxo}." (if (zerop (- maxa mina)) empty-result (+ mino (* (/ (- a mina) (- maxa mina)) (- maxo mino))))) ;;;; SETF :after methods (defmethod (setf gadget-min-value) :after (new-value (pane scroll-bar-pane)) (declare (ignore new-value)) (scroll-bar/update-display pane)) (defmethod (setf gadget-max-value) :after (new-value (pane scroll-bar-pane)) (declare (ignore new-value)) (scroll-bar/update-display pane)) (defmethod (setf scroll-bar-thumb-size) :after (new-value (pane scroll-bar-pane)) (declare (ignore new-value)) (scroll-bar/update-display pane)) (defmethod (setf gadget-value) :after (new-value (pane scroll-bar-pane) &key invoke-callback) (declare (ignore new-value invoke-callback)) (scroll-bar/update-display pane)) (defmethod* (setf scroll-bar-values) (min-value max-value thumb-size value (scroll-bar scroll-bar-pane)) (setf (slot-value scroll-bar 'min-value) min-value (slot-value scroll-bar 'max-value) max-value (slot-value scroll-bar 'thumb-size) thumb-size (slot-value scroll-bar 'value) value) (scroll-bar/update-display scroll-bar)) ;;;; geometry (defparameter +minimum-thumb-size-in-pixels+ 30) (defmethod scroll-bar-up-region ((sb scroll-bar-pane)) (with-bounding-rectangle* (minx miny maxx maxy) (transform-region (scroll-bar-transformation sb) (pane-inner-region sb)) (declare (ignore maxy)) (make-rectangle* minx miny maxx (+ miny (- maxx minx))))) (defmethod scroll-bar-down-region ((sb scroll-bar-pane)) (with-bounding-rectangle* (minx miny maxx maxy) (transform-region (scroll-bar-transformation sb) (pane-inner-region sb)) (declare (ignore miny)) (make-rectangle* minx (- maxy (- maxx minx)) maxx maxy))) (defun scroll-bar/thumb-bed* (sb) ;; -> y1 y2 y3 (with-bounding-rectangle* (minx miny maxx maxy) (transform-region (scroll-bar-transformation sb) (pane-inner-region sb)) (let ((y1 (+ miny (- maxx minx) 1)) (y3 (- maxy (- maxx minx) 1))) (let ((ts (scroll-bar-thumb-size sb))) ;; This is the right spot to handle ts = :none or perhaps NIL (multiple-value-bind (range) (gadget-range sb) (let ((ts-in-pixels (round (* (- y3 y1) (/ ts (max 1 (+ range ts))))))) ; handle range + ts = 0 (setf ts-in-pixels (min (- y3 y1) ;thumb can't be larger than the thumb bed (max +minimum-thumb-size-in-pixels+ ;but shouldn't be smaller than this. ts-in-pixels))) (values y1 (- y3 ts-in-pixels) y3))))))) (defmethod scroll-bar-thumb-bed-region ((sb scroll-bar-pane)) (with-bounding-rectangle* (minx miny maxx maxy) (transform-region (scroll-bar-transformation sb) (pane-inner-region sb)) (declare (ignore miny maxy)) (multiple-value-bind (y1 y2 y3) (scroll-bar/thumb-bed* sb) (declare (ignore y2)) (make-rectangle* minx y1 maxx y3)))) (defun scroll-bar/map-coordinate-to-value (sb y) (multiple-value-bind (y1 y2 y3) (scroll-bar/thumb-bed* sb) (declare (ignore y3)) (multiple-value-bind (minv maxv) (gadget-range* sb) (translate-range-value y y1 y2 minv maxv minv)))) (defun scroll-bar/map-value-to-coordinate (sb v) (multiple-value-bind (y1 y2 y3) (scroll-bar/thumb-bed* sb) (declare (ignore y3)) (multiple-value-bind (minv maxv) (gadget-range* sb) (round (translate-range-value v minv maxv y1 y2 y1))))) (defmethod scroll-bar-thumb-region ((sb scroll-bar-pane)) (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-thumb-bed-region sb) (declare (ignore y1 y2)) (multiple-value-bind (y1 y2 y3) (scroll-bar/thumb-bed* sb) (declare (ignore y1)) (let ((y4 (scroll-bar/map-value-to-coordinate sb (gadget-value sb)))) (make-rectangle* x1 y4 x2 (+ y4 (- y3 y2))))))) ;;;; event handler (defmethod handle-event ((sb scroll-bar-pane) (event pointer-button-press-event)) (multiple-value-bind (x y) (transform-position (scroll-bar-transformation sb) (pointer-event-x event) (pointer-event-y event)) (with-slots (event-state drag-dy) sb (cond ((region-contains-position-p (scroll-bar-up-region sb) x y) (scroll-up-line-callback sb (gadget-client sb) (gadget-id sb)) (setf event-state :up-armed) (scroll-bar/update-display sb)) ((region-contains-position-p (scroll-bar-down-region sb) x y) (scroll-down-line-callback sb (gadget-client sb) (gadget-id sb)) (setf event-state :dn-armed) (scroll-bar/update-display sb)) ;; ((region-contains-position-p (scroll-bar-thumb-region sb) x y) (setf event-state :dragging drag-dy (- y (bounding-rectangle-min-y (scroll-bar-thumb-region sb))))) ;; ((region-contains-position-p (scroll-bar-thumb-bed-region sb) x y) (if (< y (bounding-rectangle-min-y (scroll-bar-thumb-region sb))) (scroll-up-page-callback sb (gadget-client sb) (gadget-id sb)) (scroll-down-page-callback sb (gadget-client sb) (gadget-id sb)))) (t nil))))) (defmethod handle-event ((sb scroll-bar-pane) (event pointer-motion-event)) (multiple-value-bind (x y) (transform-position (scroll-bar-transformation sb) (pointer-event-x event) (pointer-event-y event)) (declare (ignore x)) (with-slots (event-state drag-dy) sb (case event-state (:dragging (let* ((y-new-thumb-top (- y drag-dy)) (new-value (min (gadget-max-value sb) (max (gadget-min-value sb) (scroll-bar/map-coordinate-to-value sb y-new-thumb-top)))) ) ;; ### when dragging value shouldn't be immediately updated (setf (gadget-value sb #|:invoke-callback nil|#) new-value) (drag-callback sb (gadget-client sb) (gadget-id sb) new-value)) ))))) (defmethod handle-event ((sb scroll-bar-pane) (event pointer-button-release-event)) (with-slots (event-state) sb (case event-state (:up-armed (setf event-state nil)) (:dn-armed (setf event-state nil)) (otherwise (setf event-state nil) ))) (scroll-bar/update-display sb) ) (defmethod handle-repaint ((pane scroll-bar-pane) region) (with-slots (all-new-p) pane (setf all-new-p t) (scroll-bar/update-display pane))) ;;; ------------------------------------------------------------------------------------------ ;;; 30.4.5 The concrete slider Gadget ;; ---------------------------------------------------------- ;; What should be done for having a better look for sliders ;; ;; We should find a way to draw the value, when show-value-p ;; is true, in a good position, or to dedicate a particular ;; sheet for this drawing (this sheet would be inside the ;; slider's sheet, probably his child). ;; ---------------------------------------------------------- ;; This values should be changeable by user. That's ;; why they are parameters, and not constants. (defparameter slider-button-long-dim 30) (defparameter slider-button-short-dim 10) (defclass slider-pane (slider-gadget basic-pane) ((drag-callback :initform nil :initarg :drag-callback :reader slider-drag-callback) (show-value-p :type boolean :initform nil :initarg :show-value-p :accessor gadget-show-value-p) (decimal-places :initform 0 :initarg :decimal-places :reader slider-decimal-places) (number-of-quanta :initform nil :initarg :number-of-quanta :reader slider-number-of-quanta))) (defmethod compose-space ((pane slider-pane) &key width height) (declare (ignore width height)) (let ((minor (+ 50 (if (gadget-show-value-p pane) 30 0))) (major 128)) (if (eq (gadget-orientation pane) :vertical) (make-space-requirement :min-width minor :width minor :min-height major :height major) (make-space-requirement :min-width major :width major :min-height minor :height minor)))) (defmethod initialize-instance :before ((pane slider-pane) &rest rest) (declare (ignore rest)) (setf (slot-value pane 'orientation) :vertical)) (defmethod drag-callback ((pane slider-pane) client gadget-id value) (declare (ignore client gadget-id)) (when (slider-drag-callback pane) (funcall (slider-drag-callback pane) pane value))) (defmethod handle-event ((pane slider-pane) (event pointer-enter-event)) (with-slots (armed) pane (unless armed (setf armed t)) (armed-callback pane (gadget-client pane) (gadget-id pane)))) (defmethod handle-event ((pane slider-pane) (event pointer-exit-event)) (with-slots (armed) pane (when armed (setf armed nil)) (disarmed-callback pane (gadget-client pane) (gadget-id pane)))) (defmethod handle-event ((pane slider-pane) (event pointer-button-press-event)) (with-slots (armed) pane (when armed (setf armed ':button-press)))) (defmethod handle-event ((pane slider-pane) (event pointer-motion-event)) (with-slots (armed) pane (when (eq armed ':button-press) (let ((value (convert-position-to-value pane (if (eq (gadget-orientation pane) :vertical) (pointer-event-y event) (pointer-event-x event))))) (setf (gadget-value pane :invoke-callback nil) value) (drag-callback pane (gadget-client pane) (gadget-id pane) value) (dispatch-repaint pane (sheet-region pane)))))) (defmethod handle-event ((pane slider-pane) (event pointer-button-release-event)) (with-slots (armed) pane (when armed (setf armed t (gadget-value pane :invoke-callback t) (convert-position-to-value pane (if (eq (gadget-orientation pane) :vertical) (pointer-event-y event) (pointer-event-x event)))) (dispatch-repaint pane (sheet-region pane))))) (defmethod convert-position-to-value ((pane slider-pane) dim) (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* (sheet-region pane)) (multiple-value-bind (good-dim1 good-dim2) (if (eq (gadget-orientation pane) :vertical) ;; vertical orientation (values (+ y1 (ash slider-button-short-dim -1)) (- y2 (ash slider-button-short-dim -1))) ;; horizontal orientation (values (+ x1 (ash slider-button-short-dim -1)) (- x2 (ash slider-button-short-dim -1)))) (let ((displacement (/ (- (max good-dim1 (min dim good-dim2)) good-dim1) (- good-dim2 good-dim1))) (quanta (slider-number-of-quanta pane))) (+ (gadget-min-value pane) (* (gadget-range pane) (if quanta (/ (round (* displacement quanta)) quanta) displacement))))))) (defun format-value (value decimal-places) (if (<= decimal-places 0) (format nil "~D" (round value)) (let ((control-string (format nil "~~,~DF" decimal-places))) (format nil control-string value)))) (defmethod handle-repaint ((pane slider-pane) region) (declare (ignore region)) (with-special-choices (pane) (let ((position (convert-value-to-position pane)) (slider-button-half-short-dim (ash slider-button-short-dim -1)) (slider-button-half-long-dim (ash slider-button-long-dim -1)) (background-color (pane-background pane)) (inner-color (gadget-current-color pane))) (flet ((draw-thingy (x y) (draw-circle* pane x y 8.0 :filled t :ink inner-color) (draw-circle* pane x y 8.0 :filled nil :ink +black+) (draw-circle* pane x y 7.0 :filled nil :ink +white+ :start-angle (* 0.25 pi) :end-angle (* 1.25 pi)) (draw-circle* pane x y 7.0 :filled nil :ink +black+ :start-angle (* 1.25 pi) :end-angle (* 2.25 pi)))) (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* (sheet-region pane)) (display-gadget-background pane background-color 0 0 (- x2 x1) (- y2 y1)) (case (gadget-orientation pane) ((:vertical) (let ((middle (round (- x2 x1) 2))) (draw-bordered-polygon pane (polygon-points (make-rectangle* (- middle 2) (+ y1 slider-button-half-short-dim) (+ middle 2) (- y2 slider-button-half-short-dim))) :style :inset :border-width 2) (draw-thingy middle (- position slider-button-half-short-dim)) (when (gadget-show-value-p pane) (draw-text* pane (format-value (gadget-value pane) (slider-decimal-places pane)) 5 ;(- position slider-button-half-short-dim) (- middle slider-button-half-long-dim))))) ((:horizontal) (let ((middle (round (- y2 y1) 2))) (draw-bordered-polygon pane (polygon-points (make-rectangle* (+ x1 slider-button-half-short-dim) (- middle 2) (- x2 slider-button-half-short-dim) (+ middle 2))) :style :inset :border-width 2) (draw-thingy (- position slider-button-half-short-dim) middle) (when (gadget-show-value-p pane) (draw-text* pane (format-value (gadget-value pane) (slider-decimal-places pane)) 5 ;(- position slider-button-half-short-dim) (- middle slider-button-half-long-dim))))))))))) #| (defmethod handle-repaint ((pane slider-pane) region) (declare (ignore region)) (with-special-choices (pane) (let ((position (convert-value-to-position pane)) (slider-button-half-short-dim (ash slider-button-short-dim -1)) (slider-button-half-long-dim (ash slider-button-long-dim -1))) (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* (sheet-region pane)) (display-gadget-background pane (gadget-current-color pane) 0 0 (- x2 x1) (- y2 y1)) (if (eq (gadget-orientation pane) :vertical) ; vertical case (let ((middle (round (- x2 x1) 2))) (draw-line* pane middle (+ y1 slider-button-half-short-dim) middle (- y2 slider-button-half-short-dim) :ink +black+ (draw-rectangle* pane (- middle slider-button-half-long-dim) (- position slider-button-half-short-dim) (+ middle slider-button-half-long-dim) (+ position slider-button-half-short-dim) :ink +gray85+ :filled t) (draw-edges-lines* pane +white+ (- middle slider-button-half-long-dim) (- position slider-button-half-short-dim) +black+ (+ middle slider-button-half-long-dim) (+ position slider-button-half-short-dim)) (when (gadget-show-value-p pane) (draw-text* pane (format-value (gadget-value pane) (slider-decimal-places pane)) 5 ;(- middle slider-button-half-short-dim) 10))) ;(- position slider-button-half-long-dim) ; horizontal case (let ((middle (round (- y2 y1) 2))) (draw-line* pane (+ x1 slider-button-half-short-dim) middle (- x2 slider-button-half-short-dim) middle :ink +black+) (draw-rectangle* pane (- position slider-button-half-short-dim) (- middle slider-button-half-long-dim) (+ position slider-button-half-short-dim) (+ middle slider-button-half-long-dim) :ink +gray85+ :filled t) (draw-edges-lines* pane +white+ (- position slider-button-half-short-dim) (- middle slider-button-half-long-dim) +black+ (+ position slider-button-half-short-dim) (+ middle slider-button-half-long-dim)) (when (gadget-show-value-p pane) (draw-text* pane (format-value (gadget-value pane) (slider-decimal-places pane)) 5 ;(- position slider-button-half-short-dim) (- middle slider-button-half-long-dim))))))))) |# (defmethod convert-value-to-position ((pane slider-pane)) (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* (sheet-region pane)) (let ((x1 (+ x1 8.0)) ; replace this with some rectangle-inset transform or something (y1 (+ y1 8.0))) (multiple-value-bind (good-dim1 good-dim2) (if (eq (gadget-orientation pane) :vertical) ; vertical orientation (values (+ y1 (ash slider-button-short-dim -1)) (- y2 (ash slider-button-short-dim -1))) ; horizontal orientation (values (+ x1 (ash slider-button-short-dim -1)) (- x2 (ash slider-button-short-dim -1)))) (+ good-dim1 (* (- good-dim2 good-dim1) (if (zerop (gadget-range pane)) 0.5 (/ (- (gadget-value pane) (gadget-min-value pane)) (gadget-range pane))))))))) ;;; ------------------------------------------------------------------------------------------ ;;; 30.4.6 The concrete radio-box and check-box Gadgets ;; radio-box (defclass radio-box-pane (radio-box rack-layout-mixin sheet-multiple-child-mixin basic-pane) () (:default-initargs :background *3d-normal-color*)) (defmethod initialize-instance :after ((pane radio-box-pane) &key choices current-selection orientation &allow-other-keys) (setf (box-layout-orientation pane) orientation) (setf (gadget-value pane) current-selection) (let ((children (mapcar (lambda (c) (let ((c (if (stringp c) (make-pane 'toggle-button-pane :label c :value nil) c))) (setf (gadget-value c) (if (eq c (radio-box-current-selection pane)) t nil)) (setf (gadget-client c) pane) c)) choices))) (mapc (curry #'sheet-adopt-child pane) children))) (defmethod (setf gadget-value) :after (button (radio-box radio-box-pane) &key invoke-callback) ;; this is silly, but works ... (dolist (c (sheet-children radio-box)) (unless (eq (not (null (eq c button))) (not (null (gadget-value c)))) (setf (gadget-value c :invoke-callback invoke-callback) (eq c button)) ))) ;; check-box (defclass check-box-pane (check-box rack-layout-mixin sheet-multiple-child-mixin basic-pane) () (:default-initargs :text-style (make-text-style :sans-serif nil nil) :background *3d-normal-color*)) (defmethod initialize-instance :after ((pane check-box-pane) &key choices current-selection orientation &allow-other-keys) (setf (box-layout-orientation pane) orientation) (setf (gadget-value pane) current-selection) (let ((children (mapcar (lambda (c) (let ((c (if (stringp c) (make-pane 'toggle-button-pane :label c :value nil) c))) (setf (gadget-value c) (if (member c current-selection) t nil)) (setf (gadget-client c) pane) c)) choices))) (mapc (curry #'sheet-adopt-child pane) children) )) ;;; ------------------------------------------------------------------------------------------ ;;; 30.4.7 The concrete list-pane and option-pane Gadgets ;;; LIST-PANE ;; Note: According to the LispWorks CLIM User's Guide, they do some peculiar ;; things in their list pane. Instead of :exclusive and :nonexclusive modes, ;; they call them :one-of and :some-of. I've supported these aliases for ;; compatibility. They also state the default mode is :some-of, which ;; contradicts the CLIM 2.0 Spec and doesn't make a lot of sense. ;; McCLIM defaults to :one-of. ;; TODO: Improve performance in order to scale to extremely large lists. ;; * Computing text-size for a 100k list items is expensive ;; * Need to share text size and cache of computed name-key/value-key ;; results with LIST-PANE when instantiated in the popup for ;; the OPTION-PANE. ;; * Improve repaint logic when items are selected to reduce flicker. ;; Currently the list and option panes are usable up to several thousand ;; items on a reasonably fast P4. ;; TODO: Consider appearance of nonexclusive option-pane when multiple items are ;; selected. ;; TODO: I think the list/option gadgets currently ignore enabled/disabled status. ;; Notes ;; A some-of/nonexclusive list pane (or option-pane popup window) supports ;; the following behaviors: ;; single-click: toggle selected item ;; shift-click: select/deselect multiple items. Selection or deselection ;; is chosen according to the result of your previous click. ;; McCLIM adds an initarg :prefer-single-selection. If true, a nonexclusive pane ;; will deselect other items selected when a new selection is made. Multiple ;; items can be selected using control-click, or shift-click as before. This ;; imitates the behvior of certain GUIs and may be useful in applications. (define-abstract-pane-mapping 'list-pane 'generic-list-pane) (defclass meta-list-pane () ((mode :initarg :mode :initform :exclusive :reader list-pane-mode :type (member :one-of :some-of :exclusive :nonexclusive)) (items :initarg :items :initform nil :reader list-pane-items :type sequence) (name-key :initarg :name-key :initform #'princ-to-string :reader list-pane-name-key :documentation "A function to be applied to items to gain a printable representation") (value-key :initarg :value-key :initform #'identity :reader list-pane-value-key :documentation "A function to be applied to items to gain its value for the purpose of GADGET-VALUE.") (presentation-type-key :initarg :presentation-type-key :initform (constantly nil) :reader list-pane-presentation-type-key :documentation "A function to be applied to items to find the presentation types for their values, or NIL.") (test :initarg :test :initform #'eql :reader list-pane-test :documentation "A function to compare two items for equality."))) (defclass generic-list-pane (list-pane meta-list-pane standard-sheet-input-mixin ;; Hmm.. value-changed-repaint-mixin mouse-wheel-scroll-mixin) ((highlight-ink :initform +royalblue4+ :initarg :highlight-ink :reader list-pane-highlight-ink) (item-strings :initform nil :documentation "Vector of item strings.") (item-values :initform nil :documentation "Vector of item values.") (items-width :initform nil :documentation "Width sufficient to contain all items") (last-action :initform nil :documentation "Last action performed on items in the pane, either :select, :deselect, or NIL if none has been performed yet.") (last-index :initform nil :documentation "Index of last item clicked, for extending selections.") (prefer-single-selection :initform nil :initarg :prefer-single-selection :documentation "For nonexclusive menus, emulate the common behavior of preferring selection of a single item, but allowing extension of the selection via the control modifier.") (items-length :initform nil :documentation "Number of items")) (:default-initargs :text-style (make-text-style :sans-serif :roman :normal) :background +white+ :foreground +black+)) (defmethod initialize-instance :after ((gadget meta-list-pane) &rest rest) (declare (ignorable rest)) ;; Initialize slot value if not specified #+NIL ;; XXX (when (slot-boundp gadget 'value) (setf (slot-value gadget 'value) (if (list-pane-exclusive-p gadget) (funcall (list-pane-value-key gadget) (first (list-pane-items gadget))) (mapcar #'list-pane-value-key (list (first (list-pane-items gadget))))))) (when (and (not (list-pane-exclusive-p gadget)) (not (listp (gadget-value gadget)))) (error "A :nonexclusive list-pane cannot be initialized with a value which is not a list.")) (when (not (list-pane-exclusive-p gadget)) (with-slots (value) gadget (setf value (copy-list value)))) #+IGNORE (when (and (list-pane-exclusive-p gadget) (> (length (gadget-value gadget)) 1)) (error "An 'exclusive' list-pane cannot be initialized with more than one item selected."))) (defmethod value-changed-callback :before ((gadget generic-list-pane) client gadget-id value) (declare (ignore client gadget-id)) ;; Maybe act as if a presentation was clicked on, but only if the ;; list pane only allows single-selection. (when (or (eq (list-pane-mode gadget) :one-of) (eq (list-pane-mode gadget) :exclusive)) (let* ((i (position value (generic-list-pane-item-values gadget))) (item (elt (list-pane-items gadget) i)) (ptype (funcall (list-pane-presentation-type-key gadget) item))) (when ptype (throw-object-ptype value ptype))))) (defun list-pane-exclusive-p (pane) (or (eql (list-pane-mode pane) :exclusive) (eql (list-pane-mode pane) :one-of))) (defmethod initialize-instance :after ((gadget generic-list-pane) &rest rest) (declare (ignorable rest)) ;; For a nonexclusive list-pane, compute some reasonable default for the last ;; selected item to make shift-click do something useful. (when (not (list-pane-exclusive-p gadget)) (with-slots (test last-action last-index) gadget (when (not (zerop (length (gadget-value gadget)))) (setf last-action :select last-index (reduce #'max (mapcar #'(lambda (item) (position item (generic-list-pane-item-values gadget) :test test)) (gadget-value gadget)))))))) (defmethod generic-list-pane-item-strings ((pane generic-list-pane)) (with-slots (item-strings) pane (or item-strings (setf item-strings (map 'vector (lambda (item) (let ((s (funcall (list-pane-name-key pane) item))) (if (stringp s) s (princ-to-string s)))) ;defensive programming! (list-pane-items pane)))))) (defmethod generic-list-pane-item-values ((pane generic-list-pane)) (with-slots (item-values) pane (or item-values (setf item-values (map 'vector (list-pane-value-key pane) (list-pane-items pane)))))) (defmethod generic-list-pane-items-width ((pane generic-list-pane)) (with-slots (items-width) pane (or items-width (setf items-width (reduce #'max (map 'vector (lambda (item-string) (text-size pane item-string)) (generic-list-pane-item-strings pane)) :initial-value 0))))) (defmethod generic-list-pane-items-length ((pane generic-list-pane)) (with-slots (items-length) pane (or items-length (setf items-length (length (generic-list-pane-item-strings pane)))))) (defmethod generic-list-pane-item-height ((pane generic-list-pane)) (+ (text-style-ascent (pane-text-style pane) pane) (text-style-descent (pane-text-style pane) pane))) (defmethod compose-space ((pane generic-list-pane) &key width height) (declare (ignore width height)) (let* ((n (generic-list-pane-items-length pane)) (w (generic-list-pane-items-width pane)) (h (* n (generic-list-pane-item-height pane)))) (make-space-requirement :width w :height h :min-width w :min-height h :max-width +fill+ :max-height +fill+))) (defmethod allocate-space ((pane generic-list-pane) w h) (resize-sheet pane w h)) (defmethod scroll-quantum ((pane generic-list-pane)) (generic-list-pane-item-height pane)) (defmethod handle-repaint ((pane generic-list-pane) region) (with-bounding-rectangle* (sx0 sy0 sx1 sy1) (sheet-region pane) (declare (ignore sx1 sy1)) (with-bounding-rectangle* (rx0 ry0 rx1 ry1) (if (bounding-rectangle-p region) region (or (pane-viewport-region pane) ; workaround for +everywhere+ (sheet-region pane))) (let ((item-height (generic-list-pane-item-height pane)) (highlight-ink (list-pane-highlight-ink pane))) (do ((index (floor (- ry0 sy0) item-height) (1+ index))) ((or (> (+ sy0 (* item-height index)) ry1) (>= index (generic-list-pane-items-length pane)))) (let ((y0 (+ sy0 (* index item-height))) (y1 (+ sy0 (* (1+ index) item-height)))) (multiple-value-bind (background foreground) (cond ((not (slot-boundp pane 'value)) (values (pane-background pane) (pane-foreground pane))) ((if (list-pane-exclusive-p pane) (funcall (list-pane-test pane) (elt (generic-list-pane-item-values pane) index) (gadget-value pane)) (member (elt (generic-list-pane-item-values pane) index) (gadget-value pane) :test (list-pane-test pane))) (values highlight-ink (pane-background pane))) (t (values (pane-background pane) (pane-foreground pane)))) (draw-rectangle* pane rx0 y0 rx1 y1 :filled t :ink background) (draw-text* pane (elt (generic-list-pane-item-strings pane) index) sx0 (+ y0 (text-style-ascent (pane-text-style pane) pane)) :ink foreground :text-style (pane-text-style pane))))))))) (defun generic-list-pane-select-item (pane item-value) "Toggle selection of a single item in the generic-list-pane. Returns :select or :deselect, depending on what action was performed." (if (list-pane-exclusive-p pane) (progn (setf (gadget-value pane :invoke-callback t) item-value) :select) (let ((member (member item-value (gadget-value pane) :test (list-pane-test pane)))) (setf (gadget-value pane :invoke-callback t) (cond ((list-pane-exclusive-p pane) (list item-value)) (member (remove item-value (gadget-value pane) :test (list-pane-test pane))) ((not member) (cons item-value (gadget-value pane))))) (if member :deselect :select)))) (defun generic-list-pane-add-selected-items (pane item-values) "Add a set of items to the current selection" (when (not (list-pane-exclusive-p pane)) (setf (gadget-value pane :invoke-callback t) (remove-duplicates (append item-values (gadget-value pane)) :test (list-pane-test pane))))) (defun generic-list-pane-deselect-items (pane item-values) "Remove a set of items from the current selection" (when (not (list-pane-exclusive-p pane)) (setf (gadget-value pane :invoke-calback t) (labels ((fun (item-values result) (if (null item-values) result (fun (rest item-values) (delete (first item-values) result :test (list-pane-test pane)))))) (fun item-values (gadget-value pane)))))) (defun generic-list-pane-item-from-x-y (pane mx my) "Given a pointer event, determine what item in the pane it has fallen upon. Returns two values, the item itself, and the index within the item list." (declare (ignore mx)) (with-bounding-rectangle* (sx0 sy0 sx1 sy1) (sheet-region pane) (declare (ignorable sx0 sx1 sy1)) (with-slots (items) pane (let* ((item-height (generic-list-pane-item-height pane)) (number-of-items (generic-list-pane-items-length pane)) (n (floor (- my sy0) item-height)) (index (and (>= n 0) (< n number-of-items) n)) (item-value (and index (elt (generic-list-pane-item-values pane) index)))) (values item-value index))))) (defun generic-list-pane-handle-click (pane x y modifier) (multiple-value-bind (item-value index) (generic-list-pane-item-from-x-y pane x y) (if (list-pane-exclusive-p pane) ;; Exclusive mode (when index (setf (slot-value pane 'last-action) (generic-list-pane-select-item pane item-value))) ;; Nonexclusive mode (when index (with-slots (last-index last-action items prefer-single-selection) pane (cond ;; Add single selection ((not (zerop (logand modifier +control-key+))) (setf last-action (generic-list-pane-select-item pane item-value))) ;; Maybe extend selection ((not (zerop (logand modifier +shift-key+))) (if (and (numberp last-index) (not (null last-action))) ;; Extend last selection (funcall (if (eql last-action :select) #'generic-list-pane-add-selected-items #'generic-list-pane-deselect-items) pane (coerce (subseq (generic-list-pane-item-values pane) (min last-index index) (1+ (max last-index index))) 'list)) (setf last-action (generic-list-pane-select-item pane item-value)))) ;; Toggle single item (t (if prefer-single-selection (setf (gadget-value pane :invoke-callback t) (list item-value) last-action :select) (setf last-action (generic-list-pane-select-item pane item-value))))) (setf last-index index)))))) (defun generic-list-pane-handle-click-from-event (pane event) (multiple-value-bind (x y) (values (pointer-event-x event) (pointer-event-y event)) (generic-list-pane-handle-click pane x y (event-modifier-state event)))) (defclass ad-hoc-presentation (standard-presentation) ()) (defmethod output-record-hit-detection-rectangle* ((presentation ad-hoc-presentation)) (values most-negative-fixnum most-negative-fixnum most-positive-fixnum most-positive-fixnum)) (defun generic-list-pane-handle-right-click (pane event) (multiple-value-bind (x y) (values (pointer-event-x event) (pointer-event-y event)) (multiple-value-bind (item-value index) (generic-list-pane-item-from-x-y pane x y) (let* ((item (elt (list-pane-items pane) index))) (meta-list-pane-call-presentation-menu pane item))))) (defun meta-list-pane-call-presentation-menu (pane item) (let ((ptype (funcall (list-pane-presentation-type-key pane) item))) (when ptype (let ((presentation (make-instance 'ad-hoc-presentation :object (funcall (list-pane-value-key pane) item) :single-box t :type ptype))) (call-presentation-menu presentation *input-context* *application-frame* pane 42 42 :for-menu t :label (format nil "Operation on ~A" ptype)))))) (defmethod handle-event ((pane generic-list-pane) (event pointer-button-press-event)) (case (pointer-event-button event) (#.+pointer-left-button+ (generic-list-pane-handle-click-from-event pane event) (setf (slot-value pane 'armed) nil)) (#.+pointer-right-button+ (generic-list-pane-handle-right-click pane event)) (t (when (next-method-p) (call-next-method))))) (defmethod handle-event ((pane generic-list-pane) (event pointer-button-release-event)) (if (eql (pointer-event-button event) +pointer-left-button+) (and (slot-value pane 'armed) (generic-list-pane-handle-click-from-event pane event)) (when (next-method-p) (call-next-method)))) (defgeneric (setf list-pane-items) (newval pane &key invoke-callback) (:documentation "Set the current list of items for this list pane. The current GADGET-VALUE will be adjusted by removing values not specified by the new items. VALUE-CHANGED-CALLBACK will be called if INVOKE-CALLBACK is given.")) (defmethod (setf list-pane-items) (newval (pane meta-list-pane) &key invoke-callback) (declare (ignore invoke-callback)) (setf (slot-value pane 'items) newval)) (defmethod (setf list-pane-items) :after (newval (pane meta-list-pane) &key invoke-callback) (when (slot-boundp pane 'value) (let ((new-values (coerce (climi::generic-list-pane-item-values pane) 'list)) (test (list-pane-test pane))) (setf (gadget-value pane :invoke-callback invoke-callback) (if (list-pane-exclusive-p pane) (if (find (gadget-value pane) new-values :test test) (gadget-value pane) nil) (intersection (gadget-value pane) new-values :test test)))))) (defmethod (setf list-pane-items) (newval (pane generic-list-pane) &key invoke-callback) (call-next-method) (with-slots (items items-length item-strings item-values) pane (setf items-length (length newval)) (setf item-strings nil) (setf item-values nil))) (defmethod (setf list-pane-items) :after (newval (pane generic-list-pane) &key invoke-callback) (change-space-requirements pane :height (space-requirement-height (compose-space pane))) (handle-repaint pane +everywhere+)) ;;; OPTION-PANE (define-abstract-pane-mapping 'option-pane 'generic-option-pane) (defclass generic-option-pane (option-pane meta-list-pane value-changed-repaint-mixin 3d-border-mixin arm/disarm-repaint-mixin enter/exit-arms/disarms-mixin) ((current-label :initform "" :accessor generic-option-pane-label)) (:default-initargs :text-style (make-text-style :sans-serif :roman :normal))) (defun option-pane-evil-backward-map (pane value) (let ((key-fn (list-pane-value-key pane))) (if (eql key-fn #'identity) ;; SANE CASE value (find value (list-pane-items pane) ;; INSANE CASE :key key-fn :test (list-pane-test pane))))) (defun generic-option-pane-compute-label-from-value (pane value) (flet ((label (value) (funcall (list-pane-name-key pane) (option-pane-evil-backward-map pane value)))) (if (list-pane-exclusive-p pane) (if (or value (member nil (list-pane-items pane) ;; Kludge in case NIL is part of the item set.. :key (list-pane-value-key pane) :test (list-pane-test pane))) (label value) "") (cond ((= 0 (length value)) "") ((= 1 (length value)) (label (first value))) (t "..."))))) (defun generic-option-pane-compute-label-from-item (pane item) (funcall (list-pane-name-key pane) item)) (defun generic-option-pane-compute-label (pane) (generic-option-pane-compute-label-from-value pane (gadget-value pane))) (defmethod initialize-instance :after ((object generic-option-pane) &rest rest) (declare (ignore rest)) (setf (slot-value object 'current-label) (if (slot-boundp object 'value) (generic-option-pane-compute-label object) ""))) (defmethod (setf gadget-value) :after (new-value (gadget generic-option-pane) &key &allow-other-keys) (setf (slot-value gadget 'current-label) (generic-option-pane-compute-label-from-value gadget new-value))) (defmethod generic-option-pane-widget-size (pane) ;; We now always make the widget occupying a square. (let ((h (bounding-rectangle-height pane))) (values h h))) (defun draw-engraved-vertical-separator (pane x y0 y1 highlight-color shadow-color) (draw-line* pane (1+ x) (1+ y0) (1+ x) (1- y1) :ink highlight-color) (draw-line* pane x y1 (1+ x) y1 :ink highlight-color) (draw-line* pane x (1+ y0) x (1- y1) :ink shadow-color) (draw-line* pane x y0 (1+ x) y0 :ink shadow-color)) (defun generic-option-pane-text-size (pane) (text-size (sheet-medium pane) (slot-value pane 'current-label) :text-style (pane-text-style pane))) (defun draw-vertical-arrow (sheet x0 y0 direction) (assert (or (eq direction :up) (eq direction :down))) (let* ((dx -4) (dy 4) (shape (if (eq direction :up) ;; Hack-p? (list x0 y0 (+ x0 dx) (+ 1 y0 dy) (- x0 dx) (+ 1 y0 dy)) (list x0 y0 (+ 1 x0 dx) (+ y0 (- dy)) (- x0 dx) (+ y0 (- dy)))))) (draw-polygon* sheet shape :ink +black+))) (defun generic-option-pane-compute-max-label-width (pane) (max (reduce #'max (mapcar #'(lambda (value) (text-size (sheet-medium pane) (generic-option-pane-compute-label-from-item pane value) :text-style (pane-text-style pane))) (list-pane-items pane))) (text-size (sheet-medium pane) "..." :text-style (pane-text-style pane)))) (defmethod compose-space ((pane generic-option-pane) &key width height) (declare (ignore width height)) (let* ((horizontal-padding 8) ;### 2px border + 2px padding each side (vertical-padding 8) ;### this should perhaps be computed from ;### border-width and spacing. (l-width (generic-option-pane-compute-max-label-width pane)) (l-height (text-style-height (pane-text-style pane) (sheet-medium pane))) (total-width (+ horizontal-padding l-width ;; widget width l-height 8)) (total-height (+ vertical-padding l-height))) (make-space-requirement :min-width total-width :width total-width :max-width +fill+ :min-height total-height :height total-height :max-height total-height))) (defmethod generic-option-pane-draw-widget (pane) (with-bounding-rectangle* (x0 y0 x1 y1) pane (declare (ignore x0)) (multiple-value-bind (widget-width widget-height) (generic-option-pane-widget-size pane) (let ((center (floor (/ (- y1 y0) 2))) (height/2 (/ widget-height 2)) (highlight-color (compose-over (compose-in +white+ (make-opacity 0.85)) (pane-background pane))) (shadow-color (compose-over (compose-in +black+ (make-opacity 0.3)) (pane-background pane)))) (draw-engraved-vertical-separator pane (- x1 widget-width -1) (- center height/2) (+ center height/2) highlight-color shadow-color) (let* ((x (+ (- x1 widget-width) (/ widget-width 2))) (frob-x (+ (floor x) 0))) (draw-vertical-arrow pane frob-x (- center 6) :up) (draw-vertical-arrow pane frob-x (+ center 6) :down)))))) (defun rewrite-event-for-grab (grabber event) (multiple-value-bind (nx ny) (multiple-value-call #'untransform-position (sheet-delta-transformation grabber nil) ;; assumes this is the graft's coordinate system.. (values (pointer-event-native-graft-x event) (pointer-event-native-graft-y event))) (with-slots (sheet x y) event (setf sheet grabber x nx y ny))) event) (defun popup-compute-spaces (pane graft) (with-bounding-rectangle* (x0 top x1 bottom) (sheet-region pane) (multiple-value-call #'(lambda (x0 top x1 bottom) (declare (ignore x0 x1)) (values (max 0 (1- top)) (max 0 (- (graft-height graft) bottom)) top bottom)) (transform-position (sheet-delta-transformation pane nil) x0 top) ;; XXX (see above) (transform-position (sheet-delta-transformation pane nil) x1 bottom)))) (defun popup-compute-height (parent-pane child-pane) "Decides whether to place the child-pane above or below the parent-pane, and how to do so. Returns three values: First T if the pane is too large to fit on the screen, otherwise NIL. Second, whether to place the child-pane above or below parent-pane. Third, the height which the popup should be constrained to if the first value is true." (let* ((sr (compose-space child-pane)) (height (space-requirement-min-height sr))) (multiple-value-bind (top-space bottom-space) (popup-compute-spaces parent-pane (graft parent-pane)) (let ((polite-ts (* 0.8 top-space)) (polite-bs (* 0.8 bottom-space))) (cond ((and (<= polite-ts height) (<= polite-bs height)) (multiple-value-call #'values t (if (> top-space bottom-space) (values :above (* 0.7 top-space)) (values :below (* 0.7 bottom-space))))) ((> polite-bs height) (values nil :below height)) (t (values nil :above height))))))) (defun popup-init (parent manager frame) (let ((list-pane (apply #'make-pane-1 manager frame 'generic-list-pane :items (list-pane-items parent) :mode (list-pane-mode parent) :name-key (list-pane-name-key parent) :value-key (list-pane-value-key parent) :test (list-pane-test parent) (and (slot-boundp parent 'value) (list :value (gadget-value parent)))))) (multiple-value-bind (scroll-p position height) (popup-compute-height parent list-pane) (with-bounding-rectangle* (cx0 cy0 cx1 cy1) parent (multiple-value-bind (x0 y0 x1 y1) (multiple-value-call #'values (transform-position (sheet-delta-transformation parent nil) cx0 cy0) (transform-position (sheet-delta-transformation parent nil) cx1 cy1)) ;; Note: This :suggested-width/height business is really a silly hack ;; which I could have easily worked around without adding kludges ;; to the scroller-pane.. (let* ((topmost-pane (if scroll-p ;list-pane (scrolling (:scroll-bar :vertical :suggest-height height ;; Doesn't appear to be working.. :suggest-width (if scroll-p (+ 30 (bounding-rectangle-width list-pane)))) list-pane) list-pane)) (topmost-pane (outlining (:thickness 1) topmost-pane)) (composed-height (space-requirement-height (compose-space topmost-pane :width (- x1 x0) :height height))) (menu-frame (make-menu-frame topmost-pane :min-width (bounding-rectangle-width parent) :left x0 :top (if (eq position :below) y1 (- y0 composed-height 1))))) (values list-pane topmost-pane menu-frame))))))) (defun popup-list-box (parent) (let* ((frame *application-frame*) (manager (frame-manager frame)) ;; Popup state (final-change nil) ;; Menu should exit after next value change (inner-grab nil) ;; Gadget is grabbing the pointer, used to simulate ;; X implicit pointer grabbing (for the scrollbar) (retain-value nil) (consume-and-exit nil) ;; If true, wait until a button release then exit (last-click-time nil) (last-item-index nil)) (with-look-and-feel-realization (manager *application-frame*) (multiple-value-bind (list-pane topmost-pane menu-frame) (popup-init parent manager frame) (setf (slot-value list-pane 'armed) t) (adopt-frame manager menu-frame) (labels ((in-window (window child x y) (and window (sheet-ancestor-p child window) (multiple-value-call #'region-contains-position-p (sheet-region window) (transform-position (sheet-delta-transformation child window) x y)))) (in-list (window x y) (in-window list-pane window x y)) (in-menu (window x y) (in-window topmost-pane window x y)) (compute-double-clicked () (let* ((now (get-internal-real-time))) (prog1 (and last-click-time (< (/ (- now last-click-time) internal-time-units-per-second) *double-click-delay*)) (setf last-click-time now)))) (end-it () (throw 'popup-list-box-done nil))) (catch 'popup-list-box-done (setf (slot-value list-pane 'value-changed-callback) (lambda (pane value) (declare (ignore pane value)) (when (and final-change (not consume-and-exit)) (end-it)))) (tracking-pointer (list-pane :multiple-window t :highlight nil) (:pointer-motion (&key event window x y) (cond (inner-grab (handle-event inner-grab (rewrite-event-for-grab inner-grab event))) ((and (list-pane-exclusive-p parent) (in-list window x y)) (generic-list-pane-handle-click list-pane x y 0)) ((in-menu window x y) (handle-event window event)))) (:pointer-button-press (&key event x y) (if inner-grab (handle-event inner-grab event) (cond ((in-list (event-sheet event) x y) (multiple-value-bind (item current-index) (generic-list-pane-item-from-x-y list-pane x y) (declare (ignore item)) (let ((double-clicked (and (compute-double-clicked) (= (or last-item-index -1) (or current-index -2)))) (exclusive (list-pane-exclusive-p parent))) (setf retain-value t final-change (or exclusive double-clicked) last-item-index current-index consume-and-exit (or exclusive (and (not exclusive) double-clicked))) (unless (and (not exclusive) double-clicked) (handle-event list-pane event))))) ((in-menu (event-sheet event) x y) (handle-event (event-sheet event) event) (setf inner-grab (event-sheet event))) (t (setf consume-and-exit t))))) (:pointer-button-release (&key event x y) (when consume-and-exit (end-it)) (cond (inner-grab (handle-event inner-grab event) (setf inner-grab nil)) ((in-list (event-sheet event) x y) (when (list-pane-exclusive-p parent) (setf retain-value t final-change t) (handle-event list-pane event))) ((in-menu (event-sheet event) x y) (handle-event (event-sheet event) event))))))) ;; Cleanup and exit (when retain-value (setf (gadget-value parent :invoke-callback t) (gadget-value list-pane))) (disown-frame manager menu-frame))))) (defmethod handle-event ((pane generic-option-pane) (event pointer-button-press-event)) (popup-list-box pane) (disarm-gadget pane)) (defmethod handle-repaint ((pane generic-option-pane) region) (with-bounding-rectangle* (x0 y0 x1 y1) (sheet-region pane) (multiple-value-bind (widget-width widget-height) (generic-option-pane-widget-size pane) (declare (ignore widget-height)) (draw-rectangle* pane x0 y0 x1 y1 :ink (effective-gadget-background pane)) (let* ((tx1 (- x1 widget-width))) (draw-text* pane (slot-value pane 'current-label) (/ (- tx1 x0) 2) (/ (+ (- y1 y0) (- (text-style-ascent (pane-text-style pane) pane) (text-style-descent (pane-text-style pane) pane))) 2) :align-x :center :align-y :baseline)) (generic-option-pane-draw-widget pane)))) ;;;; ------------------------------------------------------------------------------------------ ;;;; ;;;; 30.5 Integrating Gadgets and Output Records ;;;; ;; ;; GADGET-OUTPUT-RECORD ;; (defclass gadget-output-record (basic-output-record displayed-output-record) ((gadget :initarg :gadget :accessor gadget))) (defmethod initialize-instance :after ((record gadget-output-record) &key x y) (setf (output-record-position record) (values x y))) (defmethod note-output-record-got-sheet ((record gadget-output-record) sheet) (multiple-value-bind (x y) (output-record-position record) (sheet-adopt-child sheet (gadget record)) (allocate-space (gadget record) (rectangle-width record) (rectangle-height record)) (move-sheet (gadget record) x y))) (defmethod note-output-record-lost-sheet ((record gadget-output-record) sheet) (sheet-disown-child sheet (gadget record))) ;; This is as good a place as any other to handle moving the position of the ;; gadget if the output record has moved. This is consistent with other ;; operations on output records that force you to manage repainting manually. (defmethod replay-output-record ((record gadget-output-record) stream &optional region x-offset y-offset) (declare (ignorable record stream region x-offset y-offset)) (multiple-value-bind (gx gy) (transform-position (sheet-transformation (gadget record)) 0 0) (multiple-value-bind (ox oy) (output-record-position record) (unless (and (= ox gx) (= oy gy)) (move-sheet (gadget record) ox oy))))) (defun setup-gadget-record (sheet record) (let* ((child (gadget record)) (sr (compose-space child)) (width (space-requirement-width sr)) (height (space-requirement-height sr))) (multiple-value-bind (x y)(output-record-position record) (setf (rectangle-edges* record) (values x y (+ x width) (+ y height))) (when t ; :move-cursor t ;; Almost like LWW, except baseline of text should align with bottom ;; of gadget? FIXME (setf (stream-cursor-position sheet) (values (+ x (bounding-rectangle-width record)) (+ y (bounding-rectangle-height record)))))))) ;; The CLIM 2.0 spec does not really say what this macro should return. ;; Existing code written for "Real CLIM" assumes it returns the gadget pane ;; object. I think returning the gadget-output-record would be more useful. ;; For compatibility I'm having it return (values GADGET GADGET-OUTPUT-RECORD) (defmacro with-output-as-gadget ((stream &rest options) &body body) ;; NOTE - incremental-redisplay 12/28/05 will call this on redisplay ;; unless wrapped in (updating-output (stream :cache-value t) ...) ;; Otherwise, new gadget-output-records are generated but only the first ;; gadget is ever adopted, and an erase-output-record called on a newer ;; gadget-output-record will face a sheet-not-child error when trying ;; to disown the never adopted gadget. (setf stream (stream-designator-symbol stream '*standard-output*)) (let ((gadget-output-record (gensym)) (x (gensym)) (y (gensym))) `(multiple-value-bind (,x ,y)(stream-cursor-position ,stream) (flet ((with-output-as-gadget-continuation (,stream record) (flet ((with-output-as-gadget-body (,stream) (declare (ignorable ,stream)) (progn ,@body))) (setf (gadget record) (with-output-as-gadget-body ,stream)))) (gadget-output-record-constructor () (make-instance 'gadget-output-record ,@options :x ,x :y ,y))) (declare (dynamic-extent #'with-output-as-gadget-continuation #'gadget-output-record-constructor)) (let ((,gadget-output-record (invoke-with-output-to-output-record ,stream #'with-output-as-gadget-continuation nil #'gadget-output-record-constructor))) (setup-gadget-record ,stream ,gadget-output-record) (stream-add-output-record ,stream ,gadget-output-record) (values (gadget ,gadget-output-record) ,gadget-output-record)))))) ;;; (defclass orientation-from-parent-mixin () ()) (defmethod orientation ((gadget orientation-from-parent-mixin)) (etypecase (sheet-parent gadget) ((or hbox-pane hrack-pane) :vertical) ((or vbox-pane vrack-pane) :horizontal))) (defclass clim-extensions::box-adjuster-gadget (standard-gadget 3d-border-mixin orientation-from-parent-mixin) ((drag-from :initform nil) (left-sr) (left-peer) (right-sr) (right-peer)) (:default-initargs :background *3d-inner-color*) (:documentation "The box-adjuster-gadget allows users to resize the panes in a layout by dragging the boundary between the panes. To use it, insert it in a layout between two panes that are to be resizeable. E.g.: (vertically () top-pane (make-pane 'clim-extensions:box-adjuster-gadget) bottom-pane)")) (defmethod compose-space ((gadget clim-extensions:box-adjuster-gadget) &key width height) (declare (ignore width height)) (if (eq (orientation gadget) :vertical) (make-space-requirement :min-width 6 :width 6 :max-width 6 :min-height 1 :height 1) (make-space-requirement :min-height 6 :height 6 :max-height 6 :min-width 1 :width 1))) (defmethod handle-event ((gadget clim-extensions:box-adjuster-gadget) (event pointer-button-press-event)) (with-slots (drag-from left-peer right-peer left-sr right-sr) gadget (setf drag-from (if (eq (orientation gadget) :vertical) (pointer-event-native-graft-x event) (pointer-event-native-graft-y event)) (values left-peer right-peer) (do ((current (box-layout-mixin-clients (sheet-parent gadget)) (rest current))) ((or (null (third current)) (eq gadget (box-client-pane (second current)))) (values (box-client-pane (first current)) (box-client-pane (third current))))) left-sr (compose-space left-peer) right-sr (compose-space right-peer)))) (defmethod handle-event ((gadget clim-extensions:box-adjuster-gadget) (event pointer-button-release-event)) (setf (slot-value gadget 'drag-from) nil)) (defun adjust-space-requirement (pane sr orientation delta) (multiple-value-bind (major major-max major-min) (if (eq orientation :vertical) (values (space-requirement-width sr) (space-requirement-max-width sr) (space-requirement-min-width sr)) (values (space-requirement-height sr) (space-requirement-max-height sr) (space-requirement-min-height sr))) (let ((new-major (max major-min (min major-max (+ major delta))))) (if (eq orientation :vertical) (change-space-requirements pane :width new-major) (change-space-requirements pane :height new-major)) (- new-major major)))) (defmethod handle-event ((gadget clim-extensions:box-adjuster-gadget) (event pointer-motion-event) &aux (orientation (orientation gadget))) (with-slots (drag-from left-peer left-sr right-peer right-sr) gadget (when (and drag-from (typep (sheet-parent gadget) 'box-layout-mixin)) (let* ((major-pos (if (eq orientation :vertical) (pointer-event-native-graft-x event) (pointer-event-native-graft-y event))) (delta (- major-pos drag-from))) (changing-space-requirements (:resize-frame nil) (adjust-space-requirement left-peer left-sr orientation delta) (adjust-space-requirement right-peer right-sr orientation (- delta))))))) (defmethod note-sheet-grafted ((sheet clim-extensions:box-adjuster-gadget)) (setf (sheet-pointer-cursor sheet) :rotate)) ;;; Support for definition of callbacks and associated callback events. A ;;; callback event is used by a backend when a high-level notification of a ;;; gadget state change is delivered in the CLIM event process -- by a native ;;; gadget, for example -- and must be delivered in the application process. (define-event-class callback-event (standard-event) ((sheet :initarg :gadget :reader event-gadget :documentation "An alias for sheet, for readability") (callback-function :initarg :callback-function :reader callback-function) (client :initarg :client :reader event-client) (client-id :initarg :client-id :reader event-client-id) (other-args :initarg :other-args :reader event-other-args :initform nil))) (defun queue-callback (fn gadget client client-id &rest other-args) (queue-event gadget (make-instance 'callback-event :callback-function fn :gadget gadget :client client :client-id client-id :other-args other-args))) (defmethod handle-event ((gadget basic-gadget) (event callback-event)) (apply (callback-function event) (event-gadget event) (event-client event) (event-client-id event) (event-other-args event))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/dialog.lisp0000644000175000017500000007420411345155771017147 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2003 by Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. #| Random notes: An accepting-values stream diverts the calls to accept into calling accept-present-default, as described in the spec. The output record produced by accept-present-default, as well as the current value of that query, arguments that were passed to accept, etc. are stored in a query object. The stream stores all the query objects for this invocation of accepting-values. The record created and returned by accept-present-default must be a subclass of updating-output-record. After the initial output records are drawn, invoke-accepting-values blocks accepting commands. The state of the dialog state machine is changed via these commands. The commands currently are: COM-SELECT-QUERY query-id -- calls the method select-query with the corresponding query object and output record object. When select-query returns the "next" field, if any, is selected so the user can move from field to field easily. COM-CHANGE-QUERY query-id value -- This command is used to directly change the value of a query field that does not need to be selected first for input. For example, a user would click directly on a radio button without selecting the gadget first. COM-DESELECT-QUERY -- deselects the currently selected query. COM-QUERY-EXIT -- Exits accepting-values COM-QUERY-ABORT -- Aborts accepting-values These commands are generated in two ways. For query fields that are entirely based on CLIM drawing commands and presentations, these are emitted by presentation translators. There is a presentation type selectable-query that throws com-select-query for the :select gesture. Fields that are based on gadgets have to throw presentations from their callbacks. This can be done using the method on p. 305 of the Franz CLIM user guide, or by using the McCLIM function throw-object-ptype. After a command is executed the body of accepting-values is rerun, calling accept-present-default again to update the fields' graphic appearance. [This may be calling these methods too often an may change in the future]. The values returned by the user's calls to accept are come from the query objects. If a query field is selectable than it should implement the method select-query: SELECT-QUERY stream query record -- Make a query field active and do any input. This should change the query object and setf (changedp query). This method might be interrupted at any time if the user selects another field. |# (in-package :clim-internals) (defclass query () ((query-identifier :accessor query-identifier :initarg :query-identifier) (ptype :accessor ptype :initarg :ptype) (view :accessor view :initarg :view) (default :accessor default :initarg :default :initform nil) (default-supplied-p :accessor default-supplied-p :initarg :default-supplied-p :initform nil) (value :accessor value :initarg :value :initform nil) (changedp :accessor changedp :initform nil) (record :accessor record :initarg :record) (activation-gestures :accessor activation-gestures :initform *activation-gestures* :documentation "Binding of *activation-gestures* on entry to this accept") (delimeter-gestures :accessor delimiter-gestures :initform *delimiter-gestures* :documentation "Binding of *delimeter-gestures* on entry to this accept") (accept-arguments :accessor accept-arguments :initarg :accept-arguments) (accept-condition :accessor accept-condition :initarg :accept-condition :initform nil :documentation "Condition signalled, if any, during accept of this query"))) (defclass accepting-values-record (standard-updating-output-record) ()) (defclass accepting-values-stream (standard-encapsulating-stream) ((queries :accessor queries :initform nil) (selected-query :accessor selected-query :initform nil) (align-prompts :accessor align-prompts :initarg :align-prompts :initform nil) (last-pass :accessor last-pass :initform nil :documentation "Flag that indicates the last pass through the body of ACCEPTING-VALUES, after the user has chosen to exit. This controls when conditions will be signalled from calls to ACCEPT."))) (defmethod stream-default-view ((stream accepting-values-stream)) +textual-dialog-view+) (define-condition av-exit (condition) ()) ;;; The accepting-values state machine is controlled by commands. Each ;;; action (e.g., "select a text field") terminates (define-command-table accept-values) ; :inherit-from nil??? (defvar *default-command* '(accepting-values-default-command)) ;;; The fields of the query have presentation type query. Fields that ;;; are "selectable", like the default text editor field, have type ;;; selectable-query. The presentation object is the query ;;; identifier. (define-presentation-type query () :inherit-from t) (define-presentation-type selectable-query () :inherit-from 'query) (define-presentation-type exit-button () :inherit-from t) (define-presentation-type abort-button () :inherit-from t) (defvar *accepting-values-stream* nil) (defmacro with-stream-in-own-window ((&optional (stream '*query-io*) &rest further-streams) (&optional label) &rest body) `(let* ((,stream (open-window-stream :label ,label :input-buffer (climi::frame-event-queue *application-frame*))) ,@(mapcar (lambda (a-stream) (list a-stream stream)) further-streams)) (unwind-protect (progn ,@body) (close ,stream)))) (defmacro accepting-values ((&optional (stream t) &rest args &key own-window exit-boxes initially-select-query-identifier modify-initial-query resynchronize-every-pass resize-frame align-prompts label scroll-bars select-first-query x-position y-position width height command-table frame-class) &body body) (declare (ignorable exit-boxes initially-select-query-identifier modify-initial-query resynchronize-every-pass resize-frame align-prompts scroll-bars select-first-query x-position y-position width height command-table frame-class)) (setq stream (stream-designator-symbol stream '*standard-input*)) (with-gensyms (accepting-values-continuation) (let* ((return-form `(flet ((,accepting-values-continuation (,stream) ,@body)) (invoke-accepting-values ,stream #',accepting-values-continuation ,@args))) (true-form `(with-stream-in-own-window (,stream *standard-input* *standard-output*) (,label) ,return-form))) ;; To avoid unreachable-code warnings, if `own-window' is a ;; boolean constant, don't generate the `if' form. (cond ((eq own-window t) true-form) ((eq own-window nil) return-form) (t `(if ,own-window ,true-form ,return-form)))))) (defun invoke-accepting-values (stream body &key own-window exit-boxes (initially-select-query-identifier nil initially-select-p) select-first-query modify-initial-query resynchronize-every-pass resize-frame align-prompts label scroll-bars x-position y-position width height (command-table 'accept-values) (frame-class 'accept-values)) (declare (ignore own-window exit-boxes modify-initial-query resize-frame label scroll-bars x-position y-position width height frame-class)) (when (and align-prompts ;; t means the same as :right (not (eq align-prompts :left))) (setf align-prompts :right)) (multiple-value-bind (cx cy) (stream-cursor-position stream) (let* ((*accepting-values-stream* (make-instance 'accepting-values-stream :stream stream :align-prompts align-prompts)) (arecord (updating-output (stream :record-type 'accepting-values-record) (if align-prompts (formatting-table (stream) (funcall body *accepting-values-stream*)) (funcall body *accepting-values-stream*)) (display-exit-boxes *application-frame* stream (stream-default-view *accepting-values-stream*)))) (first-time t) (current-command (if initially-select-p `(com-select-query ,initially-select-query-identifier) *default-command*))) (letf (((frame-command-table *application-frame*) (find-command-table command-table))) (unwind-protect (handler-case (loop (if first-time (setq first-time nil) (when resynchronize-every-pass (redisplay arecord stream))) (with-input-context ('(command :command-table accept-values)) (object) (progn (when (and select-first-query (not initially-select-p)) (setf current-command `(com-select-query ,(query-identifier (first (queries *accepting-values-stream*)))) select-first-query nil)) (apply (command-name current-command) (command-arguments current-command)) ;; If current command returns without throwing a ;; command, go back to the default command (setq current-command *default-command*)) (t (setq current-command object))) (redisplay arecord stream)) (av-exit () (finalize-query-records *accepting-values-stream*) (setf (last-pass *accepting-values-stream*) t) (redisplay arecord stream))) (dolist (query (queries *accepting-values-stream*)) (finalize (editing-stream (record query)) nil)) (erase-output-record arecord stream) (setf (stream-cursor-position stream) (values cx cy))))))) (defgeneric display-exit-boxes (frame stream view)) (defmethod display-exit-boxes (frame stream (view textual-dialog-view)) (declare (ignore frame)) (updating-output (stream :unique-id 'buttons :cache-value t) (fresh-line stream) (formatting-table (stream) (formatting-row (stream) (formatting-cell (stream) (with-output-as-presentation (stream nil 'exit-button) (surrounding-output-with-border (stream :shape :rounded :radius 6 :background +gray80+ :highlight-background +gray90+) (format stream "OK")))) (formatting-cell (stream) (with-output-as-presentation (stream nil 'abort-button) (surrounding-output-with-border (stream :shape :rounded :radius 6 :background +gray80+ :highlight-background +gray90+) (format stream "Cancel")))))) (terpri stream))) (defmethod stream-accept ((stream accepting-values-stream) type &rest rest-args &key (view (stream-default-view stream)) (default nil default-supplied-p) default-type provide-default insert-default replace-input history active-p prompt prompt-mode display-default (query-identifier prompt) activation-gestures additional-activation-gestures delimiter-gestures additional-delimiter-gestures) (declare (ignore default-type provide-default insert-default replace-input history active-p prompt-mode display-default activation-gestures additional-activation-gestures delimiter-gestures additional-delimiter-gestures)) (let ((query (find query-identifier (queries stream) :key #'query-identifier :test #'equal)) (align (align-prompts stream))) (unless query ;; If there's no default but empty input could return a sensible value, ;; use that as a default. (unless default-supplied-p (setq default (ignore-errors (accept-from-string type "" :view +textual-view+ )))) (setq query (make-instance 'query :query-identifier query-identifier :ptype type :view view :default default :default-supplied-p default-supplied-p :value default)) (setf (queries stream) (nconc (queries stream) (list query))) (when default (setf (changedp query) t))) (setf (accept-arguments query) rest-args) ;; If the program changes the default, that becomes the value. (unless (equal default (default query)) (setf (default query) default) (setf (value query) default)) (flet ((do-prompt () (apply #'prompt-for-accept stream type view rest-args)) (do-accept-present-default () (funcall-presentation-generic-function accept-present-default type (encapsulating-stream-stream stream) view (value query) default-supplied-p nil query-identifier))) (let ((query-record nil)) (if align (formatting-row (stream) (formatting-cell (stream :align-x align :align-y :center) (do-prompt)) (formatting-cell (stream) (setq query-record (do-accept-present-default)))) (progn (do-prompt) (setq query-record (do-accept-present-default)))) (setf (record query) query-record) (when (and (last-pass stream) (accept-condition query)) (signal (accept-condition query))) (multiple-value-prog1 (values (value query) (ptype query) (changedp query)) (setf (default query) default) (setf (ptype query) type) (setf (changedp query) nil)))))) (defmethod prompt-for-accept ((stream accepting-values-stream) type view &rest args) (declare (ignore view)) (apply #'prompt-for-accept-1 stream type :display-default nil args)) (define-command (com-query-exit :command-table accept-values :name nil :provide-output-destination-keyword nil) () (signal 'av-exit)) (define-command (com-query-abort :command-table accept-values :name nil :provide-output-destination-keyword nil) () (and (find-restart 'abort) (invoke-restart 'abort))) (define-command (com-change-query :command-table accept-values :name nil :provide-output-destination-keyword nil) ((query-identifier t) (value t)) (when *accepting-values-stream* (let ((query (find query-identifier (queries *accepting-values-stream*) :key #'query-identifier :test #'equal))) (when query (setf (value query) value) (setf (changedp query) t))))) (defgeneric select-query (stream query record) (:documentation "Does whatever is needed for input (e.g., calls accept) when a query is selected for input. It is responsible for updating the query object when a new value is entered in the query field." )) (defgeneric deselect-query (stream query record) (:documentation "Deselect a query field: turn the cursor off, turn off highlighting, etc." )) (define-command (com-select-query :command-table accept-values :name nil :provide-output-destination-keyword nil) ((query-identifier t)) (when *accepting-values-stream* (with-accessors ((selected-query selected-query)) *accepting-values-stream* (let* ((query-list (member query-identifier (queries *accepting-values-stream*) :key #'query-identifier :test #'equal)) (query (car query-list))) (when selected-query (unless (equal query-identifier (query-identifier selected-query)) (deselect-query *accepting-values-stream* selected-query (record selected-query)))) (when query (setf selected-query query) (select-query *accepting-values-stream* query (record query)) (let ((command-ptype '(command :command-table accept-values))) (if (cdr query-list) (throw-object-ptype `(com-select-query ,(query-identifier (cadr query-list))) command-ptype) (throw-object-ptype '(com-deselect-query) command-ptype)))))))) (define-command (com-deselect-query :command-table accept-values :name nil :provide-output-destination-keyword nil) () (when *accepting-values-stream* (with-accessors ((selected-query selected-query)) *accepting-values-stream* (when selected-query (deselect-query *accepting-values-stream* selected-query (record selected-query)) (setf selected-query nil))))) (defclass av-text-record (standard-updating-output-record) ((editing-stream :accessor editing-stream) (snapshot :accessor snapshot :initarg :snapshot :initform nil :documentation "A copy of the stream buffer before accept is called. Used to determine if any editing has been done by user"))) (defparameter *no-default-cache-value* (cons nil nil)) ;;; Hack until more views / dialog gadgets are defined. (define-default-presentation-method accept-present-default (type stream (view text-field-view) default default-supplied-p present-p query-identifier) (if (width view) (multiple-value-bind (cx cy) (stream-cursor-position stream) (declare (ignore cy)) (letf (((stream-text-margin stream) (+ cx (width view)))) (funcall-presentation-generic-function accept-present-default type stream +textual-dialog-view+ default default-supplied-p present-p query-identifier))))) (define-default-presentation-method accept-present-default (type stream (view textual-dialog-view) default default-supplied-p present-p query-identifier) (declare (ignore present-p)) (let* ((editing-stream nil) (record (updating-output (stream :unique-id query-identifier :cache-value (if default-supplied-p default *no-default-cache-value*) :record-type 'av-text-record) (with-output-as-presentation (stream query-identifier 'selectable-query :single-box t) (surrounding-output-with-border (stream :shape :rounded :radius 3 :background +white+ :foreground +gray40+ :move-cursor t) ;;; FIXME: In this instance we really want borders that ;;; react to the growth of their children. This should ;;; be straightforward unless there is some involvement ;;; of incremental redisplay. ;;; KLUDGE: Arbitrary min-width. (setq editing-stream (make-instance (if *use-goatee* 'goatee-input-editing-stream 'standard-input-editing-stream) :stream stream :cursor-visibility nil :single-line t :min-width (- (bounding-rectangle-max-x stream) (stream-cursor-position stream) 100))))) (when default-supplied-p (input-editing-rescan-loop ;XXX probably not needed editing-stream (lambda (s) (presentation-replace-input s default type view :rescan t))))))) (when editing-stream (setf (editing-stream record) editing-stream)) record)) (defun av-do-accept (query record interactive) (let* ((estream (editing-stream record)) (ptype (ptype query)) (view (view query)) (default (default query)) (default-supplied-p (default-supplied-p query)) (accept-args (accept-arguments query)) (*activation-gestures* (apply #'make-activation-gestures :existing-activation-gestures (activation-gestures query) accept-args)) (*delimiter-gestures* (apply #'make-delimiter-gestures :existing-delimiter-args (delimiter-gestures query) accept-args))) ;; If there was an error on a previous pass, set the insertion pointer to ;; 0 so the user has a chance to edit the field without causing another ;; error. Otherwise the insertion pointer should already be at the end of ;; the input (because it was activated); perhaps we should set it anyway. (when (accept-condition query) (setf (stream-insertion-pointer estream) 0)) (reset-scan-pointer estream) (setf (accept-condition query) nil) ;; If a condition is thrown, then accept should return the old value and ;; ptype. (block accept-condition-handler (setf (changedp query) nil) (setf (values (value query) (ptype query)) (input-editing-rescan-loop estream #'(lambda (s) (handler-bind ((error #'(lambda (c) (format *trace-output* "accepting-values accept condition: ~A~%" c) (if interactive (progn (beep) (setf (stream-insertion-pointer estream) (max 0 (1- (stream-scan-pointer estream)))) (immediate-rescan estream) (format *trace-output* "Ack!~%")) (progn (setf (accept-condition query) c) (return-from accept-condition-handler c)))))) (if default-supplied-p (accept ptype :stream s :view view :prompt nil :default default) (accept ptype :stream s :view view :prompt nil)))))) (setf (changedp query) t)))) ;;; The desired (defmethod select-query (stream query (record av-text-record)) (declare (ignore stream)) (let ((estream (editing-stream record)) (ptype (ptype query)) (view (view query))) (declare (ignore ptype view)) ;for now (with-accessors ((stream-input-buffer stream-input-buffer)) estream (setf (cursor-visibility estream) t) (setf (snapshot record) (copy-seq stream-input-buffer)) (av-do-accept query record t)))) ;;; If the query has not been changed (i.e., ACCEPT didn't return) and there is ;;; no error, act as if the user activated the query. (defmethod deselect-query (stream query (record av-text-record)) (let ((estream (editing-stream record))) (setf (cursor-visibility estream) nil) (when (not (or (changedp query) (accept-condition query))) (finalize-query-record query record)))) (defgeneric finalize-query-record (query record) (:documentation "Do any cleanup on a query before the accepting-values body is run for the last time")) (defmethod finalize-query-record (query record) nil) ;;; If the user edits a text field, selects another text field and ;;; then exits from accepting-values without activating the first ;;; field, the values returned would be some previous value or default ;;; for the field, not what's on the screen. That would be completely ;;; bogus. So, if a field has been edited but not activated, activate ;;; it now. Unfortunately that's a bit hairy. (defmethod finalize-query-record (query (record av-text-record)) (let ((estream (editing-stream record))) (when (and (snapshot record) (not (equal (snapshot record) (stream-input-buffer estream)))) (let* ((activation-gestures (apply #'make-activation-gestures :existing-activation-gestures (activation-gestures query) (accept-arguments query))) (gesture (car activation-gestures))) (when gesture (let ((c (character-gesture-name gesture))) (activate-stream estream c) (reset-scan-pointer estream) (av-do-accept query record nil))))))) (defun finalize-query-records (av-stream) (loop for query in (queries av-stream) do (finalize-query-record query (record query)))) (define-presentation-to-command-translator com-select-field (selectable-query com-select-query accept-values :gesture :select :documentation "Select field for input" :pointer-documentation "Select field for input" :echo nil :tester ((object) (let ((selected (selected-query *accepting-values-stream*))) (or (null selected) (not (eq (query-identifier selected) object)))))) (object) `(,object)) (define-presentation-to-command-translator com-exit-button (exit-button com-query-exit accept-values :gesture :select :documentation "Exit dialog" :pointer-documentation "Exit dialog" :echo nil) () ()) (define-presentation-to-command-translator com-abort-button (abort-button com-query-abort accept-values :gesture :select :documentation "Abort dialog" :pointer-documentation "Abort dialog" :echo nil) () ()) (defun accepting-values-default-command () (loop (read-gesture :stream *accepting-values-stream*))) ;;;; notify-user ;;; See http://openmap.bbn.com/hypermail/clim/0028.html for example usage. ;;; TODO: ;;; - associated-window argument? ;;; - What is the correct return value from notify-user? We currently return ;;; the name of the action given in the :exit-boxes argument. ;;; - Invoke abort restart? Not necessary as it is with accepting-values, ;;; but probably what "Classic CLIM" does. ;;; - What are the default exit boxes? Just "Okay"? Okay and cancel? ;;; - Reimplement using accepting-values, if accepting-values is ever ;;; improved to produce comparable dialogs. ;;; - Should the user really be able to close the window from the WM? (defmethod notify-user (frame message &rest args) (apply #'frame-manager-notify-user (if frame (frame-manager frame) (find-frame-manager)) message :frame frame args)) (define-application-frame generic-notify-user-frame () ((message-string :initarg :message-string) (exit-boxes :initarg :exit-boxes) (title :initarg :title) (style :initarg :style) (text-style :initarg :text-style) (return-value :initarg nil :initform :abort)) (:pane (generate-notify-user-dialog *application-frame*))) (defun generate-notify-user-dialog (frame) (with-slots (message-string exit-boxes text-style) frame (vertically () (spacing (:thickness 6) (make-pane 'label-pane :label (or message-string "I'm speechless.") :text-style text-style)) (spacing (:thickness 4) (make-pane 'hbox-pane :contents (cons '+fill+ (generate-exit-box-buttons exit-boxes))))))) (defun generate-exit-box-buttons (specs) (mapcar (lambda (spec) (destructuring-bind (action string &rest args) spec (spacing (:thickness 2) (apply #'make-pane 'push-button :label string :text-style (make-text-style :sans-serif :roman :small) ; XXX :activate-callback (lambda (gadget) (declare (ignore gadget)) ;; This is fboundp business is weird, and only implied by a ;; random message on the old CLIM list. Does the user function ;; take arguments? (when (or (typep action 'function) (fboundp action)) (funcall action)) (setf (slot-value *application-frame* 'return-value) action) ;; This doesn't work: #+NIL (when (eql action :abort) (and (find-restart 'abort) (invoke-restart 'abort))) (frame-exit *application-frame*)) args)))) specs)) (defmethod frame-manager-notify-user (frame-manager message-string &key frame associated-window (title "") documentation (exit-boxes '((:exit "OK"))) ; The 'name' arg is in the spec but absent from the Lispworks ; manual, and I can't imagine what it would do differently ; than 'title'. name style (text-style (make-text-style :sans-serif :roman :small))) (declare (ignore associated-window documentation)) ;; Keywords from notify-user: ;; associated-window title documentation exit-boxes name style text-style (let ((frame (make-application-frame 'generic-notify-user-frame :calling-frame frame :pretty-name title :message-string message-string :frame-manager frame-manager :exit-boxes exit-boxes :title (or name title) :style style :text-style text-style))) (run-frame-top-level frame) (slot-value frame 'return-value))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/clim-examples.asd0000644000175000017500000000264211345155771020245 0ustar pdmpdm;;; -*- lisp -*- (defpackage :clim-examples.system (:use :cl :asdf)) (in-package :clim-examples.system) ;;; CLIM-Examples depends on having at least one backend loaded. (defsystem :clim-examples :depends-on (:mcclim) :components ((:module "Examples" :components ((:file "calculator") (:file "colorslider") (:file "menutest") ; extra (:file "address-book") (:file "traffic-lights") (:file "clim-fig") (:file "postscript-test") (:file "puzzle") (:file "transformations-test") (:file "demodemo" :depends-on ("tabdemo")) (:file "stream-test") (:file "presentation-test") (:file "dragndrop") (:file "gadget-test") (:file "accepting-values") (:file "method-browser") (:file "stopwatch") (:file "dragndrop-translator") (:file "draggable-graph") (:file "text-size-test") (:file "drawing-benchmark") (:file "logic-cube") (:file "views") (:file "font-selector") (:file "tabdemo") (:file "bordered-output-examples") (:file "misc-tests") (:file "image-viewer"))) (:module "Goatee" :components ((:file "goatee-test"))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/input-editing-drei.lisp0000644000175000017500000001714711345155771021414 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2001 by ;;; Tim Moore (moore@bricoworks.com) ;;; (c) copyright 2006 by ;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Finalize input editing code by defining the stuff that actually ;;; needs a working Drei loaded. (in-package :clim-internals) (defclass empty-input-mixin () () (:documentation "A mixin class used for detecting empty input")) (defclass standard-input-editing-stream (drei:drei-input-editing-mixin empty-input-mixin standard-input-editing-mixin input-editing-stream standard-encapsulating-stream) ((scan-pointer :accessor stream-scan-pointer :initform 0) (rescan-queued :accessor rescan-queued :initform nil)) (:documentation "The instantiable class that implements CLIM's standard input editor. This is the class of stream created by calling `with-input-editing'. Members of this class are mutable.")) (defmethod interactive-stream-p ((stream standard-input-editing-stream)) t) (defmethod stream-accept ((stream standard-input-editing-stream) type &rest args &key (view (stream-default-view stream)) &allow-other-keys) (apply #'prompt-for-accept stream type view args) (apply #'accept-1 stream type args)) ;;; Markers for noise strings in the input buffer. (defclass noise-string-property () ()) (defclass noise-string-start-property (noise-string-property) ()) (defparameter *noise-string* (make-instance 'noise-string-property)) (defparameter *noise-string-start* (make-instance 'noise-string-start-property)) (defgeneric activate-stream (stream gesture) (:documentation "Cause the input editing stream STREAM to be activated with GESTURE")) (defmethod activate-stream ((stream standard-input-editing-stream) gesture) (setf (drei::activation-gesture stream) gesture)) ;;; These helper functions take the arguments of ACCEPT so that they ;;; can be used directly by ACCEPT. (defun make-activation-gestures (&key (activation-gestures nil activation-gestures-p) (additional-activation-gestures nil additional-activations-p) (existing-activation-gestures *activation-gestures*) &allow-other-keys) (cond (additional-activations-p (append additional-activation-gestures existing-activation-gestures)) (activation-gestures-p activation-gestures) (t (or existing-activation-gestures *standard-activation-gestures*)))) (defun make-delimiter-gestures (&key (delimiter-gestures nil delimiter-gestures-p) (additional-delimiter-gestures nil additional-delimiters-p) (existing-delimiter-gestures *delimiter-gestures*) &allow-other-keys) (cond (additional-delimiters-p (append additional-delimiter-gestures existing-delimiter-gestures)) (delimiter-gestures-p delimiter-gestures) (t existing-delimiter-gestures))) (define-condition rescan-condition (condition) ()) (defmethod finalize ((stream drei:drei-input-editing-mixin) input-sensitizer) (call-next-method) (setf (cursor-visibility stream) nil) (let ((real-stream (encapsulating-stream-stream stream)) (record (drei:drei-instance stream))) (cond (input-sensitizer (erase-output-record record real-stream) (funcall input-sensitizer real-stream #'(lambda () (stream-add-output-record real-stream record) (when (stream-drawing-p real-stream) (replay record real-stream))))) ;; We still want to replay it for the cursor visibility ;; change... ((stream-drawing-p real-stream) (replay record real-stream) )) (setf (stream-cursor-position real-stream) (values 0 (bounding-rectangle-max-y (input-editing-stream-output-record stream)))))) ;; XXX: We are supposed to implement input editing for all ;; "interactive streams", but that's not really reasonable. We only ;; care about `clim-stream-pane's, at least for Drei, currently. (defmethod invoke-with-input-editing ((stream clim-stream-pane) continuation input-sensitizer initial-contents class) (let ((editing-stream (make-instance class :stream stream))) (unwind-protect (with-input-editing (editing-stream :input-sensitizer input-sensitizer :initial-contents initial-contents :class class) (input-editing-rescan-loop editing-stream continuation)) (finalize editing-stream input-sensitizer)))) (defmethod immediate-rescan ((stream standard-input-editing-stream)) (unless (stream-rescanning-p stream) (signal 'rescan-condition))) (defmethod queue-rescan ((stream standard-input-editing-stream)) (setf (rescan-queued stream) t)) (defmethod rescan-if-necessary ((stream standard-input-editing-stream) &optional inhibit-activation) ;; FIXME: (declare (ignore inhibit-activation)) (when (rescan-queued stream) (setf (rescan-queued stream) nil) (immediate-rescan stream))) (defmethod input-editing-stream-output-record ((stream standard-input-editing-stream)) (drei:drei-instance stream)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Presentation type history support ;;; ;;; Presentation histories are pretty underspecified, so we have to ;;; rely on internal features and implement input-editor support in ;;; CLIM-INTERNALS (Goatee does the same trick). (defun history-yank-next (stream input-buffer gesture numeric-argument) (declare (ignore input-buffer gesture numeric-argument)) (let* ((accepting-type *active-history-type*) (history (and accepting-type (presentation-type-history accepting-type)))) (when history (multiple-value-bind (object type) (presentation-history-next history accepting-type) (when type (presentation-replace-input stream object type (stream-default-view stream) :allow-other-keys t :accept-result nil)))))) (defun history-yank-previous (stream input-buffer gesture numeric-argument) (declare (ignore input-buffer gesture numeric-argument)) (let* ((accepting-type *active-history-type*) (history (and accepting-type (presentation-type-history accepting-type)))) (when history (multiple-value-bind (object type) (presentation-history-previous history accepting-type) (when type (presentation-replace-input stream object type (stream-default-view stream) :allow-other-keys t :accept-result nil)))))) (add-input-editor-command '((#\n :meta)) 'history-yank-next) (add-input-editor-command '((#\p :meta)) 'history-yank-previous) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/INSTALL0000640000175000017500000001072410561555364016042 0ustar pdmpdmPrerequisites: ============== ASDF - The ASDF system definition facility. Many implementations come with it and (require :asdf) is all that is needed. If yours doesn't, see http://www.cliki.net/asdf. Installing McCLIM using mcclim.asd ================================== To tell ASDF about the wherabouts of McCLIM and to compile it for the first time, perform these steps: 1. Symlink mcclim.asd to a directory in your asdf:*central-registry* list. E.g., for SBCL, that would be: $ ln -sf /path/to/mcclim.asd ~/.sbcl/systems/ 2. If you are using a Lisp implementation that requires a separate CLX to be installed, do this now and symlink the clx's .asd file to your asdf:*central-registry*, as above. If your implementation's CLX doesn't come with a clx.asd file, you will have to load CLX via (require :clx) or a similar mechanism yourself. 3. You need to install the spatial-trees library (available at http://cliki.net/spatial-trees). The preferred method for that is via asdf-install. see http://cliki.net/asdf-install for an introduction to that method. 4. On your Lisp's REPL (with ASDF loaded), type (asdf:oos 'asdf:load-op :mcclim) ; compilation messages should zip past After step 4, McCLIM and the CLX backend should be loaded and you are good to go. When you restart your lisp image, you will need to perform step 4 to load McCLIM again. Installing mcclim.asd if you were using ASDF & system.lisp before ================================================================= Make sure to remove all symlinks in your asdf:*central-registry* to system.lisp and replace them with symlinks to mcclim.asd. Keeping the old links around will break loading the McCLIM system in subtle ways. After replacing the symlinks, follow the "Installing McCLIM..." section above, beginning at step 1 - the symlink mcclim.asd itself is required, too. Writing a system that depends on McCLIM ======================================= In an ASDF system that depends on a loaded CLIM, use the following code to declare a dependency on McCLIM: (defsystem :your-clim-using-system :depends-on (:mcclim #| other dependencies |#) :components (#| components |#) ) The dependency on the McCLIM system will also load a suitable display backend on implementations where it can determine one. Running the demos ================= McCLIM comes with some interesting demo programs and applications: address-book - The classic CLIM demo: (asdf:oos 'asdf:load-op :clim-examples) (in-package :clim-demo) (run-frame-top-level (make-application-frame 'address-book)) The Examples directory includes other demo programs that might be of interest. Many of these are quite old and were written before large parts of the CLIM specification were implemented; for good examples of CLIM style it is best to look elsewhere. clim-listener - a Lisp 'listener' or top-level loop with many goodies for examining directories, CLOS classes, etc. Printed results are mouse-sensitive and in supported implementations (currently OpenMCL) can be used directly as arguments in Lisp expressions: (asdf:oos 'asdf:load-op :clim-listener) (clim-listener:run-listener) functional-geometry - Frank Buss' and Rainer Joswig's functional geometry explorer, implemented on top of clim-listener: (load "Apps/Functional-Geometry/functional-geometry.asd") (asdf:oos 'asdf:load-op :functional-geometry) (functional-geometry::run-functional-geometry) Installation Notes for Implementations ====================================== Notes about bugs or gotchas in specific Common Lisp implementations appear in the release notes found in the ReleaseNotes directory. Franz Allegro Common Lisp ========================= McCLIM has been tested with the ANSI Common Lisp image alisp. It doesn't currently work in with "modern Lisp" but support is on the way. OpenMCL ======= McCLIM has been tested with openmcl-1.0. It is recommended that you download CLX from ftp://clozure.com/pub/CLX. An experimental Cocoa backend for McCLIM, called Beagle, is included in Backends/beagle. CLISP ===== 1. Get clisp-20041218 or newer. Build it with option --with-module=clx/mit-clx. 2. Get a copy of the ASDF package. Compile it: $ clisp -c $ASDF/asdf.lisp 3. Start $ clisp -K full -i $ASDF/asdf.fas and continue as above. CMUCL ===== McCLIM has been tested with version 19.c. SBCL ==== McCLIM has been tested with version 0.9.8 and later. cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Copyright0000644000175000017500000006131407120013650016671 0ustar pdmpdm GNU LIBRARY GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1991 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the library GPL. It is numbered 2 because it goes with version 2 of the ordinary GPL.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Library General Public License, applies to some specially designated Free Software Foundation software, and to any other libraries whose authors decide to use it. You can use it for your libraries, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library, or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link a program with the library, you must provide complete object files to the recipients so that they can relink them with the library, after making changes to the library and recompiling it. And you must show them these terms so they know their rights. Our method of protecting your rights has two steps: (1) copyright the library, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the library. Also, for each distributor's protection, we want to make certain that everyone understands that there is no warranty for this free library. If the library is modified by someone else and passed on, we want its recipients to know that what they have is not the original version, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that companies distributing free software will individually obtain patent licenses, thus in effect transforming the program into proprietary software. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License, which was designed for utility programs. This license, the GNU Library General Public License, applies to certain designated libraries. This license is quite different from the ordinary one; be sure to read it in full, and don't assume that anything in it is the same as in the ordinary license. The reason we have a separate public license for some libraries is that they blur the distinction we usually make between modifying or adding to a program and simply using it. Linking a program with a library, without changing the library, is in some sense simply using the library, and is analogous to running a utility program or application program. However, in a textual and legal sense, the linked executable is a combined work, a derivative of the original library, and the ordinary General Public License treats it as such. Because of this blurred distinction, using the ordinary General Public License for libraries did not effectively promote software sharing, because most developers did not use the libraries. We concluded that weaker conditions might promote sharing better. However, unrestricted linking of non-free programs would deprive the users of those programs of all benefit from the free status of the libraries themselves. This Library General Public License is intended to permit developers of non-free programs to use free libraries, while preserving your freedom as a user of such programs to change the free libraries that are incorporated in them. (We have not seen how to achieve this as regards changes in header files, but we have achieved it as regards changes in the actual functions of the Library.) The hope is that this will lead to faster development of free libraries. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, while the latter only works together with the library. Note that it is possible for a library to be covered by the ordinary General Public License rather than by this special one. GNU LIBRARY GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Library General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also compile or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. c) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. d) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Library General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Libraries If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307 USA. Also add information on how to contact you by electronic and paper mail. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the library `Frob' (a library for tweaking knobs) written by James Random Hacker. , 1 April 1990 Ty Coon, President of Vice That's all there is to it! cl-mcclim-0.9.6.dfsg.cvs20100315.orig/input.lisp0000640000175000017500000004545710741375206017047 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com) ;;; (c) copyright 2002 by Gilbert Baumann ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) ;;; Input Protocol Classes ;; Event queues (defclass standard-event-queue () ((lock :initform (make-lock "event queue") :reader event-queue-lock) (head :initform nil :accessor event-queue-head :documentation "Head pointer of event queue.") (tail :initform nil :accessor event-queue-tail :documentation "Tail pointer of event queue.") (processes :initform (make-condition-variable) :accessor event-queue-processes :documentation "Condition variable for waiting processes") ;; experimental extension for scheduled event insersion (schedule-time :initform nil :accessor event-schedule-time :documentation "The next time an event should be scheduled.") (schedule :initform nil ;; :accessor event-queue-schedule ;; this accessor conflicts with the method below. ;; noted by mikemac. I recommend renaming the slot. ;; --GB 2002-11-10 :documentation "Time ordered queue of events to schedule."))) (defclass port-event-queue (standard-event-queue) ((port :initform nil :initarg :port :accessor event-queue-port :documentation "The port which will be generating events for the queue."))) (defmethod event-queue-read-no-hang/locked ((eq standard-event-queue)) (check-schedule eq) (let ((res (pop (event-queue-head eq)))) (when (null (event-queue-head eq)) (setf (event-queue-tail eq) nil)) res)) (defmethod event-queue-read-no-hang ((eq standard-event-queue)) "Reads one event from the queue, if there is no event just return NIL." (with-lock-held ((event-queue-lock eq)) (event-queue-read-no-hang/locked eq))) (defmethod event-queue-read ((eq standard-event-queue)) "Reads one event from the queue, if there is no event, hang until here is one." (let ((lock (event-queue-lock eq))) (with-lock-held (lock) (loop (check-schedule eq) (let ((res (event-queue-read-no-hang/locked eq))) (when res (return res)) ;; is there an event waiting to be scheduled? (with-slots (schedule-time) eq (let* ((now (now)) (timeout (when schedule-time (- schedule-time now)))) (condition-wait (event-queue-processes eq) lock timeout)))))))) ;;; XXX Should we do something with the wait function? I suspect that ;;; it's not compatible with the brave new world of native threads. (defmethod event-queue-read-with-timeout ((eq standard-event-queue) timeout wait-function) (let ((lock (event-queue-lock eq))) (with-lock-held (lock) (loop (check-schedule eq) (let ((res (event-queue-read-no-hang/locked eq))) (when res (return res)) (when wait-function (warn "event-queue-read-with-timeout ignoring predicate")) (unless (condition-wait (event-queue-processes eq) lock timeout) (return))))))) (defmethod event-queue-append ((eq standard-event-queue) item) "Append the item at the end of the queue. Does event compression." (with-lock-held ((event-queue-lock eq)) (labels ((append-event () (cond ((null (event-queue-tail eq)) (setf (event-queue-head eq) (cons item nil) (event-queue-tail eq) (event-queue-head eq))) (t (setf (event-queue-tail eq) (setf (cdr (event-queue-tail eq)) (cons item nil)))))) (event-delete-if (predicate) (when (not (null (event-queue-head eq))) (setf (event-queue-head eq) (delete-if predicate (event-queue-head eq)) (event-queue-tail eq) (last (event-queue-head eq)))))) (cond ;; Motion Event Compression ;; ;; . find the (at most one) motion event ;; . delete it ;; . append item to queue ;; ;; But leave enter/exit events. ;; ((and (typep item 'pointer-motion-event) (not (typep item 'pointer-boundary-event))) (let ((sheet (event-sheet item))) (event-delete-if #'(lambda (x) (and (typep x 'pointer-motion-event) (not (typep x 'pointer-boundary-event)) (eq (event-sheet x) sheet)))) (append-event))) ;; ;; Resize event compression ;; ((typep item 'window-configuration-event) (when (typep (event-sheet item) 'top-level-sheet-pane) (let ((sheet (event-sheet item))) (event-delete-if #'(lambda (ev) (and (typep ev 'window-configuration-event) (eq (event-sheet ev) sheet))))) (append-event))) ;; ;; Repaint event compression ;; ((typep item 'window-repaint-event) (let ((region (window-event-native-region item)) (sheet (event-sheet item)) (did-something-p nil)) (labels ((fun (xs) (cond ((null xs) ;; We reached the queue's tail: Append the new event, construct a new ;; one if necessary. (when did-something-p (setf item (make-instance 'window-repaint-event :timestamp (event-timestamp item) :sheet (event-sheet item) :region region))) (setf (event-queue-tail eq) (cons item nil)) ) ;; ((and (typep (car xs) 'window-repaint-event) (eq (event-sheet (car xs)) sheet)) ;; This is a repaint event for the same sheet, delete it and combine ;; its region into the new event. (setf region (region-union region (window-event-native-region (car xs)))) ;; Here is an alternative, which just takes the bounding rectangle. ;; NOTE: When doing this also take care that the new region really ;; is cleared. ;; (setf region ;; (let ((old-region (window-event-native-region (car xs)))) ;; (make-rectangle* ;; (min (bounding-rectangle-min-x region) ;; (bounding-rectangle-min-x old-region)) ;; (min (bounding-rectangle-min-y region) ;; (bounding-rectangle-min-y old-region)) ;; (max (bounding-rectangle-max-x region) ;; (bounding-rectangle-max-x old-region)) ;; (max (bounding-rectangle-max-y region) ;; (bounding-rectangle-max-y old-region))))) (setf did-something-p t) (fun (cdr xs))) ;; (t (setf (cdr xs) (fun (cdr xs))) xs)))) (setf (event-queue-head eq) (fun (event-queue-head eq)))))) ;; Regular events are just appended: (t (append-event)))) (condition-notify (event-queue-processes eq)))) (defmethod event-queue-prepend ((eq standard-event-queue) item) "Prepend the item to the beginning of the queue." (with-lock-held ((event-queue-lock eq)) (cond ((null (event-queue-tail eq)) (setf (event-queue-head eq) (cons item nil) (event-queue-tail eq) (event-queue-head eq))) (t (push item (event-queue-head eq)))) (condition-notify (event-queue-processes eq)))) (defmethod event-queue-peek ((eq standard-event-queue)) (with-lock-held ((event-queue-lock eq)) (check-schedule eq) (first (event-queue-head eq)))) (defmethod event-queue-peek-if (predicate (eq standard-event-queue)) "Goes thru the whole event queue and returns the first event, which satisfies 'predicate' and leaves the event in the queue. Returns NIL, if there is no such event." (with-lock-held ((event-queue-lock eq)) (find-if predicate (event-queue-head eq)))) (defmethod event-queue-listen ((eq standard-event-queue)) (check-schedule eq) (not (null (event-queue-head eq)))) (defun now () (/ (get-internal-real-time) internal-time-units-per-second)) (defmethod event-queue-listen-or-wait ((eq standard-event-queue) &key timeout) (check-schedule eq) (let ((lock (event-queue-lock eq))) (with-lock-held (lock) (with-slots (schedule-time) eq (flet ((pred () (not (null (event-queue-head eq))))) (cond (timeout (loop as timeout-time = (+ now timeout) with now = (now) do (when (pred) (return t)) do (when (>= now timeout-time) (return nil)) do (let ((timeout (if schedule-time (min (- schedule-time now) (- timeout-time now)) (- timeout-time now)))) (condition-wait (event-queue-processes eq) lock timeout)) do (check-schedule eq))) (schedule-time (loop do (when (pred) (return t)) do (condition-wait (event-queue-processes eq) lock (- schedule-time (now))) do (check-schedule eq))) (t (or (pred) (progn (condition-wait (event-queue-processes eq) lock) t))))))))) (defmethod check-schedule ((eq standard-event-queue)) ; see if it's time to inject a scheduled event into the queue. (with-slots (schedule-time schedule) eq (when (and schedule-time (> (now) schedule-time)) (let* ((event (pop schedule)) (sheet (pop schedule))) (setf schedule-time (pop schedule)) (dispatch-event sheet event)) t))) ; ugh. FIXME when I work - build a priority queue or something (defmethod schedule-event-queue ((eq standard-event-queue) sheet event delay) (with-slots (schedule-time schedule) eq (let ((when (+ (now) delay))) (if schedule (cond ((< when schedule-time) (push schedule-time schedule) (push sheet schedule) (push event schedule) (setf schedule-time when)) (t ; (format *trace-output* "queue = ~A~%" schedule) (do* ((prev (cdr schedule) (cdddr prev)) (point (cddr schedule) (cdddr point)) (time (car point))) ((or (null point) (< when time)) (setf (cdr prev) (cons when (cons event (cons sheet (cdr prev))))))))) (progn (setf schedule-time when) (push sheet schedule) (push event schedule)))))) ;; PORT-EVENT-QUEUE methods (defun do-port-force-output (port-event-queue) (let ((port (event-queue-port port-event-queue))) (when port (port-force-output port)))) (defmethod event-queue-read :before ((eq port-event-queue)) (do-port-force-output eq)) (defmethod event-queue-read-no-hang :before ((eq port-event-queue)) (do-port-force-output eq)) (defmethod event-queue-read-with-timeout :before ((eq port-event-queue) timeout wait-function) (declare (ignore timeout wait-function)) (do-port-force-output eq)) (defmethod event-queue-listen :before ((eq port-event-queue)) (do-port-force-output eq)) (defmethod event-queue-listen-or-wait :before ((eq standard-event-queue) &key timeout) (declare (ignore timeout)) (do-port-force-output eq)) (defmethod event-queue-peek :before ((eq port-event-queue)) (do-port-force-output eq)) (defmethod event-queue-peek-if :before (predicate (eq port-event-queue)) (declare (ignore predicate)) (do-port-force-output eq)) ;; STANDARD-SHEET-INPUT-MIXIN (defclass standard-sheet-input-mixin () ((queue :initform (make-instance 'port-event-queue) :reader sheet-event-queue :initarg :input-buffer) (port :initform nil :initarg :port :reader port))) (defmethod stream-input-buffer ((stream standard-sheet-input-mixin)) (sheet-event-queue stream)) (defmethod (setf stream-input-buffer) (new-val (stream standard-sheet-input-mixin)) (setf (slot-value stream 'queue) new-val)) ;(defmethod dispatch-event ((sheet standard-sheet-input-mixin) event) ; (if (typep event 'device-event) ; (queue-event sheet event) ; (handle-event sheet event))) (defmethod dispatch-event ((sheet standard-sheet-input-mixin) event) (queue-event sheet event)) (defmethod queue-event ((sheet standard-sheet-input-mixin) event) (with-slots (queue) sheet (event-queue-append queue event))) (defmethod schedule-event ((sheet standard-sheet-input-mixin) event delay) (with-slots (queue) sheet (schedule-event-queue queue sheet event delay))) (defmethod handle-event ((sheet standard-sheet-input-mixin) event) ;; Standard practice is to ignore events (declare (ignore event)) nil) (defmethod event-read ((sheet standard-sheet-input-mixin)) (with-slots (queue) sheet (event-queue-read queue))) (defmethod event-read-with-timeout ((sheet standard-sheet-input-mixin) &key (timeout nil) (wait-function nil)) ;; This one is not in the spec ;-( --GB (with-slots (queue) sheet (event-queue-read-with-timeout queue timeout wait-function))) (defmethod event-read-no-hang ((sheet standard-sheet-input-mixin)) (with-slots (queue) sheet (event-queue-read-no-hang queue))) (defmethod event-peek ((sheet standard-sheet-input-mixin) &optional event-type) (with-slots (queue) sheet (if event-type (event-queue-peek-if (lambda (x) (typep x event-type)) queue) (event-queue-peek-if (lambda (x) (declare (ignore x)) t) queue)))) (defmethod event-unread ((sheet standard-sheet-input-mixin) event) (with-slots (queue) sheet (event-queue-prepend queue event))) (defmethod event-listen ((sheet standard-sheet-input-mixin)) (with-slots (queue) sheet (event-queue-listen queue))) ;;;; ;;; Support for callers that want to set an event queue for every pane. (defclass no-event-queue-mixin () ()) (defmethod initialize-instance :after ((obj no-event-queue-mixin) &key input-buffer) (declare (ignore input-buffer)) nil) (defmethod (setf stream-input-buffer) (new-val (stream no-event-queue-mixin)) new-val) (defclass immediate-sheet-input-mixin (no-event-queue-mixin) ()) (defmethod dispatch-event ((sheet immediate-sheet-input-mixin) event) (handle-event sheet event)) (defmethod handle-event ((sheet immediate-sheet-input-mixin) event) (declare (ignore event)) nil) (define-condition sheet-is-mute-for-input (error) ()) (defclass sheet-mute-input-mixin (no-event-queue-mixin) ()) (defmethod dispatch-event ((sheet sheet-mute-input-mixin) event) (declare (ignore event)) (error 'sheet-is-mute-for-input)) (defmethod queue-event ((sheet sheet-mute-input-mixin) event) (declare (ignore event)) (error 'sheet-is-mute-for-input)) (defmethod schedule-event ((sheet sheet-mute-input-mixin) event delay) (declare (ignore event delay)) (error 'sheet-is-mute-for-input)) (defmethod handle-event ((sheet sheet-mute-input-mixin) event) (declare (ignore event)) (error 'sheet-is-mute-for-input)) (defmethod event-read ((sheet sheet-mute-input-mixin)) (error 'sheet-is-mute-for-input)) (defmethod event-read-with-timeout ((sheet sheet-mute-input-mixin) &key (timeout nil) (wait-function nil)) (declare (ignore timeout wait-function)) (error 'sheet-is-mute-for-input)) (defmethod event-read-no-hang ((sheet sheet-mute-input-mixin)) (error 'sheet-is-mute-for-input)) (defmethod event-peek ((sheet sheet-mute-input-mixin) &optional event-type) (declare (ignore event-type)) (error 'sheet-is-mute-for-input)) (defmethod event-unread ((sheet sheet-mute-input-mixin) event) (declare (ignore event)) (error 'sheet-is-mute-for-input)) (defmethod event-listen ((sheet sheet-mute-input-mixin)) (error 'sheet-is-mute-for-input)) ;;;; (defclass delegate-sheet-input-mixin () ((delegate :initform nil :initarg :delegate :accessor delegate-sheet-delegate) )) ;;; Don't know if this event queue stuff is completely right, or if it matters ;;; much... (defmethod initialize-instance :after ((obj delegate-sheet-input-mixin) &key input-buffer) (declare (ignore input-buffer))) (defmethod stream-input-buffer ((stream delegate-sheet-input-mixin)) (sheet-event-queue (delegate-sheet-delegate stream))) (defmethod (setf stream-input-buffer) (new-val (stream delegate-sheet-input-mixin)) (setf (stream-input-buffer (delegate-sheet-delegate stream)) new-val)) (defmethod dispatch-event ((sheet delegate-sheet-input-mixin) event) (dispatch-event (delegate-sheet-delegate sheet) event)) (defmethod queue-event ((sheet delegate-sheet-input-mixin) event) (queue-event (delegate-sheet-delegate sheet) event)) (defmethod schedule-event ((sheet delegate-sheet-input-mixin) event delay) (schedule-event (delegate-sheet-delegate sheet) event delay)) (defmethod handle-event ((sheet delegate-sheet-input-mixin) event) (handle-event (delegate-sheet-delegate sheet) event)) (defmethod event-read ((sheet delegate-sheet-input-mixin)) (event-read (delegate-sheet-delegate sheet))) (defmethod event-read-with-timeout ((sheet delegate-sheet-input-mixin) &key (timeout nil) (wait-function nil)) (event-read-with-timeout (delegate-sheet-delegate sheet) :timeout timeout :wait-function wait-function)) (defmethod event-read-no-hang ((sheet delegate-sheet-input-mixin)) (event-read-no-hang (delegate-sheet-delegate sheet))) (defmethod event-peek ((sheet delegate-sheet-input-mixin) &optional event-type) (event-peek (delegate-sheet-delegate sheet) event-type)) (defmethod event-unread ((sheet delegate-sheet-input-mixin) event) (event-unread (delegate-sheet-delegate sheet) event)) (defmethod event-listen ((sheet delegate-sheet-input-mixin)) (event-listen (delegate-sheet-delegate sheet))) ;;; Class actually used by panes. (defclass clim-sheet-input-mixin (standard-sheet-input-mixin) ()) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/README0000600000175000017500000000300010423413274015640 0ustar pdmpdmMcCLIM 0.9.2 "Laetare Sunday" This is McCLIM, an implementation of the "Common Lisp Interface Manager CLIM II Specification." It currently works on X Windows using CLX. It works with CMUCL, SBCL, CLISP, OpenMCL, Allegro CL, LispWorks, and the Scieneer CL. The INSTALL files in this directory give instructions for each Lisp implementation. Release notes for each release of McCLIM are in the ReleaseNotes directory. The other directories of interest are: Doc - the start of a manual Apps - sample applications. This includes: Apps/Debugger - Peter Mechleborg's debugger (similar to SLIME's) Apps/Functional-Geometry - Frank Buss and Rainer Joswig's functional geometry package for drawing "Escher" tiles. Apps/Inspector - Robert Strandh's inspector (similar to SLIME's) Apps/Listener - Andy Hefner's incredibly cool Lisp listener Apps/Scigraph - BBN's graphing package, currently not quite working Examples - Small examples from the Net or written by the McCLIM developers. These are of varying quality and style; many of them date from a time when McCLIM was quite incomplete. In rough order of relevance they are: address-book - the canonical CLIM application clim-fig - a drawing program postscript-test - shows off the CLIM PostScript stream gadget-test - fun with CLIM gadgets calculator - a gadget-based calculator goatee-test - Hacks with Goatee, the Emacs-like editor used in McCLIM Spec - The LaTeX source to the CLIM specification. Please send bug reports and comments to mcclim-devel@common-lisp.netcl-mcclim-0.9.6.dfsg.cvs20100315.orig/menu.lisp0000644000175000017500000004616511345155771016661 0ustar pdmpdm1;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2000 by ;;; Robert Strandh (strandh@labri.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) (defmethod stream-force-output ((pane menu-button-pane)) (with-sheet-medium (medium pane) (medium-force-output medium))) (defmethod menu-root ((button menu-button-pane)) (menu-root (gadget-client button))) (defmethod arm-menu ((button menu-button-pane)) (with-slots (client armed id) button (unless armed (arm-menu client) (mapc #'disarm-menu (menu-children client)) (arm-gadget button t)) (dispatch-repaint button (sheet-region button)))) (defmethod disarm-menu ((button menu-button-pane)) (with-slots (client armed id) button (when armed (disarm-gadget button) (dispatch-repaint button (sheet-region button)) (stream-force-output button)))) (defun menu-draw-highlighted (gadget) (when (sheet-mirror gadget) ;XXX only do this when the gadget is realized. (with-special-choices (gadget) (with-slots (label) gadget (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region gadget) (let ((w (- x2 x1)) (h (- y2 y1))) (draw-rectangle* gadget -1 -1 x2 y2 :ink (gadget-highlighted-color gadget) :filled t) (draw-edges-lines* gadget +white+ 0 0 +black+ (1- w) (1- h)) (draw-label* gadget x1 y1 x2 y2))))))) (defun menu-draw-unhighlighted (gadget) (when (sheet-mirror gadget) ;XXX only do this when the gadget is realized. (with-special-choices (gadget) (with-slots (label) gadget (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region gadget) (let ((w (- x2 x1)) (h (- y2 y1))) (draw-rectangle* gadget -1 -1 w h ;-1 -1 x2 y2 :ink +background-ink+ :filled t) (draw-label* gadget x1 y1 x2 y2))))))) (defmethod handle-event ((pane menu-button-pane) (event pointer-enter-event)) (when (slot-value (slot-value pane 'client) 'armed) (arm-branch pane))) (defmethod handle-event ((pane menu-button-pane) (event pointer-button-press-event)) (arm-branch pane)) (defmethod handle-event ((pane menu-button-pane) (event pointer-ungrab-event)) (destroy-substructure (menu-root pane))) ;;; menu-button-leaf-pane (defclass menu-button-leaf-pane (menu-button-pane) ((command :initform nil :initarg :command))) (defmethod arm-branch ((button menu-button-leaf-pane)) (with-slots (client) button (arm-menu client) (mapc #'destroy-substructure (menu-children client)) (arm-menu button))) (defmethod destroy-substructure ((button menu-button-leaf-pane)) (disarm-gadget button)) (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-button-release-event)) (with-slots (armed label client id) pane (when armed (unwind-protect (value-changed-callback pane client id label) (disarm-menu pane) (destroy-substructure (menu-root pane)))))) (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-exit-event)) (disarm-menu pane)) (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-ungrab-event)) (destroy-substructure (menu-root pane))) ;;; menu-button-submenu-pane (defclass menu-button-submenu-pane (menu-button-pane) ((frame-manager :initform nil :initarg :frame-manager) (submenu-frame :initform nil) (bottomp :initform nil :initarg :bottomp) (command-table :initform nil :initarg :command-table))) (defmethod menu-children ((submenu menu-button-submenu-pane)) (with-slots (submenu-frame) submenu (if submenu-frame (sheet-children (first (sheet-children (frame-panes submenu-frame)))) '()))) (defclass submenu-border (border-pane) ()) (defclass submenu-border-pane (raised-pane) () (:default-initargs :border-width 2 :background *3d-normal-color*)) (defun make-menu-buttons (command-table-name client) "Map over the available menu items in the command table with name `command-table-name', taking inherited menu items into account, and create a list of menu buttons." (let ((menu-buttons '())) (map-over-command-table-menu-items #'(lambda (name gesture item) (declare (ignore name gesture)) (push (make-menu-button-from-menu-item item client :command-table command-table-name :vertical t) menu-buttons)) command-table-name) (nreverse menu-buttons))) (defun create-substructure (sub-menu client) (let* ((frame *application-frame*) (manager (frame-manager frame)) (command-table-name (slot-value sub-menu 'command-table)) (items (make-menu-buttons command-table-name client)) (rack (make-pane-1 manager frame 'vrack-pane :background *3d-normal-color* :contents items)) (raised (make-pane-1 manager frame 'submenu-border :contents (list rack)))) (with-slots (bottomp) sub-menu (multiple-value-bind (xmin ymin xmax ymax) (bounding-rectangle* (sheet-region sub-menu)) (multiple-value-bind (x y) (transform-position (sheet-delta-transformation sub-menu nil) (if bottomp xmin xmax) (if bottomp ymax ymin)) (with-slots (frame-manager submenu-frame) sub-menu (setf frame-manager manager submenu-frame (make-menu-frame raised :left x :top y)) (adopt-frame manager submenu-frame) (with-sheet-medium (medium raised) (medium-force-output medium)))))))) (defmethod destroy-substructure ((sub-menu menu-button-submenu-pane)) (with-slots (frame-manager submenu-frame) sub-menu (when submenu-frame (mapc #'destroy-substructure (menu-children sub-menu)) (disown-frame frame-manager submenu-frame) (disarm-gadget sub-menu) (dispatch-repaint sub-menu +everywhere+) (setf submenu-frame nil) ))) (defmethod arm-branch ((sub-menu menu-button-submenu-pane)) (with-slots (client frame-manager submenu-frame) sub-menu (arm-menu client) (if submenu-frame (progn (mapc #'destroy-substructure (menu-children sub-menu)) (mapc #'disarm-menu (menu-children sub-menu))) (progn (mapc #'destroy-substructure (menu-children client)) (create-substructure sub-menu sub-menu))) (arm-menu sub-menu))) (defmethod handle-event ((pane menu-button-submenu-pane) (event pointer-button-release-event)) (destroy-substructure (menu-root pane))) ;;; menu-button-vertical-submenu-pane (defclass menu-button-vertical-submenu-pane (menu-button-submenu-pane) ()) (let* ((left-padding 10) (widget-size 5) (right-padding 4) (widget-width widget-size) (widget-height (* 2 widget-size)) (total-width (+ left-padding widget-width right-padding)) (total-height widget-height)) (defmethod compose-space ((gadget menu-button-vertical-submenu-pane) &key width height) (declare (ignorable width height)) (multiple-value-bind (width min-width max-width height min-height max-height) (space-requirement-components (call-next-method)) (declare (ignorable max-width)) (make-space-requirement :min-width (+ min-width total-width) :width (+ width total-width) :max-width +fill+ :min-height (max min-height total-height) :height (max height total-height) :max-height (if (zerop max-height) ; make-space-requirements default maximums are zero.. 0 (max max-height total-height))))) (defmethod handle-repaint ((pane menu-button-vertical-submenu-pane) region) (call-next-method) (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* (sheet-region pane)) (when (and (> (- x2 x1) total-width) (> (- y2 y1) total-height)) (let* ((center (/ (+ y1 y2) 2)) (vbase (- center (/ widget-height 2))) (hbase (+ (- x2 total-width) left-padding)) (shape (list hbase vbase (+ hbase widget-size) (+ vbase widget-size) hbase (+ vbase (* 2 widget-size))))) (draw-polygon* pane shape :ink +black+)))))) ;;; menu-divider-leaf-pane (defclass menu-divider-leaf-pane (standard-gadget) ((label :initform nil :initarg :label))) (defparameter *labelled-divider-text-style* (make-text-style :sans-serif :roman :small)) (defmethod destroy-substructure ((object menu-divider-leaf-pane))) (defmethod arm-menu ((object menu-divider-leaf-pane))) (defmethod disarm-menu ((object menu-divider-leaf-pane))) (defmethod compose-space ((gadget menu-divider-leaf-pane) &key width height) (declare (ignorable width height)) (flet ((make-sr (w h) (make-space-requirement :min-width w :width w :min-height h :height h :max-height h))) (let ((label (slot-value gadget 'label))) (if label (multiple-value-bind (width height fx fy baseline) (text-size gadget label :text-style *labelled-divider-text-style*) (declare (ignore fx fy height baseline)) (make-sr width (+ 0 (text-style-ascent *labelled-divider-text-style* gadget) (text-style-descent *labelled-divider-text-style* gadget)))) (make-sr 0 4))))) (defmethod handle-repaint ((pane menu-divider-leaf-pane) region) (let ((label (slot-value pane 'label))) (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* (sheet-region pane)) (declare (ignore y2)) (if label (multiple-value-bind (width height fx fy baseline) (text-size pane label :text-style *labelled-divider-text-style*) (declare (ignore height fx fy)) (let ((tx0 (+ x1 (/ (- (- x2 x1) width) 2))) (ty0 (+ 1 y1 baseline))) (draw-line* pane tx0 (1+ ty0) (+ tx0 width) (1+ ty0) :ink *3d-dark-color*) (draw-text* pane label tx0 ty0 :text-style *labelled-divider-text-style*))) (progn (draw-line* pane x1 (1+ y1) x2 (1+ y1) :ink *3d-dark-color*) (draw-line* pane x1 (+ 2 y1) x2 (+ 2 y1) :ink *3d-light-color*)))))) ;;; Menu creation from command tables (defparameter *enabled-text-style* (make-text-style :sans-serif :roman :normal)) (defparameter *disabled-text-style* (make-text-style :sans-serif :roman :normal)) (defun make-menu-button-from-menu-item (item client &key (bottomp nil) (vertical nil) command-table (presentation-type 'menu-item)) (declare (ignore command-table)) (let ((name (command-menu-item-name item)) (type (command-menu-item-type item)) (value (command-menu-item-value item)) (frame *application-frame*) (manager (frame-manager *application-frame*))) (case type (:command (let ((command-name (if (consp value) (car value) value))) (if (command-enabled command-name frame) (make-pane-1 manager frame 'menu-button-leaf-pane :label name :text-style *enabled-text-style* :client client :vertical vertical :value-changed-callback #'(lambda (gadget val) (declare (ignore gadget val)) (throw-object-ptype item presentation-type))) (let ((pane (make-pane-1 manager frame 'menu-button-leaf-pane :label name :text-style *disabled-text-style* :client client :vertical vertical :value-changed-callback #'(lambda (gadget val) (declare (ignore gadget val)) nil)))) (deactivate-gadget pane) pane)))) (:function (make-pane-1 manager frame 'menu-button-leaf-pane :label name :text-style *enabled-text-style* :client client :vertical vertical :value-changed-callback #'(lambda (gadget val) (declare (ignore gadget val)) ;; FIXME: the spec requires us to pass a gesture to the ;; function, but value-changed-callback doesn't provide ;; one, so we pass NIL for now. ;; FIXME: We don't have a numeric argument, either. (let ((command (funcall value nil nil))) (throw-object-ptype command 'command))))) (:divider (make-pane-1 manager frame 'menu-divider-leaf-pane :label name :vertical vertical :client client)) (:menu (make-pane-1 manager frame (if vertical 'menu-button-vertical-submenu-pane 'menu-button-submenu-pane) :label name :client client :vertical vertical :frame-manager manager :command-table value :bottomp bottomp)) (otherwise (error "Don't know how to create a menu button for ~W" type))))) ;; ;; MENU-BAR ;; (defclass menu-button-hrack-pane (hrack-pane) ()) (defclass menu-bar (menu-button-hrack-pane permanent-medium-sheet-output-mixin) ((items :initform nil) (armed :initform nil))) (defmethod initialize-instance :after ((pane menu-bar) &rest args &key &allow-other-keys) (declare (ignore args)) (setf (slot-value pane 'items) (copy-list (sheet-children pane))) (loop for child in (menu-children pane) do (setf (gadget-client child) pane))) (defmethod menu-children ((menu-bar menu-bar)) (slot-value menu-bar 'items)) (defmethod menu-root ((object menu-bar)) object) (defmethod destroy-substructure ((object menu-bar)) (loop for child in (menu-children object) do (progn (destroy-substructure child) (dispatch-repaint child (sheet-region child)))) (setf (slot-value object 'armed) nil)) (defmethod arm-menu ((object menu-bar)) (setf (slot-value object 'armed) t)) (defmethod disarm-menu ((object menu-bar)) (setf (slot-value object 'armed) nil)) (defun make-menu-bar (command-table &key width height (max-width +fill+) max-height min-width min-height) (with-slots (menu) (find-command-table command-table) (make-pane-1 *pane-realizer* *application-frame* 'menu-bar :background *3d-normal-color* :width width :height height :max-width max-width :max-height max-height :min-width min-width :min-height min-height :contents (append (loop for item in menu collect (make-menu-button-from-menu-item item nil :bottomp t :vertical nil :command-table command-table)) (list +fill+))))) (defmethod handle-repaint ((pane menu-bar) region) (declare (ignore region)) (with-slots (border-width) pane (multiple-value-call #'draw-bordered-rectangle* pane (bounding-rectangle* (sheet-region pane)) :style :outset :border-width 2))) (defmethod compose-space ((pane menu-bar) &key width height) (declare (ignore width height)) (space-requirement+ (call-next-method) (make-space-requirement :height 4 :max-height 4 :min-height 4))) (defmethod box-layout-mixin/horizontally-allocate-space ((pane menu-bar) real-width real-height) (with-slots (x-spacing) pane (let ((widths (box-layout-mixin/horizontally-allocate-space-aux* pane real-width real-height)) (x 2)) (loop for child in (box-layout-mixin-clients pane) for width in widths do (when (box-client-pane child) (layout-child (box-client-pane child) :expand :expand x 2 width (- real-height 4))) (incf x width) (incf x x-spacing))))) (defmethod display-command-table-menu ((command-table standard-command-table) (stream fundamental-output-stream) &rest args &key max-width max-height n-rows n-columns x-spacing y-spacing initial-spacing row-wise (cell-align-x :left) (cell-align-y :top) (move-cursor t)) (formatting-item-list (stream :max-width max-width :max-height max-height :n-rows n-rows :n-columns n-columns :x-spacing x-spacing :y-spacing y-spacing :initial-spacing initial-spacing :row-wise row-wise :move-cursor move-cursor) (map-over-command-table-menu-items #'(lambda (item-name accelerator item) (declare (ignore accelerator)) (formatting-cell (stream :align-x cell-align-x :align-y cell-align-y) (cond ((eq (command-menu-item-type item) :menu) (with-text-style (stream (make-text-style :serif '(:bold :italic) nil)) (write-string item-name stream) (terpri stream)) (surrounding-output-with-border (stream) (apply #'display-command-table-menu (find-command-table (command-menu-item-value item)) stream args))) ((eq (command-menu-item-type item) :command) (let ((name (command-menu-item-name item))) (with-output-as-presentation (stream (command-menu-item-value item) 'command) (write-string name stream))))))) command-table))) (defmethod display-command-menu (frame (stream fundamental-output-stream) &rest args &key (command-table (frame-command-table frame)) initial-spacing row-wise max-width max-height n-rows n-columns (cell-align-x :left) (cell-align-y :top)) (declare (ignore initial-spacing row-wise max-width max-height n-rows n-columns cell-align-x cell-align-y)) (with-keywords-removed (args (:command-table)) (apply #'display-command-table-menu command-table stream args))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/0000755000175000017500000000000011347763515016525 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/Graphic-Forms/0000750000175000017500000000000011347763412021155 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/Graphic-Forms/graft.lisp0000640000175000017500000000403710577125676023166 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-GRAPHIC-FORMS -*- ;;; (c) 2006-2007 Jack D. Unrue (jdunrue (at) gmail (dot) com) ;;; based on the null backend by: ;;; (c) 2005 Christophe Rhodes (c.rhodes@gold.ac.uk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-graphic-forms) (defclass graphic-forms-graft (graft) ()) (defmethod graft-width ((graft graphic-forms-graft) &key (units :device)) (gfw:with-root-window (window) (let ((size (gfw:size window))) (gfw:with-graphics-context (gc window) (ecase units (:device (gfs:size-width size)) (:millimeters (gfs::get-device-caps (gfs:handle gc) gfs::+horzsize+)) (:inches (floor (gfs:size-width size) (gfs::get-device-caps (gfs:handle gc) gfs::+logpixelsx+))) (:screen-sized 1)))))) (defmethod graft-height ((graft graphic-forms-graft) &key (units :device)) (gfw:with-root-window (window) (let ((size (gfw:size window))) (gfw:with-graphics-context (gc window) (ecase units (:device (gfs:size-height size)) (:millimeters (gfs::get-device-caps (gfs:handle gc) gfs::+vertsize+)) (:inches (floor (gfs:size-height size) (gfs::get-device-caps (gfs:handle gc) gfs::+logpixelsy+))) (:screen-sized 1)))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/Graphic-Forms/port.lisp0000640000175000017500000005010510670666274023042 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-GRAPHIC-FORMS; -*- ;;; (c) 2006 Jack D. Unrue (jdunrue (at) gmail (dot) com) ;;; based on the null backend by: ;;; (c) 2005 Christophe Rhodes (c.rhodes@gold.ac.uk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-graphic-forms) (defclass gf-mirror-mixin () ((sheet :accessor sheet :initarg :sheet :initform nil))) (defclass gfw-top-level (gfw:top-level gf-mirror-mixin) ()) (defclass gfw-panel (gfw:panel gf-mirror-mixin) ()) (defclass gfw-menu (gfw:menu gf-mirror-mixin) ()) (defclass gfw-menu-item (gfw:menu-item gf-mirror-mixin) ()) (defclass gfw-button (gfw:button gf-mirror-mixin) ()) (defclass gfw-scroll-bar (gfw:scrollbar gf-mirror-mixin) ()) (defclass gfw-widget-pane-mixin () ()) (defclass gfw-menu-pane-mixin (gfw-widget-pane-mixin) ((label :accessor label :initarg :label :initform "Mu!") (contents :accessor contents :initarg :contents :initform nil) (command-table :accessor command-table :initarg :command-table :initform nil))) (defclass gfw-menu-bar-pane (basic-pane sheet-multiple-child-mixin gfw-menu-pane-mixin) ()) (defclass gfw-menu-pane (basic-pane sheet-parent-mixin sheet-multiple-child-mixin gfw-menu-pane-mixin) ()) (defclass gfw-menu-item-pane (climi::menu-button-pane sheet-parent-mixin gfw-widget-pane-mixin) ((item :accessor item :initarg :item :initform nil) (callback :initarg :value-changed-callback :accessor callback) (command :accessor command :initarg :command :initform nil))) (defmethod print-object ((object gfw-menu-item-pane) stream) (print-unreadable-object (object stream :identity t :type t) (format stream "~S ~S ~S ~S" :item (item object) :command (command object)))) (defclass sheet-event-dispatcher (gfw:event-dispatcher) ((port :accessor port :initform nil))) (defclass pane-event-dispatcher (gfw:event-dispatcher) ((port :accessor port :initform nil))) (defclass menu-clicked-event (window-event) ((item :accessor event-item :initarg :item :initform nil))) (defmethod print-object ((object menu-clicked-event) stream) (print-unreadable-object (object stream :identity t :type t) (format stream "~S ~S ~S ~S ~S ~S" :timestamp (climi::event-timestamp object) :sheet (event-sheet object) :item (event-item object)))) (defclass gfw-pointer (standard-pointer) ((cursor :accessor pointer-cursor :initform :upper-left) (x :initform 0) (y :initform 0))) (defclass graphic-forms-port (basic-port) ((id) (events :accessor events :initform nil) (pointer :accessor port-pointer :initform (make-instance 'gfw-pointer)))) (defun enqueue (port event) (setf (slot-value event 'climi::timestamp) (gfw:obtain-event-time)) (push event (events port))) (defvar *sheet-dispatcher* (make-instance 'sheet-event-dispatcher)) (defvar *pane-dispatcher* (make-instance 'pane-event-dispatcher)) (defun parse-graphic-forms-server-path (path) path) ;;; FIXME: if :port-type and :server-path-parser aren't CLIM-specified ;;; keywords, they should be altered to be in some mcclim-internal ;;; package instead. (setf (get :graphic-forms :port-type) 'graphic-forms-port) (setf (get :graphic-forms :server-path-parser) 'parse-graphic-forms-server-path) (defun resolve-abstract-pane-name (type) (when (get type 'climi::concrete-pane-class-name) (setf type (get type 'climi::concrete-pane-class-name))) (class-name (or (find-class (intern (concatenate 'string (symbol-name type) "-PANE") :climi) nil) (if (keywordp type) (find-class (intern (symbol-name type) :climi)) (find-class type))))) (defgeneric make-pane-2 (type &rest initargs) (:documentation "Implement this to instantiate specific pane types.") (:method (type &rest initargs) (apply #'make-instance (resolve-abstract-pane-name type) initargs))) ;;; ;;; helper functions ;;; ;;; ;;; port methods ;;; (defmethod initialize-instance :after ((port graphic-forms-port) &rest initargs) (declare (ignore initargs)) (setf (slot-value port 'id) (gensym "GRAPHIC-FORMS-PORT-") (port *sheet-dispatcher*) port (port *pane-dispatcher*) port) ;; FIXME: gtkairo backend comments that it seems bizarre for this to be necessary (push (make-instance 'graphic-forms-frame-manager :port port) (slot-value port 'climi::frame-managers))) (defmethod print-object ((object graphic-forms-port) stream) (print-unreadable-object (object stream :identity t :type t) (format stream "~S ~S" :id (slot-value object 'id)))) ;;; ;;; mirror methods ;;; (defmethod port-set-mirror-region ((port graphic-forms-port) (mirror gfw-top-level) region) (let ((size (gfs:make-size :width (floor (bounding-rectangle-width region)) :height (floor (bounding-rectangle-height region))))) (setf (gfw:size mirror) (gfw::compute-outer-size mirror size)))) (defmethod port-set-mirror-region ((port graphic-forms-port) (mirror gf-mirror-mixin) region) (setf (gfw:size mirror) (gfs:make-size :width (floor (bounding-rectangle-width region)) :height (floor (bounding-rectangle-height region))))) (defmethod port-set-mirror-region ((port graphic-forms-port) (mirror gfw-menu) region) (declare (ignore port mirror region))) (defmethod port-set-mirror-region ((port graphic-forms-port) (mirror gfw-menu-item) region) (declare (ignore port mirror region))) (defmethod port-set-mirror-transformation ((port graphic-forms-port) (mirror gfw-top-level) transformation) ;; FIXME: does McCLIM really need to set position of top-level window's? ()) (defmethod port-set-mirror-transformation ((port graphic-forms-port) (mirror gf-mirror-mixin) transformation) (multiple-value-bind (x y) (transform-position transformation 0 0) (setf (gfw:location mirror) (gfs:make-point :x (floor x) :y (floor y))))) (defmethod port-set-mirror-transformation ((port graphic-forms-port) (mirror gfw-menu) transformation) (declare (ignore port mirror transformation))) (defmethod port-set-mirror-transformation ((port graphic-forms-port) (mirror gfw-menu-item) transformation) (declare (ignore port mirror transformation))) ;;; ;;; sheet methods ;;; (defmethod realize-mirror ((port graphic-forms-port) (sheet climi::top-level-sheet-pane)) #+nil (gfs::debug-format "realizing ~a~%" (class-of sheet)) (let* ((mirror (make-instance 'gfw-top-level :sheet sheet :dispatcher *sheet-dispatcher* :style '(:workspace) :text (frame-pretty-name (pane-frame sheet))))) (let ((menu-bar (make-instance 'gfw-menu :handle (gfs::create-menu)))) (gfw::put-widget (gfw::thread-context) menu-bar) (setf (gfw:menu-bar mirror) menu-bar)) (climi::port-register-mirror (port sheet) sheet mirror) mirror)) (defmethod destroy-mirror ((port graphic-forms-port) (sheet climi::top-level-sheet-pane)) (let ((mirror (climi::port-lookup-mirror port sheet))) (climi::port-unregister-mirror port sheet mirror) (gfs:dispose mirror))) (defmethod realize-mirror ((port graphic-forms-port) (sheet mirrored-sheet-mixin)) (let* ((parent (sheet-mirror (sheet-parent sheet))) (mirror (make-instance 'gfw-panel :sheet sheet :dispatcher *sheet-dispatcher* :style '() ;was: '(:border) :parent parent))) (climi::port-register-mirror (port sheet) sheet mirror) mirror)) (defmethod destroy-mirror ((port graphic-forms-port) (sheet mirrored-sheet-mixin)) (let ((mirror (climi::port-lookup-mirror port sheet))) #| (let ((medium (climi::sheet-medium sheet))) (destroy-medium medium) (setf (climi::%sheet-medium sheet) nil)) |# (climi::port-unregister-mirror port sheet mirror) (gfs:dispose mirror))) (defmethod port-enable-sheet ((port graphic-forms-port) (sheet mirrored-sheet-mixin)) (gfw:show (climi::port-lookup-mirror port sheet) t)) (defmethod port-disable-sheet ((port graphic-forms-port) (sheet mirrored-sheet-mixin)) (gfw:show (climi::port-lookup-mirror port sheet) nil)) (defmethod destroy-port :before ((port graphic-forms-port)) ()) (defmethod port-motion-hints ((port graphic-forms-port) (sheet mirrored-sheet-mixin)) ()) (defmethod (setf port-motion-hints) (value (port graphic-forms-port) (sheet mirrored-sheet-mixin)) value) (defmethod get-next-event ((port graphic-forms-port) &key wait-function (timeout nil)) (declare (ignore wait-function timeout)) ; FIXME (or (pop (events port)) (cffi:with-foreign-object (msg-ptr 'gfs::msg) (let ((gm (gfs::get-message msg-ptr (cffi:null-pointer) 0 0))) (gfw::default-message-filter gm msg-ptr)) (setf (events port) (nreverse (events port))) (pop (events port))))) (defmethod process-next-event :after ((port graphic-forms-port) &key wait-function (timeout nil)) (declare (ignore wait-function timeout)) (render-pending-mediums)) (defmethod make-graft ((port graphic-forms-port) &key (orientation :default) (units :device)) (make-instance 'graphic-forms-graft :port port :mirror (gensym) :orientation orientation :units units)) (defmethod make-medium ((port graphic-forms-port) sheet) #+nil (gfs::debug-format "creating medium for ~a~%" (class-of sheet)) (make-instance 'graphic-forms-medium :port port :sheet sheet)) (defmethod text-style-mapping ((port graphic-forms-port) text-style &optional character-set) ()) (defmethod (setf text-style-mapping) (font-name (port graphic-forms-port) (text-style text-style) &optional character-set) ()) (defmethod port-character-width ((port graphic-forms-port) text-style char) #+nil (gfs::debug-format "port-character-width called: ~a ~c~%" text-style char)) (defmethod port-string-width ((port graphic-forms-port) text-style string &key (start 0) end) #+nil (gfs::debug-format "port-string-width called: ~a ~c~%" text-style string)) (defmethod port-mirror-width ((port graphic-forms-port) (sheet mirrored-sheet-mixin)) #+nil (gfs::debug-format "port-mirror-width called for ~a~%" sheet) (let ((mirror (climi::port-lookup-mirror port sheet))) (gfs:size-width (gfw:size mirror)))) (defmethod port-mirror-height ((port graphic-forms-port) (sheet mirrored-sheet-mixin)) #+nil (gfs::debug-format "port-mirror-height called for ~a~%" sheet) (let ((mirror (climi::port-lookup-mirror port sheet))) (gfs:size-height (gfw:size mirror)))) (defmethod port-mirror-width ((port graphic-forms-port) (sheet graphic-forms-graft)) (graft-width sheet)) (defmethod port-mirror-height ((port graphic-forms-port) (sheet graphic-forms-graft)) (graft-height sheet)) (defmethod graft ((port graphic-forms-port)) (first (climi::port-grafts port))) (defmethod port-allocate-pixmap ((port graphic-forms-port) sheet width height) ()) (defmethod port-deallocate-pixmap ((port graphic-forms-port) pixmap) #+nil (when (climi::port-lookup-mirror port pixmap) (destroy-mirror port pixmap))) (defmethod pointer-position ((pointer gfw-pointer)) (values (slot-value pointer 'x) (slot-value pointer 'y))) (defmethod pointer-button-state ((pointer gfw-pointer)) ()) (defmethod port-modifier-state ((port graphic-forms-port)) ()) (defmethod synthesize-pointer-motion-event ((pointer gfw-pointer)) ()) ;;; Set the keyboard input focus for the port. (defmethod port-frame-keyboard-input-focus ((port graphic-forms-port) frame) ;; fixme (frame-properties frame 'focus)) (defmethod (setf port-frame-keyboard-input-focus) (focus (port graphic-forms-port) frame) (gfw:give-focus (sheet-mirror focus)) (setf (frame-properties frame 'focus) focus)) (defmethod %set-port-keyboard-focus (focus (port graphic-forms-port) &key timestamp) (declare (ignore timestamp)) ()) (defmethod port-force-output ((port graphic-forms-port)) ()) ;; FIXME: What happens when CLIM code calls tracking-pointer recursively? (defmethod port-grab-pointer ((port graphic-forms-port) pointer sheet) ()) (defmethod port-ungrab-pointer ((port graphic-forms-port) pointer sheet) ()) (defmethod set-sheet-pointer-cursor ((port graphic-forms-port) sheet cursor) ()) (defmethod bind-selection ((port graphic-forms-port) window &optional time) ()) (defmethod release-selection ((port graphic-forms-port) &optional time) ()) (defmethod request-selection ((port graphic-forms-port) requestor time) ()) (defmethod get-selection-from-event ((port graphic-forms-port) event) ()) (defmethod send-selection ((port graphic-forms-port) event string) nil) (defmethod compose-space ((pane gfw-menu-bar-pane) &key width height) (declare (ignore width height)) (make-space-requirement :width 0 :height 0)) ;;; ;;; dispatchers and callbacks ;;; (defun debug-menu-callback (disp menu) (declare (ignore disp)) (gfs::debug-format "menu: ~a activated~%" menu)) (defun debug-menu-item-callback (disp item) (declare (ignore disp)) (gfs::debug-format "menu item: ~a invoked~%" item)) (defmethod gfw:event-close ((self sheet-event-dispatcher) mirror) (enqueue (port self) (make-instance 'window-manager-delete-event :sheet (sheet mirror)))) ;; copy&paste from port.lisp|CLX: (defun sheet-desired-ink (sheet) (typecase sheet (sheet-with-medium-mixin (medium-background sheet)) (basic-pane ;; CHECKME [is this sensible?] seems to be (let ((background (pane-background sheet))) (if (typep background 'color) background +white+))) (t +white+))) (defmethod gfw:event-paint ((self sheet-event-dispatcher) mirror gc rect) (let ((sheet (sheet mirror))) (when (and (typep sheet 'sheet-with-medium-mixin) (not (image-of (sheet-medium sheet)))) (let ((c (ink-to-color (sheet-medium sheet) (sheet-desired-ink sheet)))) (setf (gfg:background-color gc) c (gfg:foreground-color gc) c)) (gfg:draw-filled-rectangle gc rect)) (enqueue (port self) (make-instance 'window-repaint-event :sheet sheet :region (translate-rectangle rect))))) (defun generate-configuration-event (mirror pnt size) (make-instance 'window-configuration-event :sheet (sheet mirror) :x (gfs:point-x pnt) :y (gfs:point-y pnt) :width (gfs:size-width size) :height (gfs:size-height size))) (defmethod gfw:event-resize ((self sheet-event-dispatcher) mirror size type) (declare (ignore type)) (setf size (gfw:client-size mirror)) (let ((sheet (sheet mirror))) (if (and sheet (subtypep (class-of sheet) 'sheet-with-medium-mixin)) (let ((medium (climi::sheet-medium sheet))) (when (and medium (image-of medium)) (resize-medium-buffer medium size))))) (enqueue (port self) (generate-configuration-event mirror (gfw:location mirror) size))) (defmethod gfw:event-move ((self sheet-event-dispatcher) mirror pnt) (enqueue (port self) (generate-configuration-event mirror pnt (gfw:client-size mirror)))) (defclass gadget-event (window-event) ()) (defclass button-pressed-event (gadget-event) ()) (defmethod gfw:event-select ((self pane-event-dispatcher) mirror) (enqueue (port self) (typecase mirror (gfw-button (make-instance 'button-pressed-event :sheet (sheet mirror))) (t (make-instance 'menu-clicked-event :sheet (sheet (gfw:owner mirror)) :item (sheet mirror)))))) (defmethod handle-event ((pane push-button) (event button-pressed-event)) (activate-callback pane (gadget-client pane) (gadget-id pane))) (defun translate-button-name (name) (case name (:left-button +pointer-left-button+) (:right-button +pointer-right-button+) (:middle-button +pointer-middle-button+) (t (warn "unknown button name: ~A" name) nil))) (defmethod gfw:event-mouse-move ((self sheet-event-dispatcher) mirror point button) (enqueue (port self) (make-instance 'pointer-motion-event :pointer 0 :sheet (sheet mirror) :x (gfs:point-x point) :y (gfs:point-y point) :button (translate-button-name button) ;; FIXME: ;;; :graft-x ;;; :graft-y :modifier-state 0 ))) (defmethod gfw:event-mouse-down ((self sheet-event-dispatcher) mirror point button) (enqueue (port self) (make-instance 'pointer-button-press-event :pointer 0 :sheet (sheet mirror) :x (gfs:point-x point) :y (gfs:point-y point) :button (translate-button-name button) ;; FIXME: ;;; :graft-x ;;; :graft-y :modifier-state 0 ))) (defmethod gfw:event-mouse-up ((self sheet-event-dispatcher) mirror point button) (enqueue (port self) (make-instance 'pointer-button-release-event :pointer 0 :sheet (sheet mirror) :x (gfs:point-x point) :y (gfs:point-y point) :button (translate-button-name button) ;; FIXME: ;;; :graft-x ;;; :graft-y :modifier-state 0 ))) (defun char-to-sym (char) (case char (#\ :| |) (#\! :!) (#\" :|"|) (#\# :|#|) (#\$ :$) (#\% :%) (#\& :&) (#\' :|'|) (#\( :|(|) (#\) :|)|) (#\* :*) (#\+ :+) (#\, :|,|) (#\- :-) (#\. :|.|) (#\/ :/) (#\0 :|0|) (#\1 :|1|) (#\2 :|2|) (#\3 :|3|) (#\4 :|4|) (#\5 :|5|) (#\6 :|6|) (#\7 :|7|) (#\8 :|8|) (#\9 :|9|) (#\: :|:|) (#\; :|;|) (#\< :<) (#\= :=) (#\> :>) (#\? :?) (#\@ :@) (#\A :A) (#\B :B) (#\C :C) (#\D :D) (#\E :E) (#\F :F) (#\G :G) (#\H :H) (#\I :I) (#\J :J) (#\K :K) (#\L :L) (#\M :M) (#\N :N) (#\O :O) (#\P :P) (#\Q :Q) (#\R :R) (#\S :S) (#\T :T) (#\U :U) (#\V :V) (#\W :W) (#\X :X) (#\Y :Y) (#\Z :Z) (#\[ :[) (#\\ :|\\|) (#\] :]) (#\_ :_) (#\` :|`|) (#\a :|a|) (#\b :|b|) (#\c :|c|) (#\d :|d|) (#\e :|e|) (#\f :|f|) (#\g :|g|) (#\h :|h|) (#\i :|i|) (#\j :|j|) (#\k :|k|) (#\l :|l|) (#\m :|m|) (#\n :|n|) (#\o :|o|) (#\p :|p|) (#\q :|q|) (#\r :|r|) (#\s :|s|) (#\t :|t|) (#\u :|u|) (#\v :|v|) (#\w :|w|) (#\x :|x|) (#\y :|y|) (#\z :|z|) (#\{ :{) (#\| :|\||) (#\} :}) (#\Backspace :BACKSPACE) (#\Tab :TAB) (#\Return :RETURN) (#\Rubout :DELETE))) (defmethod gfw:event-key-down ((self sheet-event-dispatcher) mirror code char) (enqueue (port self) (make-instance 'key-press-event :key-name (char-to-sym char) :key-character char :sheet (sheet mirror) ;; FIXME: :x 0 :y 0 :modifier-state 0 ;;; :graft-x root-x ;;; :graft-y root-y ))) (defmethod gfw:event-key-up ((self sheet-event-dispatcher) mirror code char) (enqueue (port self) (make-instance 'key-release-event :key-name (char-to-sym char) :key-character char :sheet (sheet mirror) ;; FIXME: :x 0 :y 0 :modifier-state 0 ;;; :graft-x root-x ;;; :graft-y root-y ))) ;;; ;;; McCLIM handle-event methods ;;; (defun handle-menu-clicked-event (event) (let ((pane (event-item event))) (if pane (let ((menu-item (item pane))) (if menu-item (if (eql (command-menu-item-type menu-item) :command) (climi::throw-object-ptype menu-item 'menu-item)) (funcall (callback pane) pane nil)))))) (defmethod handle-event ((pane gfw-menu-pane) (event menu-clicked-event)) (handle-menu-clicked-event event)) (defmethod handle-event ((pane gfw-menu-bar-pane) (event menu-clicked-event)) (handle-menu-clicked-event event)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/Graphic-Forms/package.lisp0000640000175000017500000000204210576104761023437 0ustar pdmpdm;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) 2006 David Lichteblau (david@lichteblau.com) ;;; based on the null backend by: ;;; (c) 2005 Christophe Rhodes (c.rhodes@gold.ac.uk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :common-lisp-user) (defpackage :clim-graphic-forms (:use :clim :clim-lisp :clim-backend)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/Graphic-Forms/gadgets.lisp0000640000175000017500000001634110700007657023464 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-GRAPHIC-FORMS; -*- ;;; (c) 2006-2007 Jack D. Unrue (jdunrue (at) gmail (dot) com) ;;; based on the null backend by: ;;; (c) 2005 Christophe Rhodes (c.rhodes@gold.ac.uk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-graphic-forms) ;;; ;;; base widget behaviors ;;; (defmethod activate-gadget ((widget gfw-widget-pane-mixin)) (with-slots (active-p) widget (unless active-p (gfw:enable (sheet-mirror widget) t))) (call-next-method)) (defmethod deactivate-gadget ((widget gfw-widget-pane-mixin)) (with-slots (active-p) widget (unless active-p (gfw:enable (sheet-mirror widget) nil))) (call-next-method)) ;;; ;;; menus ;;; (defun append-menu-items (port menu-pane) (let ((table-name (command-table menu-pane))) (when table-name (let ((table (find-command-table table-name))) (dolist (thing (slot-value table 'climi::menu)) (let* ((sub-table-name (if (eql (command-menu-item-type thing) :menu) (command-table-name thing) nil)) (sub-pane (climi::make-menu-button-from-menu-item thing nil :command-table sub-table-name))) (if (eql (command-menu-item-type thing) :command) (setf (gadget-label sub-pane) (climi::command-menu-item-name thing) (item sub-pane) thing) (if (climi::command-menu-item-name thing) (setf (label sub-pane) (climi::command-menu-item-name thing)))) (setf (sheet-parent sub-pane) menu-pane) (realize-mirror port sub-pane)))))) (dolist (menu-item (contents menu-pane)) (unless (integerp menu-item) (setf (sheet-parent menu-item) menu-pane) (realize-mirror port menu-item)))) (defmethod make-pane-2 ((type (eql 'climi::menu-bar)) &rest initargs) (apply #'make-instance 'gfw-menu-bar-pane initargs)) (defmethod realize-mirror ((port graphic-forms-port) (pane gfw-menu-bar-pane)) (let* ((top-level (sheet-mirror (sheet-parent (sheet-parent pane)))) (mirror (gfw:menu-bar top-level))) (setf (sheet mirror) pane) (climi::port-register-mirror port pane mirror) (append-menu-items port pane) mirror)) (defmethod destroy-mirror ((port graphic-forms-port) (pane gfw-menu-bar-pane)) (let ((mirror (climi::port-lookup-mirror port pane))) (climi::port-unregister-mirror port pane mirror))) (defmethod make-pane-2 ((type (eql 'climi::menu-button-submenu-pane)) &rest initargs) (apply #'make-instance 'gfw-menu-pane initargs)) (defmethod realize-mirror ((port graphic-forms-port) (pane gfw-menu-pane)) (let* ((parent (sheet-mirror (sheet-parent pane))) (mirror (make-instance 'gfw-menu :sheet pane :handle (gfs::create-popup-menu)))) (gfw:append-submenu parent (label pane) mirror nil) (climi::port-register-mirror port pane mirror) (append-menu-items port pane) mirror)) (defmethod destroy-mirror ((port graphic-forms-port) (pane gfw-menu-pane)) (let ((mirror (climi::port-lookup-mirror port pane))) (climi::port-unregister-mirror port pane mirror))) (defmethod make-pane-2 ((type (eql 'climi::menu-button-leaf-pane)) &rest initargs) (apply #'make-instance 'gfw-menu-item-pane initargs)) (defmethod realize-mirror ((port graphic-forms-port) (pane gfw-menu-item-pane)) (let* ((menu (sheet-mirror (sheet-parent pane))) (mirror (gfw:append-item menu (gadget-label pane) *pane-dispatcher* nil nil 'gfw-menu-item))) (setf (sheet mirror) pane) (climi::port-register-mirror port pane mirror) mirror)) (defmethod destroy-mirror ((port graphic-forms-port) (pane gfw-menu-item-pane)) (let ((mirror (climi::port-lookup-mirror port pane))) (climi::port-unregister-mirror port pane mirror))) (defmethod realize-mirror ((port graphic-forms-port) (pane climi::menu-divider-leaf-pane)) (let* ((menu (sheet-mirror (sheet-parent pane))) (mirror (gfw:append-separator menu))) (climi::port-register-mirror port pane mirror) mirror)) (defmethod destroy-mirror ((port graphic-forms-port) (pane climi::menu-divider-leaf-pane)) (let ((mirror (climi::port-lookup-mirror port pane))) (climi::port-unregister-mirror port pane mirror))) ;;; ;;; other gadgets ;;; (defmethod realize-mirror ((port graphic-forms-port) (gadget push-button)) #+nil (gfs::debug-format "realizing ~a~%" gadget) (let* ((parent-mirror (sheet-mirror (sheet-parent gadget))) (mirror (make-instance 'gfw-button :sheet gadget :parent parent-mirror :dispatcher *pane-dispatcher* :style '(:push-button)))) (if (gadget-label gadget) (setf (gfw:text mirror) (gadget-label gadget))) (climi::port-register-mirror port gadget mirror) mirror)) (defmethod realize-mirror ((port graphic-forms-port) (gadget toggle-button)) #+nil (gfs::debug-format "realizing ~a~%" gadget) (let* ((parent-mirror (sheet-mirror (sheet-parent gadget))) (mirror (make-instance 'gfw-button :parent parent-mirror :style '(:check-box)))) (if (gadget-label gadget) (setf (gfw:text mirror) (gadget-label gadget))) (climi::port-register-mirror port gadget mirror) mirror)) (defmethod realize-mirror ((port graphic-forms-port) (gadget scroll-bar)) #+nil (gfs::debug-format "realizing ~a~%" gadget) (let* ((parent-mirror (sheet-mirror (sheet-parent gadget))) (mirror (make-instance 'gfw-scroll-bar :parent parent-mirror :style :vertical))) (climi::port-register-mirror port gadget mirror) mirror)) (defmethod destroy-mirror ((port graphic-forms-port) (gadget value-gadget)) (let ((mirror (climi::port-lookup-mirror port gadget))) (climi::port-unregister-mirror port gadget mirror))) (defmethod destroy-mirror ((port graphic-forms-port) (gadget action-gadget)) (let ((mirror (climi::port-lookup-mirror port gadget))) (climi::port-unregister-mirror port gadget mirror))) ;;; ;;; layout ;;; (defmethod compose-space ((gadget action-gadget) &key width height) (declare (ignore width height)) (let ((mirror (climi::port-lookup-mirror (port gadget) gadget)) (pref-size (gfs:make-size :width 100 :height 100))) (if mirror (setf pref-size (gfw:preferred-size mirror -1 -1)) (progn (setf mirror (make-instance 'gfw:button :parent (sheet-mirror (sheet-parent gadget)) :text (gadget-label gadget))) (setf pref-size (gfw:preferred-size mirror -1 -1)) (gfs:dispose mirror) (setf mirror nil))) (make-space-requirement :width (gfs:size-width pref-size) :height (gfs:size-height pref-size)))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/Graphic-Forms/frame-manager.lisp0000640000175000017500000000305410666604152024551 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-GRAPHIC-FORMS -*- ;;; (c) 2006 Jack D. Unrue (jdunrue (at) gmail (dot) com) ;;; based on the null backend by: ;;; (c) 2005 Christophe Rhodes (c.rhodes@gold.ac.uk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-graphic-forms) (defclass graphic-forms-frame-manager (frame-manager) ()) (defmethod make-pane-1 ((fmgr graphic-forms-frame-manager) (frame application-frame) type &rest initargs) #+nil (gfs::debug-format "make-pane-1 type: ~a initargs: ~a~%" type initargs) (apply #'make-pane-2 type :manager fmgr :frame frame :port (port frame) initargs)) (defmethod adopt-frame :after ((fmgr graphic-forms-frame-manager) (frame application-frame)) ()) (defmethod note-space-requirements-changed :after ((graft graphic-forms-graft) pane) #+nil (gfs::debug-format "space requirements changed: ~a~%" pane)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/Graphic-Forms/utils.lisp0000640000175000017500000000401210700044413023165 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-GRAPHIC-FORMS; -*- ;;; (c) 2006 Jack D. Unrue (jdunrue (at) gmail (dot) com) ;;; based on the null backend by: ;;; (c) 2005 Christophe Rhodes (c.rhodes@gold.ac.uk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-graphic-forms) (defun requirement->size (req) (gfs:make-size :width (floor (space-requirement-width req)) :height (floor (space-requirement-height req)))) (defun translate-rectangle (gfw-rect) (let ((pnt (gfs:location gfw-rect)) (size (gfs:size gfw-rect))) (make-rectangle* (gfs:point-x pnt) (gfs:point-y pnt) (+ (gfs:point-x pnt) (gfs:size-width size)) (+ (gfs:point-y pnt) (gfs:size-height size))))) (declaim (inline coordinates->rectangle)) (defun coordinates->rectangle (left top right bottom) (gfs:create-rectangle :x (floor left) :y (floor top) :width (floor (- right left)) :height (floor (- bottom top)))) (defun coordinates->points (seq) (loop for i from 0 below (length seq) by 2 collect (gfs:make-point :x (floor (elt seq i)) :y (floor (elt seq (+ i 1)))))) (declaim (inline radians->degrees)) (defun radians->degrees (rads) (floor (* rads 180) pi)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/Graphic-Forms/medium.lisp0000640000175000017500000005052610700045446023327 0ustar pdmpdm;; -*- Mode: Lisp; Package: CLIM-GRAPHIC-FORMS -*- ;;; (c) 2006-2007 Jack D. Unrue (jdunrue (at) gmail (dot) com) ;;; based on the null backend by: ;;; (c) 2005 Christophe Rhodes (c.rhodes@gold.ac.uk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-graphic-forms) (defclass graphic-forms-medium (basic-medium) ((font :accessor font-of :initform nil) (image :accessor image-of :initform nil) (port :accessor port-of :initarg :port :initform nil))) (defvar *medium-origin* (gfs:make-point)) (defvar *mediums-to-render* nil) (defun add-medium-to-render (medium) (when (image-of medium) (pushnew medium *mediums-to-render* :test #'eql))) (defun remove-medium-to-render (medium) (setf *mediums-to-render* (remove medium *mediums-to-render*))) (defun render-medium-buffer (medium) (let ((mirror (climi::port-lookup-mirror (port-of medium) (medium-sheet medium)))) (gfw:with-graphics-context (gc mirror) (gfg:draw-image gc (image-of medium) *medium-origin*)))) (defun render-pending-mediums () (loop for medium in *mediums-to-render* do (render-medium-buffer medium)) (setf *mediums-to-render* nil)) (defun ink-to-color (medium ink) (cond ((subtypep (class-of ink) (find-class 'climi::opacity)) (setf ink (medium-foreground medium))) ; see discussion of opacity in design.lisp ((eql ink +foreground-ink+) (setf ink (medium-foreground medium))) ((eql ink +background-ink+) (setf ink (medium-background medium))) ((eql ink +flipping-ink+) (warn "+flipping-ink+ encountered in ink-to-color~%") (setf ink nil))) (if ink (multiple-value-bind (red green blue) (clim:color-rgb ink) (gfg:make-color :red (min (truncate (* red 256)) 255) :green (min (truncate (* green 256)) 255) :blue (min (truncate (* blue 256)) 255))) (gfw:with-graphics-context (gc (target-of medium)) (gfg:background-color gc)))) (defun target-of (medium) (let ((sheet (medium-sheet medium))) (if (climi::pane-double-buffering sheet) (or (image-of medium) (let* ((region (climi::sheet-mirror-region sheet)) (width (floor (bounding-rectangle-max-x region))) (height (floor (bounding-rectangle-max-y region)))) (setf (image-of medium) (make-instance 'gfg:image :size (gfs:make-size width height))))) (sheet-mirror (medium-sheet medium))))) (defun resize-medium-buffer (medium size) (let ((old-image (image-of medium))) (when old-image (if (not (gfs:disposed-p old-image)) (let ((old-size (gfg:size old-image))) (unless (gfs:equal-size-p size old-size) (gfs:dispose old-image) (setf old-image nil))) (setf old-image nil))) (unless old-image (setf (image-of medium) (make-instance 'gfg:image :size size))))) (defun destroy-medium (medium) (remove-medium-to-render medium) (let ((image (image-of medium))) (if (and image (not (gfs:disposed-p image))) (gfs:dispose image))) (let ((font (font-of medium))) (if (and font (not (gfs:disposed-p font))) (gfs:dispose font)) (setf (font-of medium) nil))) (defun normalize-text-data (text) (etypecase text (string text) (character (string text)) (symbol (symbol-name text)))) (defun sync-text-style (medium text-style) (gfw:with-graphics-context (gc (climi::port-lookup-mirror (port-of medium) (medium-sheet medium))) (let* ((old-data (when (font-of medium) (gfg:data-object (font-of medium) gc))) (new-font (text-style-to-font gc text-style old-data))) (when new-font (when old-data (gfs:dispose (font-of medium)) (setf (font-of medium) nil)) (setf (font-of medium) new-font))))) (defun text-style-to-font (gc text-style old-data) (multiple-value-bind (family face size) (text-style-components (merge-text-styles text-style *default-text-style*)) #+nil (gfs::debug-format "family: ~a face: ~a size: ~a~%" family face size) ;; ;; FIXME: what to do about font data char sets? ;; ;; FIXME: externalize these specific choices so that applications can ;; have better control over them ;; (let ((face-name (if (stringp family) family (ecase family ((:fix :fixed) "Lucida Console") (:serif "Times New Roman") (:sans-serif "Arial")))) (pnt-size (case size (:tiny 6) (:very-small 7) (:small 8) (:normal 10) (:large 12) (:very-large 14) (:huge 16) (otherwise 10))) (style nil)) (pushnew (case face ((:bold :bold-italic :bold-oblique :italic-bold :oblique-bold) :bold) (otherwise :normal)) style) (pushnew (case face ((:bold-italic :italic :italic-bold) :italic) (otherwise :normal)) style) (pushnew (case family ((:fix :fixed) :fixed) (otherwise :normal)) style) (if (or (null old-data) (not (eql pnt-size (gfg:font-data-point-size old-data))) (string-not-equal face-name (gfg:font-data-face-name old-data)) (/= (length style) (length (intersection style (gfg:font-data-style old-data))))) (let ((new-data (gfg:make-font-data :face-name face-name :point-size pnt-size :style style))) (make-instance 'gfg:font :gc gc :data new-data)) (make-instance 'gfg:font :gc gc :data old-data))))) (defmethod (setf medium-text-style) :before (text-style (medium graphic-forms-medium)) (sync-text-style medium (merge-text-styles (medium-text-style medium) (medium-default-text-style medium)))) (defmethod (setf medium-line-style) :before (line-style (medium graphic-forms-medium)) ()) (defmethod medium-draw-point* ((medium graphic-forms-medium) x y) (when (target-of medium) (gfw:with-graphics-context (gc (target-of medium)) (let ((color (ink-to-color medium (medium-ink medium)))) (setf (gfg:foreground-color gc) color)) (let ((tr (sheet-native-transformation (medium-sheet medium)))) (climi::with-transformed-position (tr x y) (gfg:draw-point gc (gfs:make-point :x (floor x) :y (floor y)))))) (add-medium-to-render medium))) (defmethod medium-draw-points* ((medium graphic-forms-medium) coord-seq) (when (target-of medium) (gfw:with-graphics-context (gc (target-of medium)) (let ((color (ink-to-color medium (medium-ink medium)))) (setf (gfg:foreground-color gc) color)) (let ((tr (sheet-native-transformation (medium-sheet medium)))) (loop for (x y) on (coerce coord-seq 'list) by #'cddr do (climi::with-transformed-position (tr x y) (gfg:draw-point gc (gfs:make-point :x (floor x) :y (floor y))))))) (add-medium-to-render medium))) (defmethod medium-draw-line* ((medium graphic-forms-medium) x1 y1 x2 y2) (when (target-of medium) (gfw:with-graphics-context (gc (target-of medium)) (let ((color (ink-to-color medium (medium-ink medium)))) (setf (gfg:foreground-color gc) color)) (let ((tr (sheet-native-transformation (medium-sheet medium)))) (climi::with-transformed-position (tr x1 y1) (climi::with-transformed-position (tr x2 y2) (gfg:draw-line gc (gfs:make-point :x (floor x1) :y (floor y1)) (gfs:make-point :x (floor x2) :y (floor y2))))))) (add-medium-to-render medium))) (defmethod medium-draw-lines* ((medium graphic-forms-medium) coord-seq) (when (target-of medium) (gfw:with-graphics-context (gc (target-of medium)) (let ((color (ink-to-color medium (medium-ink medium)))) (setf (gfg:foreground-color gc) color)) (let ((tr (sheet-native-transformation (medium-sheet medium)))) (loop for (x1 y1 x2 y2) on (coerce coord-seq 'list) by #'cddddr do (climi::with-transformed-position (tr x1 y1) (climi::with-transformed-position (tr x2 y2) (gfg:draw-line gc (gfs:make-point :x (floor x1) :y (floor y1)) (gfs:make-point :x (floor x2) :y (floor y2)))))))) (add-medium-to-render medium))) (defmethod medium-draw-polygon* ((medium graphic-forms-medium) coord-seq closed filled) (when (target-of medium) (gfw:with-graphics-context (gc (target-of medium)) (climi::with-transformed-positions ((sheet-native-transformation (medium-sheet medium)) coord-seq) (let ((points-list (coordinates->points coord-seq)) (color (ink-to-color medium (medium-ink medium)))) (if filled (setf (gfg:background-color gc) color)) (setf (gfg:foreground-color gc) color) (when (and closed (not filled)) (push (car (last points-list)) points-list)) (if filled (gfg:draw-filled-polygon gc points-list) (gfg:draw-polygon gc points-list))))) (add-medium-to-render medium))) (defmethod medium-draw-rectangle* ((medium graphic-forms-medium) left top right bottom filled) (when (target-of medium) (gfw:with-graphics-context (gc (target-of medium)) (let ((tr (sheet-native-transformation (medium-sheet medium)))) (climi::with-transformed-position (tr left top) (climi::with-transformed-position (tr right bottom) (let ((rect (coordinates->rectangle left top right bottom)) (color (ink-to-color medium (medium-ink medium)))) (if filled (setf (gfg:background-color gc) color)) (setf (gfg:foreground-color gc) color) (if filled (gfg:draw-filled-rectangle gc rect) (gfg:draw-rectangle gc rect))))))) (add-medium-to-render medium))) (defmethod medium-draw-rectangles* ((medium graphic-forms-medium) position-seq filled) (when (target-of medium) (gfw:with-graphics-context (gc (target-of medium)) (let ((tr (sheet-native-transformation (medium-sheet medium))) (color (ink-to-color medium (medium-ink medium)))) (if filled (setf (gfg:background-color gc) color)) (setf (gfg:foreground-color gc) color) (loop for i below (length position-seq) by 4 do (let ((x1 (floor (elt position-seq (+ i 0)))) (y1 (floor (elt position-seq (+ i 1)))) (x2 (floor (elt position-seq (+ i 2)))) (y2 (floor (elt position-seq (+ i 3))))) (climi::with-transformed-position (tr x1 y1) (climi::with-transformed-position (tr x2 y2) (let ((rect (coordinates->rectangle x1 y1 x2 y2))) (if filled (gfg:draw-filled-rectangle gc rect) (gfg:draw-rectangle gc rect))))))))) (add-medium-to-render medium))) (defun compute-quad-point (center-x height angle) (let* ((opp-len (/ height 2)) (hyp-len (/ opp-len (sin angle))) (adj-len (sqrt (- (expt hyp-len 2) (expt opp-len 2))))) (gfs:make-point :x (floor (+ center-x adj-len)) :y (floor opp-len)))) (defun compute-arc-point (center-x center-y width height radians) (let ((angle (radians->degrees radians))) (multiple-value-bind (count remainder) (floor angle 360) (if (> count 0) (setf angle remainder))) (cond ((= angle 270) (gfs:make-point :x (floor center-x) :y (+ (floor center-y) (floor height 2)))) ((> angle 270) (compute-quad-point center-x height (- angle 270))) ((= angle 180) (gfs:make-point :x (- (floor center-x) (floor width 2)) :y (floor center-y))) ((> angle 180) (compute-quad-point center-x height (- angle 180))) ((= angle 90) (gfs:make-point :x (floor center-x) :y (- (floor center-y) (floor height 2)))) ((> angle 90) (compute-quad-point center-x height(- angle 90))) ((= angle 0) (gfs:make-point :x (+ (floor center-x) (floor width 2)) :y (floor center-y))) (t (compute-quad-point center-x height angle))))) (defmethod medium-draw-ellipse* ((medium graphic-forms-medium) center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy start-angle end-angle filled) (unless (or (= radius-2-dx radius-1-dy 0) (= radius-1-dx radius-2-dy 0)) (error "MEDIUM-DRAW-ELLIPSE* not for non axis-aligned ellipses.")) (when (target-of medium) (gfw:with-graphics-context (gc (target-of medium)) (let ((color (ink-to-color medium (medium-ink medium)))) (if filled (setf (gfg:background-color gc) color)) (setf (gfg:foreground-color gc) color)) (climi::with-transformed-position ((sheet-native-transformation (medium-sheet medium)) center-x center-y) (let* ((width (abs (+ radius-1-dx radius-2-dx))) (height (abs (+ radius-1-dy radius-2-dy))) (min-x (floor (- center-x width))) (min-y (floor (- center-y height))) (max-x (floor (+ center-x width))) (max-y (floor (+ center-y height))) (rect (coordinates->rectangle min-x min-y max-x max-y)) (start-pnt (compute-arc-point center-x center-y width height start-angle)) (end-pnt (compute-arc-point center-x center-y width height end-angle))) (if filled (gfg:draw-filled-pie-wedge gc rect start-pnt end-pnt) (gfg:draw-arc gc rect start-pnt end-pnt))))) (add-medium-to-render medium))) (defmethod medium-draw-circle* ((medium graphic-forms-medium) center-x center-y radius start-angle end-angle filled) (medium-draw-ellipse* medium center-x center-y radius radius radius radius start-angle end-angle filled)) (defmethod text-style-ascent (text-style (medium graphic-forms-medium)) (let ((font (font-of medium))) (if font (gfw:with-graphics-context (gc (target-of medium)) (gfg:ascent (gfg:metrics gc font))) 1))) (defmethod text-style-descent (text-style (medium graphic-forms-medium)) (let ((font (font-of medium))) (if font (gfw:with-graphics-context (gc (target-of medium)) (gfg:descent (gfg:metrics gc font))) 1))) (defmethod text-style-height (text-style (medium graphic-forms-medium)) (let ((font (font-of medium))) (if font (gfw:with-graphics-context (gc (target-of medium)) (gfg:height (gfg:metrics gc font))) 1))) (defmethod text-style-character-width (text-style (medium graphic-forms-medium) char) (let ((font (font-of medium)) (width 1) (text (normalize-text-data char))) (if font (gfw:with-graphics-context (gc (target-of medium)) (setf (gfg:font gc) font) (setf width (gfs:size-width (gfg:text-extent gc text))))) width)) (defmethod text-style-width (text-style (medium graphic-forms-medium)) (let ((font (font-of medium))) (if font (gfw:with-graphics-context (gc (target-of medium)) (gfg:average-char-width (gfg:metrics gc font))) 1))) (defmethod text-size ((medium graphic-forms-medium) string &key text-style (start 0) end) (setf string (normalize-text-data string)) (setf text-style (or text-style (make-text-style nil nil nil))) (setf text-style (merge-text-styles text-style (medium-default-text-style medium))) (sync-text-style medium text-style) (gfw:with-graphics-context (gc (target-of medium)) (let ((font (font-of medium))) (setf (gfg:font gc) font) (let ((metrics (gfg:metrics gc font)) (extent (gfg:text-extent gc (subseq string start (or end (length string)))))) (values (gfs:size-width extent) (gfg:height metrics) (gfs:size-width extent) (gfg:height metrics) (gfg:ascent metrics)))))) (defmethod climi::text-bounding-rectangle* ((medium graphic-forms-medium) string &key text-style (start 0) end) ;; fixme, completely wrong (text-size medium string :text-style text-style :start start :end end)) (defmethod medium-draw-text* ((medium graphic-forms-medium) string x y start end align-x align-y toward-x toward-y transform-glyphs) #+nil (gfs::debug-format "medium-draw-text: ~d, ~d ~s~%" x y string) (when (target-of medium) (sync-text-style medium (merge-text-styles (medium-text-style medium) (medium-default-text-style medium))) (setf string (normalize-text-data string)) (gfw:with-graphics-context (gc (target-of medium)) (let ((font (font-of medium))) (if font (setf (gfg:font gc) font)) (let ((ascent (gfg:ascent (gfg:metrics gc font))) (x (floor x)) (y (floor y))) (gfg:draw-text gc (subseq string start (or end (length string))) (gfs:make-point :x x :y (- y ascent)))))) (add-medium-to-render medium))) (defmethod medium-buffering-output-p ((medium graphic-forms-medium)) t) (defmethod (setf medium-buffering-output-p) (buffer-p (medium graphic-forms-medium)) buffer-p) (defmethod medium-draw-glyph ((medium graphic-forms-medium) element x y align-x align-y toward-x toward-y transform-glyphs) ()) (defmethod medium-finish-output ((medium graphic-forms-medium)) (when (image-of medium) (render-medium-buffer medium))) (defmethod medium-force-output ((medium graphic-forms-medium)) (when (image-of medium) (render-medium-buffer medium))) (defmethod medium-clear-area ((medium graphic-forms-medium) left top right bottom) (when (target-of medium) (let ((rect (coordinates->rectangle left top right bottom)) (color (ink-to-color medium (medium-background medium)))) (gfw:with-graphics-context (gc (target-of medium)) (setf (gfg:background-color gc) color (gfg:foreground-color gc) color) (gfg:draw-filled-rectangle gc rect))) (add-medium-to-render medium))) (defmethod medium-beep ((medium graphic-forms-medium)) ()) (defmethod invoke-with-special-choices (continuation (medium graphic-forms-medium)) (let ((sheet (medium-sheet medium))) (funcall continuation (sheet-medium sheet)))) (defmethod medium-miter-limit ((medium graphic-forms-medium)) 0) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/Graphic-Forms/pixmap.lisp0000640000175000017500000000361410700010522023324 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-GRAPHIC-FORMS; -*- ;;; (c) 2007 Jack D. Unrue (jdunrue (at) gmail (dot) com) ;;; based on the null backend by: ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-graphic-forms) (defclass graphic-forms-pixmap (climi::mirrored-pixmap) ()) (defmethod medium-copy-area ((from-drawable graphic-forms-medium) from-x from-y width height (to-drawable graphic-forms-medium) to-x to-y) ()) (defmethod medium-copy-area ((from-drawable graphic-forms-medium) from-x from-y width height (to-drawable graphic-forms-pixmap) to-x to-y) ()) (defmethod medium-copy-area ((from-drawable graphic-forms-pixmap) from-x from-y width height (to-drawable graphic-forms-medium) to-x to-y) ()) (defmethod medium-copy-area ((from-drawable graphic-forms-pixmap) from-x from-y width height (to-drawable graphic-forms-pixmap) to-x to-y) ()) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/Null/0000700000175000017500000000000011347763412017421 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/Null/graft.lisp0000640000175000017500000000215010705412615021412 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-CLX -*- ;;; (c) copyright 2005 Christophe Rhodes (c.rhodes@gold.ac.uk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-null) (defclass null-graft (graft) ()) (defmethod graft-width ((graft null-graft) &key (units :device)) (declare (ignore units)) nil) (defmethod graft-height ((graft null-graft) &key (units :device)) (declare (ignore units)) nil) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/Null/port.lisp0000640000175000017500000001510410741375211021276 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-NULL; -*- ;;; (c) 2005 Christophe Rhodes (c.rhodes@gold.ac.uk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-null) (defclass null-pointer (standard-pointer) ((cursor :accessor pointer-cursor :initform :upper-left) (x :initform 0) (y :initform 0))) (defclass null-port (basic-port) ((id) (pointer :accessor port-pointer :initform (make-instance 'null-pointer)) (window :initform nil :accessor null-port-window))) (defun parse-null-server-path (path) path) ;;; FIXME: if :port-type and :server-path-parser aren't CLIM-specified ;;; keywords, they should be altered to be in some mcclim-internal ;;; package instead. (setf (get :null :port-type) 'null-port) (setf (get :null :server-path-parser) 'parse-null-server-path) (defmethod initialize-instance :after ((port null-port) &rest initargs) (declare (ignore initargs)) (setf (slot-value port 'id) (gensym "NULL-PORT-")) ;; FIXME: it seems bizarre for this to be necessary (push (make-instance 'null-frame-manager :port port) (slot-value port 'climi::frame-managers))) (defmethod print-object ((object null-port) stream) (print-unreadable-object (object stream :identity t :type t) (format stream "~S ~S" :id (slot-value object 'id)))) (defmethod port-set-mirror-region ((port null-port) mirror mirror-region) ()) (defmethod port-set-mirror-transformation ((port null-port) mirror mirror-transformation) ()) (defmethod realize-mirror ((port null-port) (sheet mirrored-sheet-mixin)) nil) (defmethod destroy-mirror ((port null-port) (sheet mirrored-sheet-mixin)) ()) (defmethod mirror-transformation ((port null-port) mirror) ()) (defmethod port-set-sheet-region ((port null-port) (graft graft) region) ()) ;; these don't exist ;;;(defmethod port-set-sheet-transformation ;;; ((port null-port) (graft graft) transformation) ;;; ()) ;;; ;;;(defmethod port-set-sheet-transformation ;;; ((port null-port) (sheet mirrored-sheet-mixin) transformation) ;;; ()) (defmethod port-set-sheet-region ((port null-port) (sheet mirrored-sheet-mixin) region) (declare (ignore region)) nil) (defmethod port-enable-sheet ((port null-port) (mirror mirrored-sheet-mixin)) nil) (defmethod port-disable-sheet ((port null-port) (mirror mirrored-sheet-mixin)) nil) (defmethod destroy-port :before ((port null-port)) nil) (defmethod port-motion-hints ((port null-port) (mirror mirrored-sheet-mixin)) nil) (defmethod (setf port-motion-hints) (value (port null-port) (sheet mirrored-sheet-mixin)) value) (defmethod get-next-event ((port null-port) &key wait-function (timeout nil)) (declare (ignore wait-function timeout)) nil) (defmethod make-graft ((port null-port) &key (orientation :default) (units :device)) (make-instance 'null-graft :port port :mirror (gensym) :orientation orientation :units units)) (defmethod make-medium ((port null-port) sheet) (make-instance 'null-medium :sheet sheet)) (defmethod text-style-mapping ((port null-port) text-style &optional character-set) (declare (ignore text-style character-set)) nil) (defmethod (setf text-style-mapping) (font-name (port null-port) (text-style text-style) &optional character-set) (declare (ignore font-name text-style character-set)) nil) (defmethod port-character-width ((port null-port) text-style char) (declare (ignore text-style char)) nil) (defmethod port-string-width ((port null-port) text-style string &key (start 0) end) (declare (ignore text-style string start end)) nil) (defmethod port-mirror-width ((port null-port) sheet) (declare (ignore sheet)) nil) (defmethod port-mirror-height ((port null-port) sheet) (declare (ignore sheet)) nil) (defmethod graft ((port null-port)) (first (climi::port-grafts port))) (defmethod port-allocate-pixmap ((port null-port) sheet width height) (declare (ignore sheet width height)) ;; FIXME: this isn't actually good enough; it leads to errors in ;; WITH-OUTPUT-TO-PIXMAP nil) (defmethod port-deallocate-pixmap ((port null-port) pixmap) #+nil (when (port-lookup-mirror port pixmap) (destroy-mirror port pixmap))) (defmethod pointer-position ((pointer null-pointer)) (values (slot-value pointer 'x) (slot-value pointer 'y))) (defmethod pointer-button-state ((pointer null-pointer)) nil) (defmethod port-modifier-state ((port null-port)) nil) (defmethod synthesize-pointer-motion-event ((pointer null-pointer)) nil) (defmethod port-frame-keyboard-input-focus ((port null-port) frame) (frame-properties frame 'focus)) (defmethod (setf port-frame-keyboard-input-focus) (focus (port null-port) frame) (setf (frame-properties frame 'focus) focus)) (defmethod (setf port-keyboard-input-focus) (focus (port null-port)) focus) (defmethod port-keyboard-input-focus ((port null-port)) nil) (defmethod port-force-output ((port null-port)) nil) ;; FIXME: What happens when CLIM code calls tracking-pointer recursively? (defmethod port-grab-pointer ((port null-port) pointer sheet) (declare (ignore pointer sheet)) nil) (defmethod port-ungrab-pointer ((port null-port) pointer sheet) (declare (ignore pointer sheet)) nil) (defmethod distribute-event :around ((port null-port) event) (declare (ignore event)) nil) (defmethod set-sheet-pointer-cursor ((port null-port) sheet cursor) (declare (ignore sheet cursor)) nil) (defmethod bind-selection ((port null-port) window &optional time) (declare (ignore window time)) nil) (defmethod release-selection ((port null-port) &optional time) (declare (ignore time)) nil) (defmethod request-selection ((port null-port) requestor time) (declare (ignore requestor time)) nil) (defmethod get-selection-from-event ((port null-port) event) (declare (ignore event)) nil) (defmethod send-selection ((port null-port) event string) (declare (ignore event string)) nil) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/Null/package.lisp0000600000175000017500000000022310410755677021710 0ustar pdmpdm;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- (in-package :common-lisp-user) (defpackage :clim-null (:use :clim :clim-lisp :clim-backend)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/Null/frame-manager.lisp0000640000175000017500000000361110741375211023014 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-NULL -*- ;;; (c) 2005 Christophe Rhodes (c.rhodes@gold.ac.uk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-null) (defclass null-frame-manager (frame-manager) ()) ;;; FIXME: maybe this or something like it belongs in CLIMI? (defun generic-concrete-pane-class (name) (let* ((concrete-name (get name 'climi::concrete-pane-class-name)) (maybe-name (concatenate 'string (symbol-name name) (symbol-name '#:-pane))) (maybe-symbol (find-symbol maybe-name :climi)) (maybe-class (find-class maybe-symbol nil))) (or maybe-class (find-class concrete-name nil) (find-class (if (keywordp name) (intern (symbol-name name) :climi) name) nil)))) (defmethod make-pane-1 ((fm null-frame-manager) (frame application-frame) type &rest initargs) (apply #'make-instance (generic-concrete-pane-class type) :frame frame :manager fm :port (port frame) initargs)) (defmethod adopt-frame :after ((fm null-frame-manager) (frame application-frame)) ()) (defmethod note-space-requirements-changed :after ((graft null-graft) pane) ()) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/Null/medium.lisp0000640000175000017500000001607010741375211021575 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-NULL -*- ;;; (c) 2005 Christophe Rhodes (c.rhodes@gold.ac.uk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-null) (defclass null-medium (basic-medium) ((buffering-output-p :accessor medium-buffering-output-p))) (defmethod (setf medium-text-style) :before (text-style (medium null-medium)) (declare (ignore text-style)) nil) (defmethod (setf medium-line-style) :before (line-style (medium null-medium)) (declare (ignore line-style)) nil) (defmethod (setf medium-clipping-region) :after (region (medium null-medium)) (declare (ignore region)) nil) (defmethod medium-copy-area ((from-drawable null-medium) from-x from-y width height (to-drawable null-medium) to-x to-y) (declare (ignore from-x from-y width height to-x to-y)) nil) #+nil ; FIXME: PIXMAP class (progn (defmethod medium-copy-area ((from-drawable null-medium) from-x from-y width height (to-drawable pixmap) to-x to-y) (declare (ignore from-x from-y width height to-x to-y)) nil) (defmethod medium-copy-area ((from-drawable pixmap) from-x from-y width height (to-drawable null-medium) to-x to-y) (declare (ignore from-x from-y width height to-x to-y)) nil) (defmethod medium-copy-area ((from-drawable pixmap) from-x from-y width height (to-drawable pixmap) to-x to-y) (declare (ignore from-x from-y width height to-x to-y)) nil)) (defmethod medium-draw-point* ((medium null-medium) x y) (declare (ignore x y)) nil) (defmethod medium-draw-points* ((medium null-medium) coord-seq) (declare (ignore coord-seq)) nil) (defmethod medium-draw-line* ((medium null-medium) x1 y1 x2 y2) (declare (ignore x1 y1 x2 y2)) nil) ;; FIXME: Invert the transformation and apply it here, as the :around ;; methods on transform-coordinates-mixin will cause it to be applied ;; twice, and we need to undo one of those. The ;; transform-coordinates-mixin stuff needs to be eliminated. (defmethod medium-draw-lines* ((medium null-medium) coord-seq) (let ((tr (invert-transformation (medium-transformation medium)))) (declare (ignore tr)) nil)) (defmethod medium-draw-polygon* ((medium null-medium) coord-seq closed filled) (declare (ignore coord-seq closed filled)) nil) (defmethod medium-draw-rectangle* ((medium null-medium) left top right bottom filled) (declare (ignore left top right bottom filled)) nil) (defmethod medium-draw-rectangles* ((medium null-medium) position-seq filled) (declare (ignore position-seq filled)) nil) (defmethod medium-draw-ellipse* ((medium null-medium) center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy start-angle end-angle filled) (declare (ignore center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy start-angle end-angle filled)) nil) (defmethod medium-draw-circle* ((medium null-medium) center-x center-y radius start-angle end-angle filled) (declare (ignore center-x center-y radius start-angle end-angle filled)) nil) (defmethod text-style-ascent (text-style (medium null-medium)) (declare (ignore text-style)) 1) (defmethod text-style-descent (text-style (medium null-medium)) (declare (ignore text-style)) 1) (defmethod text-style-height (text-style (medium null-medium)) (+ (text-style-ascent text-style medium) (text-style-descent text-style medium))) (defmethod text-style-character-width (text-style (medium null-medium) char) (declare (ignore text-style char)) 1) ;;; FIXME: this one is nominally backend-independent (defmethod text-style-width (text-style (medium null-medium)) (text-style-character-width text-style medium #\m)) (defmethod text-size ((medium null-medium) string &key text-style (start 0) end) (setf string (etypecase string (character (string string)) (string string))) (let ((width 0) (height (text-style-height text-style medium)) (x (- (or end (length string)) start)) (y 0) (baseline (text-style-ascent text-style medium))) (do ((pos (position #\Newline string :start start :end end) (position #\Newline string :start (1+ pos) :end end))) ((null pos) (values width height x y baseline)) (let ((start start) (end pos)) (setf x (- end start)) (setf y (+ y (text-style-height text-style medium))) (setf width (max width x)) (setf height (+ height (text-style-height text-style medium))) (setf baseline (+ baseline (text-style-height text-style medium))))))) (defmethod climi::text-bounding-rectangle* ((medium null-medium) string &key text-style (start 0) end) (text-size medium string :text-style text-style :start start :end end)) (defmethod medium-draw-text* ((medium null-medium) string x y start end align-x align-y toward-x toward-y transform-glyphs) (declare (ignore string x y start end align-x align-y toward-x toward-y transform-glyphs)) nil) #+nil (defmethod medium-buffering-output-p ((medium null-medium)) t) #+nil (defmethod (setf medium-buffering-output-p) (buffer-p (medium null-medium)) buffer-p) (defmethod medium-draw-glyph ((medium null-medium) element x y align-x align-y toward-x toward-y transform-glyphs) (declare (ignore element x y align-x align-y toward-x toward-y transform-glyphs)) nil) (defmethod medium-finish-output ((medium null-medium)) nil) (defmethod medium-force-output ((medium null-medium)) nil) (defmethod medium-clear-area ((medium null-medium) left top right bottom) (declare (ignore left top right bottom)) nil) (defmethod medium-beep ((medium null-medium)) nil) (defmethod invoke-with-special-choices (continuation (medium null-medium)) (let ((sheet (medium-sheet medium))) (funcall continuation (sheet-medium sheet)))) (defmethod medium-miter-limit ((medium null-medium)) 0) ;;; FIXME: need these to stop the default method attempting to do ;;; pixmaps, which it appears the null backend doesn't support yet. (defmethod climi::medium-draw-bezier-design* ((medium null-medium) (design climi::bezier-area)) nil) (defmethod climi::medium-draw-bezier-design* ((medium null-medium) (design climi::bezier-union)) nil) (defmethod climi::medium-draw-bezier-design* ((medium null-medium) (design climi::bezier-difference)) nil) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/OpenGL/0000755000175000017500000000000011347763412017645 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/OpenGL/opengl-x-frame-manager.lisp0000644000175000017500000000321607463151562024772 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2001 by Julien Boninfante (boninfan@emi.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :CLIM-INTERNALS) ;;; OPENGL-X-FRAME-MANAGER-MIXIN class (defclass opengl-graphical-system-frame-manager-mixin () () (:documentation "This frame-manager-mixin class store elements relative to the X-Windows system architecture")) (defmethod adopt-frame :after ((fm opengl-graphical-system-frame-manager-mixin) (frame menu-frame)) (let ((display (opengl-port-display (port frame)))) (xlib-gl:XMapWindow display (sheet-direct-mirror (frame-top-level-sheet frame))) (xlib-gl:XFlush display))) (defmethod adopt-frame :after ((fm opengl-graphical-system-frame-manager-mixin) (frame application-frame)) (let ((display (opengl-port-display (port frame)))) (xlib-gl:XMapWindow display (sheet-direct-mirror (frame-top-level-sheet frame))) (xlib-gl:XFlush display))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/OpenGL/opengl-medium.lisp0000644000175000017500000003074010003251076023266 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2001 by Julien Boninfante (boninfan@emi.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :CLIM-INTERNALS) (defclass opengl-medium (basic-medium) ()) ;;; The medium transformation is now handled by the ;;; transform-coordinates-mixin in the McCLIM front end. For OpenGL it ;;; might be better to make it part of the model matrix. --moore #| (defun medium-transform-position (medium x y) (declare (type real x y) (type opengl-medium medium)) (multiple-value-bind (xr yr) (bounding-rectangle* (sheet-region (medium-sheet medium))) (declare (type coordinate xr yr)) (transform-position (medium-device-transformation medium) (- x xr) (- y yr)))) (defun medium-transform-distance (medium dx dy) (declare (type real dx dy)) (transform-distance (medium-device-transformation medium) dx dy)) |# (defmacro with-OpenGL-graphics ((medium) &body body) `(let ((ink (medium-ink ,medium)) (line-style (medium-line-style ,medium)) ;(clipping-region (medium-clipping-region ,medium)) (sheet (medium-sheet ,medium))) (cond ((eq ink +foreground-ink+) (setf ink (medium-foreground ,medium))) ((eq ink +background-ink+) (setf ink (medium-background ,medium))) (t nil)) (with-context (sheet) (multiple-value-bind (red green blue) (color-rgb ink) (declare (type single-float red green blue)) (gl:glColor3f red green blue)) (gl:glLineWidth (coerce (line-style-thickness line-style) 'single-float)) ;(unless (eq clipping-region +everywhere+) ; nil (gl:glLoadIdentity) (progn ,@body)))) (defmacro activate-dash () (let ((dashes (gensym))) `(let ((,dashes (line-style-dashes line-style))) (when ,dashes (if (eq ,dashes t) (gl:glLineStipple 1 3) (gl:glLineStipple 1 3))) ; case of sequence must be implemented (gl:glEnable gl:GL_LINE_STIPPLE)))) (defmacro desactivate-dash () `(gl:glDisable gl:GL_LINE_STIPPLE)) ;; Points (defmacro with-points ((medium) &body body) `(with-OpenGL-graphics (,medium) (gl:glPointSize (coerce (line-style-thickness line-style) 'single-float)) (gl:glBegin gl:GL_POINTS) (progn ,@body) (gl:glEnd))) (defmethod medium-draw-point* ((medium opengl-medium) x y) (declare (type coordinate x y)) (multiple-value-bind (tx ty) (medium-transform-position medium x y) (declare (type coordinate tx ty)) (with-points (medium) (gl:glVertex2d tx ty)))) (defmethod medium-draw-points* ((medium opengl-medium) coord-seq) (declare (type cons coord-seq)) (assert (evenp (length coord-seq))) (with-points (medium) (loop for (x y) on coord-seq by #'cddr do (multiple-value-bind (tx ty) (medium-transform-position medium x y) (declare (type coordinate x y)) (gl:glVertex2d tx ty))))) ;; Lines (defmacro with-lines ((medium) &body body) `(with-OpenGL-graphics (,medium) (activate-dash) (gl:glBegin gl:GL_LINES) (unwind-protect (progn ,@body)) (gl:glEnd) (desactivate-dash))) (defmethod medium-draw-line* ((medium opengl-medium) x1 y1 x2 y2) (declare (type real x1 y1 x2 y2)) (multiple-value-bind (tx1 ty1) (medium-transform-position medium x1 y1) (declare (type coordinate tx1 ty1)) (multiple-value-bind (tx2 ty2) (medium-transform-position medium x2 y2) (declare (type coordinate tx2 ty2)) (with-lines (medium) (gl:glVertex2d tx1 ty1) (gl:glVertex2d tx2 ty2))))) (defmethod medium-draw-lines* ((medium opengl-medium) coord-seq) (declare (type cons coord-seq)) (assert (evenp (length coord-seq))) (with-lines (medium) (loop for (x y) on coord-seq by #'cddr do (multiple-value-bind (tx ty) (medium-transform-position medium x y) (declare (type coordinate tx ty)) (gl:glVertex2d tx ty))))) ;; Polygon and Polyline (defmethod medium-draw-polygon* ((medium opengl-medium) coord-seq closed filled) (declare (type boolean filled closed) (type cons coord-seq)) (assert (evenp (length coord-seq))) (with-OpenGL-graphics (medium) (if filled (progn (gl:glPolygonMode gl:GL_FRONT gl:GL_FILL) (gl:glBegin gl:GL_POLYGON)) (progn (activate-dash) (if closed (progn (gl:glPolygonMode gl:GL_FRONT gl:GL_LINE) (gl:glBegin gl:GL_POLYGON)) (gl:glBegin gl:GL_LINE_STRIP)))) (loop for (x y) on coord-seq by #'cddr do (multiple-value-bind (tx ty) (medium-transform-position medium x y) (declare (type coordinate tx ty)) (gl:glVertex2d tx ty))) (gl:glEnd) (desactivate-dash))) ;; Rectangle (defmethod medium-draw-rectangle* ((medium opengl-medium) x1 y1 x2 y2 filled) (declare (type real x1 y1 x2 y2) (type boolean filled)) (with-OpenGL-graphics (medium) (multiple-value-bind (tx1 ty1) (medium-transform-position medium x1 y1) (declare (type coordinate tx1 ty1)) (multiple-value-bind (tx2 ty2) (medium-transform-position medium x2 y2) (declare (type coordinate tx2 ty2)) (if filled (if (rectilinear-transformation-p (medium-transformation medium)) (progn (when (< tx2 tx1) (rotatef tx1 tx2)) (when (< ty2 ty1) (rotatef ty1 ty2)) (gl:glRectd tx1 ty1 tx2 ty2)) (progn (gl:glBegin gl:GL_QUADS) (gl:glVertex2d tx1 ty1) (gl:glVertex2d tx2 ty1) (gl:glVertex2d tx2 ty2) (gl:glVertex2d tx1 ty2) (gl:glEnd))) (progn (activate-dash) (gl:glBegin gl:GL_LINE_LOOP) (gl:glVertex2d tx1 ty1) (gl:glVertex2d tx2 ty1) (gl:glVertex2d tx2 ty2) (gl:glVertex2d tx1 ty2) (gl:glEnd) (desactivate-dash))))))) ;; Ellipse and Elliptical Arc ; In the ellipse, we find the transformation, tr, which transforms the ; unit circle into the ellipse. ; To draw an ellipse (or part of an ellipse), arc between start-angle ; and end-angle is cut in 100 slices. Then a polygon is drawn with all ; points representing the slices. (defmethod medium-draw-ellipse* ((medium opengl-medium) center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy start-angle end-angle filled) (declare (type real center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy) (type real start-angle end-angle) (type boolean filled)) (with-OpenGL-graphics (medium) (multiple-value-bind (tx ty) (medium-transform-position medium center-x center-y) (declare (type coordinate tx ty)) (multiple-value-bind (dx1 dy1) (medium-transform-distance medium radius-1-dx radius-1-dy) (declare (type coordinate dx1 dy1)) (multiple-value-bind (dx2 dy2) (medium-transform-distance medium radius-2-dx radius-2-dy) (declare (type coordinate dx2 dy2)) (when (= (* dx1 dy2) (* dy1 dx2)) ; vectors radius-1 and radius-2 are colinear (error 'ellipse-not-well-defined)) (gl:glTranslated tx ty 0d0) (let* ((ell (make-ellipse* 0d0 0d0 dx1 dy1 dx2 dy2 :start-angle start-angle :end-angle end-angle)) (tr (slot-value ell 'tr)) (2pi (* 2 pi)) (d-theta (- end-angle start-angle))) (if filled (progn (gl:glPolygonMode gl:GL_FRONT gl:GL_FILL) (gl:glBegin gl:GL_POLYGON) (when (/= (mod d-theta 2pi) 0) ; case of the pie slice (gl:glVertex2d 0d0 0d0))) (progn (activate-dash) (gl:glBegin gl:GL_LINE_STRIP))) (loop with step-angle of-type real = (/ (- end-angle start-angle) 100) for theta from start-angle to end-angle by step-angle do (multiple-value-bind (x y) (transform-position tr (cos theta) (sin theta)) (declare (type coordinate x y)) (gl:glVertex2d x y))) (gl:glEnd) (desactivate-dash))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Methods for text styles (defmethod text-size ((medium opengl-medium) string &key text-style (start 0) end) (declare (type fixnum start)) (let ((port (port medium))) (when (characterp string) (setf string (make-string 1 :initial-element string))) (unless end (setf end (length string))) (unless text-style (setf text-style (medium-text-style medium))) (if (= start end) (values 0 0 0 0 0) (let ((position-newline (position #\newline string :start start))) (if position-newline ; newline inside the string (multiple-value-bind (width ascent descent left right font-ascent direction first-not-done) (port-text-extents port text-style string :start start :end position-newline) (declare (type real width ascent descent) (ignorable left right font-ascent direction first-not-done)) (multiple-value-bind (w h x y baseline) (text-size medium string :text-style text-style :start (1+ position-newline) :end end) (values (max w width) (+ ascent descent h) x (+ ascent descent y) (+ ascent descent baseline)))) ; no newline inside the string (multiple-value-bind (width ascent descent left right font-ascent direction first-not-done) (port-text-extents port text-style string :start start :end end) (declare (type real width ascent descent) (ignorable left right font-ascent direction first-not-done)) (values width (+ ascent descent) width 0 ascent))))))) (defmethod medium-draw-text* ((medium opengl-medium) string x y start end align-x align-y toward-x toward-y transform-glyphs) (declare (ignore toward-x toward-y transform-glyphs) (type real x y) (type fixnum start) (type symbol align-x align-y)) (multiple-value-bind (text-style-list text-style-start) (text-style-list-and-start (port medium) (medium-text-style medium)) (declare (type fixnum text-style-list)) (with-OpenGL-graphics (medium) (when (characterp string) (setq string (make-string 1 :initial-element string))) (unless end (setq end (length string))) (multiple-value-bind (tx ty) (medium-transform-position medium x y) (declare (type coordinate tx ty)) (multiple-value-bind (text-width text-height x y baseline) (text-size medium string :start start :end end) (declare (type real text-width text-height baseline) (ignore x y)) (unless (and (eq align-x :left) (eq align-y :baseline)) (setq tx (- tx (ecase align-x (:left 0) (:center (round text-width 2)) (:right text-width)))) (setq ty (ecase align-y (:top (+ ty baseline)) (:center (+ ty baseline (- (floor text-height 2)))) (:baseline ty) (:bottom (+ ty baseline (- text-height))))))) (let* ((s (subseq string start end)) (tab (map '(simple-array (unsigned-byte 8) (*)) #'(lambda (char) (declare (type standard-char char)) (- (char-code char) text-style-start)) s))) (declare (type string s)) (gl:glRasterPos2d tx ty) (gl:glListBase text-style-list) (gl:glCallLists (length s) gl:GL_UNSIGNED_BYTE (find-array-address tab))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Methods for text styles (defmethod text-style-ascent (text-style (medium opengl-medium)) ; (let ((font (text-style-to-X-font (port medium) text-style))) ; (xlib-gl:font-ascent font)) ; ^--- FIXME - BTS 10) (defmethod text-style-descent (text-style (medium opengl-medium)) ; (let ((font (text-style-to-X-font (port medium) text-style))) ; (xlib-gl:font-descent font)) ; ^-- FIXME - BTS 4) (defmethod text-style-height (text-style (medium opengl-medium)) ; (let ((font (text-style-to-X-font (port medium) text-style))) ; (+ (xlib-gl:font-ascent font) (xlib-gl:font-descent font))) ; ^-- FIXME - BTS 14) (defmethod text-style-character-width (text-style (medium opengl-medium) char) ; (xlib-gl:char-width (text-style-to-X-font (port medium) text-style) (char-code char)) ; ^-- FIXME - BTS 8) (defmethod text-style-width (text-style (medium opengl-medium)) (text-style-character-width text-style medium #\m)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/OpenGL/README0000644000175000017500000000477507350131152020527 0ustar pdmpdm -How to use Free-CLIM with OpenGL backend version 0.1- - Installation - I've installed those bindings for CMUCL, and that needed a few changes in the source code. The version that i've used is not the most recent (i used the 2000-09-18 release), because i did not need the bindings with GLUT library. I think there are not many differences with these bindings for other Common Lisp releases. 1. Get OpenGL/MesaGL bindings You can download it at this address : ftp://ftp.cs.toronto.edu/pub/mann/Software/Lisp/ or find it in the Free-CLIM cvs directory : McCLIM/OpenGL/archives/ 2. Untar the file 3. For CMUCL : Open the "cmucl-interface-defpackage.lisp" file and change the "vector-data-address" by "array-data-address" Open the "gl.lisp" file and add these few lines : (foreign-function glgentextures (INT (POINTER INT)) VOID "glGenTextures") (foreign-function glbindtexture (INT INT) VOID "glBindTexture") (foreign-function glcopyteximage1d (INT INT INT INT INT INT INT) VOID "glCopyTexImage1D") (foreign-function glcopyteximage2d (INT INT INT INT INT INT INT INT) VOID "glCopyTexImage2D") (foreign-function glcopytexsubimage1d (INT INT INT INT INT INT) VOID "glCopyTexSubImage1D") (foreign-function glcopytexsubimage2d (INT INT INT INT INT INT INT INT) VOID "glCopyTexSubImage2D") 4. Compile the bindings, according to the bindings README file. - How to use the backend - This backend is provided for OpenGL working with X Window System. 1. Start Lisp 2. Load the OpenGL bindings file : (load "/defsystem.lisp") (load-gl) (load-xlib) 2. Load the system definition file: (load "system-opengl.lisp") 3. Load the file patch-cmu.lisp (load "patch-cmu.lisp") 4. Load the source code of the system: (operate-on-system :clim :load :load-source-instead-of-binary t) (operate-on-system :clim-opengl :load :load-source-instead-of-binary t) (operate-on-system :clim-examples :load :load-source-instead-of-binary t) 5. Compile and load the system: (operate-on-system :clim :compile) (operate-on-system :clim-opengl :compile) (operate-on-system :clim-examples :compile) 6. Load the compiled system: (operate-on-system :clim :load) (operate-on-system :clim-opengl :load) (operate-on-system :clim-examples :load) - Major thing to do - * Implement the use of the clipping-region for opengl-medium - BUGS - Unfortunaly, there are lots of bugs. They will be resolved little by little in the future. This version could be considered as the beta-test version of the backend. cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/OpenGL/system.lisp0000644000175000017500000000221007475531030022051 0ustar pdmpdm;;; -*- Mode: Lisp; Package: User -*- ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :common-lisp-user) (clim-defsystem (:clim-opengl :depends-on (:clim)) "Backends/OpenGL/opengl-x-frame-manager" "Backends/OpenGL/opengl-frame-manager" "Backends/OpenGL/opengl-x-port-before" "Backends/OpenGL/opengl-port" "Backends/OpenGL/opengl-x-port-after" "Backends/OpenGL/opengl-medium" "Backends/OpenGL/opengl-x-graft" ) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/OpenGL/opengl-x-port-after.lisp0000644000175000017500000011042610016355174024346 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2001 by Julien Boninfante (boninfan@emi.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :CLIM-INTERNALS) ; should be in the port structure... (defparameter *x-visual* nil) ; perhaps not this one (defparameter *opengl-glx-context* nil) (defmethod initialize-instance :after ((port opengl-port) &rest rest) (declare (ignore rest)) (push (make-instance 'opengl-frame-manager :port port) (slot-value port 'frame-managers)) (initialize-signature-count) (initialize-opengl-port port)) (defmethod initialize-opengl-port ((port opengl-port)) (let* ((options (cdr (port-server-path port))) (hostname (getf options :host "")) (screen-id (getf options :screen-id 0))) (clim-ffi:with-c-strings ((host (if (string= hostname "localhost") "" hostname))) (with-slots (display screen root) port (setf display (xlib-gl:XOpenDisplay host) screen (xlib-gl:XScreenOfDisplay display screen-id) root (xlib-gl:XRootWindow display screen-id))) (make-graft port)))) (defmethod destroy-port :before ((port opengl-port)) (let ((display (opengl-port-display port))) (when *opengl-glx-context* (gl:glXMakeCurrent display xlib-gl:None xlib-gl:Null) (xlib-gl:free-xvisualinfo *x-visual*) (gl:glXDestroyContext display *opengl-glx-context*) (setf *opengl-glx-context* nil *x-visual* nil *current-sheet-signature* 0)) (xlib-gl:XCloseDisplay display))) (defmethod bell ((port opengl-port)) (xlib-gl:XBell (opengl-port-display port) 100)) ;; Events (defun event-not-present-p (port) (= (xlib-gl:XPending (opengl-port-display port)) 0)) ; The philosophy is to send the pointer button number, ignoring ; the key masks, and returning the higher button corresponding ; to the mask (defun find-button (mask) (cond ((< mask xlib-gl:Button1MotionMask) 0) ((< mask xlib-gl:Button2MotionMask) 1) ((< mask xlib-gl:Button3MotionMask) 2) ((< mask xlib-gl:Button4MotionMask) 3) ((< mask xlib-gl:Button5MotionMask) 4) (t 5))) ; There is a hierarchy in modifier. BUTTON1MOTIONMASK is just ; above the key modifier. (defmacro key-mod (mask) `(mod ,mask xlib-gl:Button1MotionMask)) (defun find-leaf-sheet-containing-point (frame x y) (loop with last = nil with prev = nil while (setf prev last last (child-containing-position (frame x y))) finally (return last))) ;;; This still needs a lot of work, particularly in the handling of ;;; modifiers. (defun event-to-keysym-and-modifiers (port event) (clim-ffi:with-c-data ((str (array char 16)) (sym (array long 1))) (let* ((num-chars (xlib-gl:XLookupString event str 16 sym (clim-ffi:null-pointer))) (event-char (when (< 0 num-chars) (code-char (clim-ffi:cref str char)))) (event-keysym (clim-xcommon:lookup-keysym (clim-ffi:cref sym long))) (event-type (xlib-gl:xkeyevent-type event))) (clim-xcommon:x-keysym-to-clim-modifiers port (if (eql event-type xlib-gl:keypress) :key-press :key-release) (or event-char event-keysym) event-keysym (xlib-gl:xkeyevent-state event))))) ;;; Relieve some of the tedium of getting values out of events (defmacro with-event-slots ((event-type &rest vars) event-form &body body) (with-gensyms (event-form-var) (let* ((event-name (symbol-name event-type)) (var-forms (mapcar (lambda (var) (let ((accessor-name (format nil "~A-~A" event-name (symbol-name var)))) (multiple-value-bind (accessor status) (find-symbol accessor-name :xlib-gl) (unless (eq status :external) (error "~A is not a known event slot"))) `(,var (,accessor ,event-form-var))))))) `(let ((,event-form-var ,event-form)) (let ,var-forms ,@body))))) (defun decode-x-button-code (code) (aref #.(vector +pointer-left-button+ +pointer-middle-button+ +pointer-right-button+ nil nil) (1- code))) (defun do-key-event (port event) (with-event-slots (:xkeyevent type window x y x_root y_root time) event (multiple-value-bind (keyname modifier-state) (event-to-keysym-and-modifiers port event) (make-instance (if (eql type xlib-gl:keypress) 'key-press-event 'key-release-event) :keyname keyname :key-character (and (characterp keyname) keyname) :x x :y y :graft-x x_root :graft-y y_root :sheet (port-sheet-from-coords port window x y) :modifier-state modifier-state :timestamp time)))) (defun do-button-event (port event) (with-event-slots (:xbuttonevent window x y x_root y_root time button state) event (let ((modifier-state (clim-xcommon:x-event-state-modifiers port state))) (make-instance (if (eq event-type xlib-gl:buttonpress) 'pointer-button-press-event 'pointer-button-release-event) :pointer 0 :button (decode-x-button-code button) :x x :y y :graft-x x_root :graft-y y_root :sheet (port-sheet-from-coords port window x y) :modifier-state modifier-state :timestamp time)))) (defun do-crossing-event (port event) (with-event-slots (:xcrossingevent x y x_root y_root state time button window) event (let ((sheet (port-sheet-from-coords port window x y)) (modifier-state (clim-xcommon:x-event-state-modifiers port state))) (when sheet (make-instance (cond ((eq event-type xlib-gl:enternotify) 'pointer-enter-event) ((eq (xlib-gl:xcrossingevent-mode event) xlib-gl:NotifyGrab) 'pointer-ungrab-event) (t 'pointer-exit-event)) :pointer 0 :button (decode-x-button-code button) :x x :y y :graft-x x_root :graft-y y_root :sheet (find-related-sheet port) :modifier-state modifier-state :timestamp time))))) (defun query-pointer (port window) (clim-ffi:with-c-data ((root :indow) (child :indow) (root-x int) (root-y int) (win-x int) (win-y int) (mask unsigned)) (let ((result (xquerypointer (opengl-port-display port) window root child root-x root-y win-x win-y mask))) (if (zerop result) (values 0 0 nil) (values win-x win-y t child mask root-x root-y))))) (defun do-motion-event (port event) (with-event-slots (:xmotionevent x y x_root y_root state time button window is_hint) event ;; If this is a hint, update the event values with the current pointer ;; state. (let ((pointer-x x) (pointer-y y) (root-x x_root) (root-y y_root) ())) (if (zerop is_hint)) (let ((sheet (port-sheet-from-coords port window x y))) (if (eq sheet (current-sheet port)) (make-instance 'pointer-motion-event :pointer 0 :button (find-button modifier) :x x :y y :sheet sheet :modifier-state (key-mod modifier) :timestamp time))))) (defun get-next-event-aux (port) (let* ((event (opengl-port-xevent port)) (display (opengl-port-display port)) (clim-event (if (synthesized-events port) (pop (synthesized-events port)) (progn (xlib-gl:XNextEvent (opengl-port-display port) event) (let ((event-type (xlib-gl:xanyevent-type event))) (case event-type ((xlib-gl:keypress xlib-gl:keyrelease) (multiple-value-bind (keyname modifier-state) (event-to-keysym-and-modifiers port event) (with-event-slots (:xkeyevent window x y x_root y_root time) event (make-instance (if (eql event-type xlib-gl:keypress) 'key-press-event 'key-release-event) :keyname keyname :key-character (and (characterp keyname) keyname) :x x :y y :graft-x x_root :graft-y y_root :sheet (port-sheet-from-coords port window x y) :modifier-state modifier-state :timestamp time)))) ((xlib-gl:buttonpress xlib-gl:buttonrelease) (with-event-slots (:xbuttonevent window x y x_root y_root time button state) event (let ((modifier-state (clim-xcommon:x-event-state-modifiers port state))) (make-instance (if (eq event-type xlib-gl:buttonpress) 'pointer-button-press-event 'pointer-button-release-event) :pointer 0 :button (decode-x-button-code code) :x x :y y :graft-x x_root :graft-y y_root :sheet (port-sheet-from-coords port window x y) :modifier-state modifier-state :timestamp time)))) ((xlib-gl:enternotify xlib-gl:leavenotify) (with-event-slots (:xcrossingevent x y x_root y_root state time code window) event (let ((sheet (port-sheet-from-coords port window x y)) (modifier-state (clim-xcommon:x-event-state-modifiers port state))) (when sheet (make-instance (cond ((eq event-type xlib-gl:enternotify) 'pointer-enter-event) ((eq (xlib-gl:xcrossingevent-mode event) xlib-gl:NotifyGrab) 'pointer-ungrab-event) (t 'pointer-exit-event)) :pointer 0 :button (decode-x-button-code code) :x x :y y :graft-x x_root :graft-y y_root :sheet (find-related-sheet port) :modifier-state modifier-state :timestamp time )))) (xlib-gl:motionnotify (with-event-slots (:xmotionevent x y x_root y_root state time code window) event (let ((sheet (port-sheet-from-coords port window x y))) ))) ((eq event-type xlib-gl:motionnotify) (let* ((x (xlib-gl:xmotionevent-x event)) (y (xlib-gl:xmotionevent-y event)) (modifier (xlib-gl:xmotionevent-state event)) (time (xlib-gl:xmotionevent-time event)) (sheet-signature (find-sheet-signature port x y)) (sheet (recognize-sheet port sheet-signature))) (declare (type fixnum x y modifier) (type (unsigned-byte 24) sheet-signature) (type bignum time)) (when (eq (xlib-gl:xmotionevent-window event) (sheet-direct-mirror (opengl-port-top-level port))) (if (= sheet-signature *current-sheet-signature*) ;; pointer is in the same sheet as for the previous event (let ((peek (opengl-port-xpeek port))) (unless (and (when (> (xlib-gl:XPending display) 0) (xlib-gl:XPeekEvent display peek) t) (eq (xlib-gl:XAnyEvent-Type peek) xlib-gl:MotionNotify)) (make-instance 'pointer-motion-event :pointer 0 :button (find-button modifier) :x x :y y :sheet sheet :modifier-state (key-mod modifier) :timestamp time))) ;; not in same sheet (when sheet (let ((button (find-button modifier)) (modifier (key-mod modifier)) (last-sheet (find-related-sheet port))) (declare (type fixnum button modifier) (type sheet last-sheet)) (progn (unless (= *current-sheet-signature* 0) (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-native-region last-sheet) (declare (type coordinate x1 y1 x2 y2)) (dispatch-event last-sheet (make-instance 'pointer-exit-event :pointer 0 :button button :x (max x1 (min x x2)) :y (max y1 (min y y2)) :sheet last-sheet :modifier-state modifier :timestamp (- time 2))))) ; change the current-sheet (setf *current-sheet-signature* sheet-signature) (dispatch-event sheet (make-instance 'pointer-enter-event :pointer 0 :button button :x x :y y :sheet sheet :modifier-state modifier :timestamp (1- time))) (make-instance 'pointer-motion-event :pointer 0 :button button :x x :y y :sheet sheet :modifier-state modifier :timestamp time)))))))) ((eq event-type xlib-gl:configurenotify) ; the configure notification will be only send to the top-level-sheet (make-instance 'window-configuration-event :sheet (port-lookup-sheet port (xlib-gl:xconfigureevent-window event)) :x (xlib-gl:xconfigureevent-x event) :y (xlib-gl:xconfigureevent-y event) :width (xlib-gl:xconfigureevent-width event) :height (xlib-gl:xconfigureevent-height event))) ((eq event-type xlib-gl:mapnotify) ; the mapping notification will be only send to the top-level-sheet (make-instance 'window-map-event :sheet (port-lookup-sheet port (xlib-gl:xmapevent-window event)))) ((eq event-type xlib-gl:destroynotify) (let ((top-level-sheet (opengl-port-top-level port))) (opengl-reshape (port-mirror-width port top-level-sheet) (port-mirror-height port top-level-sheet)) (draw-the-entire-scene port))) ((eq event-type xlib-gl:expose) ; the exposure notification will be only send to the top-level-sheet (let ((x (xlib-gl:xexposeevent-x event)) (y (xlib-gl:xexposeevent-y event))) (make-instance 'window-repaint-event :sheet (port-lookup-sheet port (xlib-gl:xexposeevent-window event)) :region (make-bounding-rectangle x y (+ x (xlib-gl:xexposeevent-width event)) (+ y (xlib-gl:xexposeevent-height event)))))) (t nil)))))))) (let ()) (when (synthesized-events port) (return-from get-next-event-aux )) ) ;; OpenGL graft (defun get-geometry (port mirror) (let ((x (make-array 1 :element-type '(unsigned-byte 32))) (y (make-array 1 :element-type '(unsigned-byte 32))) (width (make-array 1 :element-type '(unsigned-byte 32))) (height (make-array 1 :element-type '(unsigned-byte 32))) (border-width (make-array 1 :element-type '(unsigned-byte 32))) (depth (make-array 1 :element-type '(unsigned-byte 32))) (root (make-array 1 :element-type '(unsigned-byte 32)))) (xlib-gl:XGetGeometry (opengl-port-display port) mirror root x y width height border-width depth) (values (aref x 0) (aref y 0) (aref width 0) (aref height 0) (aref border-width 0) (aref depth 0)))) (defmethod make-graft ((port opengl-port) &key (orientation :default) (units :device)) (let* ((mirror (opengl-port-root port)) (graft (make-instance 'opengl-graft :port port :mirror mirror :orientation orientation :units units))) (multiple-value-bind (x y width height) (get-geometry port mirror) (declare (ignore x y) (type fixnum width height)) (setf (sheet-region graft) (make-bounding-rectangle 0 0 width height)) (push graft (port-grafts port)) graft))) (defmethod port-set-sheet-region ((port opengl-port) (graft graft) region) (declare (ignore region) (ignorable port graft)) nil) (defmethod port-set-sheet-transformation ((port opengl-port) (graft graft) transformation) (declare (ignore transformation) (ignorable port graft)) nil) (defmethod graft ((port opengl-port)) (first (port-grafts port))) ;; top-level-sheet-pane ; Integrate with the aux (defmethod realize-mirror ((port opengl-port) (sheet top-level-sheet-pane)) (let ((display (opengl-port-display port)) (screen-id (or (cadr (member :screen-id (port-server-path port))) 0)) (root (opengl-port-root port))) (unless *x-visual* (setf *x-visual* (gl:glXChooseVisual display screen-id (make-array 3 :element-type '(signed-byte 32) :initial-contents (list gl:GLX_RGBA gl:GLX_DOUBLEBUFFER xlib-gl:None))))) (when (zerop *x-visual*) (error "Error with X-Windows : couldn't get an RGB, double-buffered visual.")) (let ((attributes (xlib-gl:make-XSetWindowAttributes))) (xlib-gl:set-XSetWindowAttributes-Bit_Gravity! attributes xlib-gl:NorthWestGravity) (xlib-gl:set-XSetWindowAttributes-Colormap! attributes (xlib-gl:XCreateColormap display root (xlib-gl:XVisualInfo-visual *x-visual*) xlib-gl:AllocNone)) (xlib-gl:Set-XSetWindowAttributes-Event_Mask! attributes (logior xlib-gl:ExposureMask xlib-gl:KeyPressMask xlib-gl:KeyReleaseMask xlib-gl:ButtonPressMask xlib-gl:ButtonReleaseMask xlib-gl:PointerMotionMask xlib-gl:EnterWindowMask xlib-gl:LeaveWindowMask xlib-gl:StructureNotifyMask)) (let ((window (xlib-gl:XCreateWindow display root 0 0 100 100 0 (xlib-gl:XVisualInfo-depth *x-visual*) xlib-gl:InputOutput (xlib-gl:XVisualInfo-visual *x-visual*) (+ xlib-gl:CWBitGravity xlib-gl:CWColormap xlib-gl:CWEventMask) attributes)) (pretty-name (frame-pretty-name (pane-frame sheet)))) (setf *opengl-glx-context* (gl:glXCreateContext display *x-visual* NULL 1)) (when (zerop *opengl-glx-context*) (error "Error with X-Window : Unable to create an OpenGL context.")) (port-register-mirror port sheet window) (with-slots (signature->sheet) port (setf (gethash 0 signature->sheet) sheet)) (setf (opengl-port-top-level port) sheet) (xlib-gl:XStoreName display window pretty-name) (xlib-gl:XSetIconName display window pretty-name) (gl:GLXMakeCurrent display window *opengl-glx-context*) (xlib-gl:free-xsetwindowattributes attributes))))) (defmethod port-mirror-width ((port opengl-port) (sheet top-level-sheet-pane)) (multiple-value-bind (x y width) (get-geometry port (sheet-direct-mirror sheet)) (declare (ignore x y) (type fixnum width)) width)) (defmethod port-mirror-height ((port opengl-port) (sheet top-level-sheet-pane)) (multiple-value-bind (x y width height) (get-geometry port (sheet-direct-mirror sheet)) (declare (ignore x y width) (type fixnum height)) height)) (defmethod unrealize-mirror ((port opengl-port) (sheet top-level-sheet-pane)) (let ((mirror (sheet-direct-mirror sheet))) (xlib-gl:XDestroyWindow (opengl-port-display port) mirror) (with-slots (signature->sheet) port (remhash 0 signature->sheet)) (port-unregister-mirror port sheet mirror))) (defmethod port-set-sheet-region ((port opengl-port) (sheet top-level-sheet-pane) region) (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* region) (xlib-gl:XResizeWindow (opengl-port-display port) (sheet-direct-mirror sheet) (round (- x2 x1)) (round (- y2 y1))))) (defmethod port-set-sheet-transformation ((port opengl-port) (sheet top-level-sheet-pane) transformation) (multiple-value-bind (x y) (transform-position transformation 0 0) (xlib-gl:XMoveWindow (opengl-port-display port) (sheet-direct-mirror sheet) (round x) (round y)))) (defmethod port-compute-native-region ((port opengl-port) (sheet top-level-sheet-pane)) (declare (ignorable port)) (sheet-region sheet)) (defmethod compute-extremum :after ((pane top-level-sheet-pane)) (with-slots (space-requirement) pane (let ((size-hints (xlib-gl:make-xsizehints))) (xlib-gl:set-xsizehints-width! size-hints (round (space-requirement-width space-requirement))) (xlib-gl:set-xsizehints-height! size-hints (round (space-requirement-height space-requirement))) (xlib-gl:set-xsizehints-max_width! size-hints (round (space-requirement-max-width space-requirement))) (xlib-gl:set-xsizehints-max_height! size-hints (round (space-requirement-max-height space-requirement))) (xlib-gl:set-xsizehints-min_width! size-hints (round (space-requirement-min-width space-requirement))) (xlib-gl:set-xsizehints-min_height! size-hints (round (space-requirement-min-height space-requirement))) (xlib-gl:XSetWMNormalHints (opengl-port-display (port pane)) (sheet-direct-mirror pane) size-hints) (xlib-gl:free-xsizehints size-hints)))) ;; unmanaged-top-level-sheet-pane (defmethod realize-mirror ((port opengl-port) (sheet unmanaged-top-level-sheet-pane)) (let ((display (opengl-port-display port)) (root (opengl-port-root port)) (attributes (xlib-gl:make-xsetwindowattributes))) (xlib-gl:set-xsetwindowattributes-bit_gravity! attributes xlib-gl:NorthWestgravity) (xlib-gl:set-xsetwindowattributes-override_redirect! attributes 1) (xlib-gl:set-xsetwindowattributes-colormap! attributes (xlib-gl:XcreateColormap display root (xlib-gl:XVisualInfo-visual *x-visual*) xlib-gl:AllocNone)) (xlib-gl:set-xsetwindowattributes-event_mask! attributes (logior xlib-gl:ExposureMask xlib-gl:KeyPressMask xlib-gl:KeyReleaseMask xlib-gl:ButtonPressMask xlib-gl:ButtonReleaseMask xlib-gl:PointerMotionMask xlib-gl:EnterWindowMask xlib-gl:LeaveWindowMask xlib-gl:StructureNotifyMask xlib-gl:OwnerGrabButtonMask)) (let ((window (xlib-gl:XCreateWindow display root 0 0 100 100 1 (xlib-gl:XVisualInfo-depth *x-visual*) xlib-gl:InputOutput (xlib-gl:XVisualInfo-visual *x-visual*) (logior xlib-gl:CWBitGravity xlib-gl:CWOverrideRedirect xlib-gl:CWColormap xlib-gl:CWEventMask) attributes))) (port-register-mirror port sheet window) (setf (opengl-port-top-level port) sheet) (with-slots (signature->sheet) port (setf (gethash 0 signature->sheet) sheet)) (gl:glXMakeCurrent display window *opengl-glx-context*) (xlib-gl:free-xsetwindowattributes attributes)))) (defmethod unrealize-mirror ((port opengl-port) (sheet unmanaged-top-level-sheet-pane)) (let ((mirror (sheet-direct-mirror sheet))) (xlib-gl:XDestroyWindow (opengl-port-display port) mirror) (port-unregister-mirror port sheet mirror))) (defmethod unrealize-mirror :after ((port opengl-port) (sheet unmanaged-top-level-sheet-pane)) (declare (ignorable sheet)) (let ((top-level-sheet (frame-top-level-sheet *application-frame*))) (gl:glXMakeCurrent (opengl-port-display port) (sheet-direct-mirror top-level-sheet) *opengl-glx-context*) (setf (opengl-port-top-level port) top-level-sheet (gethash 0 (slot-value port 'signature->sheet)) top-level-sheet) ; reset the current signature (setf *current-sheet-signature* 0))) ;; Font and text styles (defconstant *opengl-text-families* '(:fix "adobe-courier" :serif "adobe-times" :sans-serif "adobe-helvetica")) (defconstant *opengl-text-faces* '(:roman "medium-r" :bold "bold-r" :italic "medium-i" :bold-italic "bold-i" :italic-bold "bold-i")) (defconstant *opengl-text-sizes* '(:normal 14 :tiny 8 :very-small 10 :small 12 :large 18 :very-large 20 :huge 24)) (defun open-font (display font-name) (let* ((font-name "fixed") ; <- FIXME ; this is what should be done, be at this moment, it doesn't work ;(number (make-array 1 :element-type '(unsigned-byte 32))) ;(fonts (xlib-gl:XListFonts display font-name 1 number)) ;(font (if fonts ; (xlib-gl:XLoadFont display (alien:deref fonts 0)) ; problems ; (xlib-gl:XLoadFont display "fixed"))) (font (xlib-gl:XLoadFont display font-name)) (font-struct (xlib-gl:XQueryFont display font)) (start (+ (* 256 (xlib-gl:xfontstruct-min_byte1 font-struct)) (xlib-gl:xfontstruct-min_char_or_byte2 font-struct))) (end (+ (* 256 (xlib-gl:xfontstruct-max_byte1 font-struct)) (xlib-gl:xfontstruct-max_char_or_byte2 font-struct))) (number-of-char (- end start)) (font-list (gl:glGenLists number-of-char))) (declare (type fixnum start end number-of-char font-list)) (prog2 (gl:glXUseXFont font start number-of-char font-list) (list font font-list start) (xlib-gl:free-xfontstruct font-struct)))) ;(xlib-gl:XFreeFontNames fonts) (defmethod text-style-to-X-font ((port opengl-port) text-style) (let ((table (slot-value port 'font-table))) (or (first (gethash text-style table)) (with-slots (family face size) text-style (let* ((family-name (if (stringp family) family (or (getf *opengl-text-families* family) (getf *opengl-text-families* :fix)))) (face-name (if (stringp face) face (or (getf *opengl-text-faces* (if (listp face) (intern (format nil "~A-~A" (first face) (second face)) :keyword) face)) (getf *opengl-text-faces* :roman)))) (size-number (if (numberp size) (round size) (or (getf *opengl-text-sizes* size) (getf *opengl-text-sizes* :normal)))) (font-name (format nil "-~A-~A-*-*-~D-*-*-*-*-*-*-*" family-name face-name size-number))) (first (setf (gethash text-style table) (open-font (opengl-port-display port) font-name)))))))) (defmacro with-font-struct ((port text-style font-struct-name) &body body) (let ((font (gensym))) `(let* ((,font (text-style-to-X-font ,port ,text-style)) (,font-struct-name (xlib-gl:XQueryFont (opengl-port-display ,port) ,font))) (unwind-protect (progn ,@body) (xlib-gl:free-xfontstruct ,font-struct-name))))) (defmethod text-style-height (text-style (port opengl-port)) (declare (type text-style text-style)) (with-font-struct (port text-style font-struct) (+ (xlib-gl:xfontstruct-ascent font-struct) (xlib-gl:xfontstruct-descent font-struct)))) (defmethod text-style-ascent (text-style (port opengl-port)) (declare (type text-style text-style)) (with-font-struct (port text-style font-struct) (xlib-gl:xfontstruct-ascent font-struct))) (defmethod text-style-descent (text-style (port opengl-port)) (declare (type text-style text-style)) (with-font-struct (port text-style font-struct) (xlib-gl:xfontstruct-descent font-struct))) ;; The text-style width is the average width between min_bounds and max_bounds (defmethod text-style-width (text-style (port opengl-port)) (declare (type text-style text-style)) (with-font-struct (port text-style font-struct) (round (+ (xlib-gl:xfontstruct-min_bounds-width font-struct) (xlib-gl:xfontstruct-max_bounds-width font-struct)) 2))) (defmethod port-character-width ((port opengl-port) text-style char) (declare (type standard-char char) (type text-style text-style)) (with-font-struct (port text-style font-struct) (xlib-gl:XTextWidth font-struct (make-string 1 :element-type 'standard-char :initial-element char) 1))) (defmethod port-string-width ((port opengl-port) text-style string &key (start 0) end) (declare (type string string) (type text-style text-style) (type fixnum start)) (let ((s (if end (subseq string start end) (subseq string start)))) (with-font-struct (port text-style font-struct) (xlib-gl:XTextWidth font-struct s (length s))))) #| ; [Julien] This is what should be done, but at this moment, it doesn't work (defmethod port-text-extents ((port opengl-port) text-style string &key start end) (declare (type text-style text-style) (type string string) (type fixnum start end)) (let ((s (subseq string start end)) (direction (make-array 1 :element-type '(unsigned-byte 32))) (font_ascent (make-array 1 :element-type '(unsigned-byte 32))) (font_descent (make-array 1 :element-type '(unsigned-byte 32))) (string_measures 0)) (declare (type fixnum string_measures)) ;direction font_ascent font_descent)) (with-font-struct (port text-style font-struct) (prog2 (xlib-gl:XTextExtents font-struct s (length s) direction font_ascent font_descent string_measures) (values (xlib-gl:xcharstruct-width string_measures) (xlib-gl:xcharstruct-ascent string_measures) (xlib-gl:xcharstruct-descent string_measures) (xlib-gl:xcharstruct-lbearing string_measures) (xlib-gl:xcharstruct-rbearing string_measures) (aref font_ascent 0) (aref direction 0) nil) (xlib-gl:free-xcharstruct string_measures))))) |# ; In order to patch this problem, informations from the biggest sizes of the font are chosen (defmethod port-text-extents ((port opengl-port) text-style string &key start end) (declare (type text-style text-style) (type string string) (type fixnum start end)) (let* ((s (subseq string start end)) (size (length s)) result) (declare (type string s) (type fixnum size)) (with-font-struct (port text-style font-struct) (let ((direction (xlib-gl:xfontstruct-direction font-struct)) (font_ascent (xlib-gl:xfontstruct-ascent font-struct)) (ascent (xlib-gl:xfontstruct-max_bounds-ascent font-struct)) (descent (xlib-gl:xfontstruct-max_bounds-descent font-struct)) (width (* (xlib-gl:xfontstruct-max_bounds-width font-struct) size)) (left 0) (right 0)) (declare (type fixnum direction font_ascent ascent descent width left right)) (if (eq direction xlib-gl:FontLeftToRight) (setf left (xlib-gl:xfontstruct-max_bounds-lbearing font-struct) right (+ (* (xlib-gl:xfontstruct-max_bounds-width font-struct) (1- size)) (xlib-gl:xfontstruct-max_bounds-rbearing font-struct))) (setf right (xlib-gl:xfontstruct-max_bounds-rbearing font-struct) left (+ (* (xlib-gl:xfontstruct-max_bounds-width font-struct) (1- size)) (xlib-gl:xfontstruct-max_bounds-lbearing font-struct)))) (values width ascent descent left right font_ascent direction nil))))) (defmethod text-style-list-and-start ((port opengl-port) text-style) (declare (type text-style text-style)) (let ((infos (gethash text-style (slot-value port 'font-table)))) (values (second infos) (third infos)))) ;; Device-Font-Text-Style (defmethod port-make-font-text-style ((port opengl-port) device-font-name) (let ((text-style (make-instance 'device-font-text-style :text-family device-font-name :text-face nil :text-size nil))) (setf (gethash text-style (slot-value port 'font-table)) (open-font (opengl-port-display port) device-font-name)) text-style)) ;;; Pixmap (defclass opengl-mirrored-pixmap (mirrored-pixmap) ((glx-pixmap :initform nil :reader opengl-mirrored-pixmap-glx-pixmap))) (defmethod realize-mirror ((port opengl-port) (pixmap pixmap)) (declare (ignorable port pixmap)) (error "OpenGL : can't realize a mirror for a generic pixmap")) (defmethod realize-mirror ((port opengl-port) (pixmap opengl-mirrored-pixmap)) (when (null (port-lookup-mirror port pixmap)) (let ((display (opengl-port-display port)) (window (sheet-mirror (pixmap-sheet pixmap)))) (multiple-value-bind (x y width height border-width depth) (get-geometry port window) (declare (ignore x y width height border-width) (type fixnum depth)) (let* ((x-pixmap (xlib-gl:XCreatePixmap display window (round (pixmap-width pixmap)) (round (pixmap-height pixmap)) depth)) (glx-pixmap (gl:glXCreateGLXPixmap display *x-visual* x-pixmap))) (setf (slot-value pixmap 'glx-pixmap) glx-pixmap) (port-register-mirror port pixmap (cons x-pixmap glx-pixmap)) (values)))))) (defmethod unrealize-mirror ((port opengl-port) (pixmap opengl-mirrored-pixmap)) (when (port-lookup-mirror port pixmap) (xlib-gl:XFreePixmap (opengl-port-display port) (port-lookup-mirror port pixmap)) (gl:glXDestroyGLXPixmap (opengl-port-display port) (opengl-mirrored-pixmap-glx-pixmap pixmap)) (port-unregister-mirror port pixmap (port-lookup-mirror port pixmap)))) (defmethod port-allocate-pixmap ((port opengl-port) sheet width height) (declare (type sheet sheet) (type real width height)) (let ((pixmap (make-instance 'opengl-mirrored-pixmap :sheet sheet :width width :height height :port port))) (when (sheet-grafted-p sheet) (realize-mirror port pixmap)) pixmap)) (defmethod port-deallocate-pixmap ((port opengl-port) pixmap) (when (port-lookup-mirror port pixmap) (unrealize-mirror port pixmap))) (defmethod port-copy-to-pixmap ((port opengl-port) (sheet sheet) from-x from-y width height pixmap to-x to-y) (declare (type coordinate from-x from-y to-x to-y) (type real width height)) (assert (typep pixmap 'opengl-mirrored-pixmap)) (let ((native-transformation (sheet-native-transformation sheet))) (declare (type transformation native-transformation)) (multiple-value-bind (x y) (bounding-rectangle* (sheet-region sheet)) (declare (type coordinate x y)) (multiple-value-bind (from-tx from-ty) (transform-position native-transformation (- from-x x) (- from-y y)) (declare (type coordinate from-tx from-ty)) (multiple-value-bind (twidth theight) (transform-position native-transformation width height) (declare (type coordinate twidth theight)) (let* ((itwidth (round twidth)) (itheight (round theight)) (addr_pixels (find-array-address (make-array `(,itheight ,itwidth) :element-type 'single-float)))) (gl:glReadBuffer gl:GL_FRONT) (gl:glReadPixels (round from-tx) (round from-ty) itwidth itheight gl:GL_RGBA gl:GL_FLOAT addr_pixels) (gl:glXMakeCurrent (opengl-port-display port) (opengl-mirrored-pixmap-glx-pixmap pixmap) *opengl-glx-context*) ; always copy in GL_FRONT buffer of the glXPixmap (gl:glDrawBuffer gl:GL_FRONT) (gl:glRasterPos2d to-x to-y) (gl:glDrawPixels itwidth itheight gl:GL_RGBA gl:GL_FLOAT addr_pixels) (gl:glXMakeCurrent (opengl-port-display port) (opengl-port-top-level port) *opengl-glx-context*))))))) (defmethod port-copy-to-pixmap ((port opengl-port) (medium medium) from-x from-y width height pixmap to-x to-y) (when (medium-sheet medium) ; temporary solution (port-copy-to-pixmap port (medium-sheet medium) from-x from-y width height pixmap to-x to-y))) (defmethod port-copy-to-pixmap ((port opengl-port) (stream stream) from-x from-y width height pixmap to-x to-y) (declare (ignore from-x from-y width height pixmap to-x to-y)) (error "copy-to-pixmap with a stream as source is not implemented.")) (defmethod port-copy-from-pixmap ((port opengl-port) pixmap from-x from-y width height sheet to-x to-y) (declare (type coordinate from-x from-y to-x to-y) (type real width height) (type sheet sheet)) (assert (typep pixmap 'opengl-mirrored-pixmap)) (let ((native-transformation (sheet-native-transformation sheet))) (declare (type transformation native-transformation)) (multiple-value-bind (x y) (bounding-rectangle* (sheet-region sheet)) (declare (type coordinate x y)) (multiple-value-bind (to-tx to-ty) (transform-position native-transformation (- to-x x) (- to-y y)) (declare (type coordinate to-tx to-ty)) (multiple-value-bind (twidth theight) (transform-position native-transformation width height) (declare (type coordinate twidth theight)) (let* ((itwidth (round twidth)) (itheight (round theight)) (addr_pixels (find-array-address (make-array `(,itheight ,itwidth) :element-type 'single-float)))) (gl:glXMakeCurrent (opengl-port-display port) (opengl-mirrored-pixmap-glx-pixmap pixmap) *opengl-glx-context*) ; always read from the GL_FRONT buffer of the glXPixmap (gl:glReadBuffer gl:GL_FRONT) (gl:glReadPixels (round from-x) (round from-y) itwidth itheight gl:GL_RGBA gl:GL_FLOAT addr_pixels) (gl:glXMakeCurrent (opengl-port-display port) (opengl-port-top-level port) *opengl-glx-context*) (gl:glDrawBuffer gl:GL_BACK) (gl:glRasterPos2d to-tx to-ty) (gl:glDrawPixels itwidth itheight gl:GL_RGBA gl:GL_FLOAT addr_pixels))))))) (defmacro with-context ((sheet) &body body) (if (typep sheet 'opengl-mirrored-pixmap) (let ((port (gensym))) `(let ((,port (port ,sheet))) (gl:glXMakeCurrent (opengl-port-display ,port) (opengl-mirrored-pixmap-glx-pixmap ,sheet) *opengl-glx-context*) (unwind-protect (progn ,@body)) (gl:glXMakeCurrent (opengl-port-display ,port) (opengl-port-top-level ,port) *opengl-glx-context*))) `(progn ,@body))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/OpenGL/opengl-port.lisp0000644000175000017500000004306210016355174023003 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2001 by Julien Boninfante (boninfan@emi.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :CLIM-INTERNALS) (defparameter *drawing-flag* (the boolean nil)) (defmacro to-gl (val) "Coerce VAL to the type expected by the OpenGL backend (currently double-float)" `(coerce ,val 'double-float)) ;; OpenGL port class (defclass opengl-port (basic-port opengl-graphical-system-port-mixin) ((signature->sheet :type hash-table :initform (make-hash-table)) (sheet->signature-dl :type hash-table :initform (make-hash-table :test #'eq)) (xevent :initform (xlib-gl:make-xevent) :reader opengl-port-xevent) (xpeek :initform (xlib-gl:make-xevent) :reader opengl-port-xpeek) (synthesized-events :initform nil :accessor synthesized-events :documentation "List of events resulting from the generation of multiple CLIM events from a single X event.") (current-sheet :initform nil :accessor current-sheet :documentation "Current sheet under the pointer."))) (defun recognize-sheet (port signature) (declare (type (unsigned-byte 24) signature) (type opengl-port port)) (gethash signature (slot-value port 'signature->sheet))) (defun opengl-sheet-infos (port sheet) (declare (type opengl-port port) (type sheet sheet)) (gethash sheet (slot-value port 'sheet->signature-dl))) (defmacro signature (port sheet) `(car (opengl-sheet-infos ,port ,sheet))) (defmacro dl (port sheet) `(cdr (opengl-sheet-infos ,port ,sheet))) (defmethod port-register-signature ((port opengl-port) sheet) ;(declare (type immediate-repainting-mixin sheet)) (declare (type clim-repainting-mixin sheet)) (let ((signature (get-signature))) (declare (type (unsigned-byte 24) signature)) (with-slots (sheet->signature-dl signature->sheet) port (setf (gethash signature signature->sheet) sheet (gethash sheet sheet->signature-dl) (cons signature (gl:glGenLists 1)))))) (defmethod port-unregister-signature ((port opengl-port) sheet) ;(declare (type immediate-repainting-mixin sheet)) (declare (type clim-repainting-mixin sheet)) (with-slots (sheet->signature-dl signature->sheet) port (let ((signature-and-dl (gethash sheet sheet->signature-dl))) (declare (type cons signature-and-dl)) (gl:glDeleteLists (cdr signature-and-dl) 1) (remhash sheet sheet->signature-dl) (remhash (car signature-and-dl) signature->sheet)))) (defmethod port-set-sheet-region ((port opengl-port) (sheet sheet) region) (declare (ignorable port sheet) (ignore region)) nil) (defmethod port-set-sheet-transformation ((port opengl-port) (sheet sheet) transformation) (declare (ignorable port sheet) (ignore transformation)) nil) (defun parse-opengl-server-path (path) (pop path) (let* ((s (get-environment-variable "DISPLAY")) (colon (position #\: s)) (dot (position #\. s :start colon)) (host-name (subseq s 0 colon)) (display-number (parse-integer s :start (1+ colon) :end dot)) (screen-number (if dot (parse-integer s :start (1+ dot)) 0))) (list :opengl :host (getf path :host host-name) :display-id (getf path :display-id display-number) :screen-id (getf path :screen-id screen-number)))) (setf (get :opengl :port-type) 'opengl-port) (setf (get :opengl :server-path-parser) 'parse-opengl-server-path) ;; opengl medium (defmethod make-medium ((port opengl-port) sheet) (make-instance 'opengl-medium ; :port port ; :graft (find-graft :port port) :sheet sheet)) ;;; opengl specific functions (defmethod opengl-init ((port opengl-port)) (gl:glClearColor 0.0 0.0 0.0 0.0) (gl:glShadeModel gl:GL_FLAT)) (defun draw-sheet (port sheet mode) (declare (type opengl-port port) (type sheet sheet) (type boolean mode)) (when (typep sheet 'clim-repainting-mixin) (if mode #+nil (repaint-sheet sheet (sheet-region sheet)) #-nil (handle-repaint sheet (sheet-region sheet)) (gl:glCallList (dl port sheet)))) (loop for child of-type sheet in (sheet-children sheet) do (draw-sheet port child mode))) (defun opengl-draw (port sheet mode) (declare (type boolean mode)) (setf *drawing-flag* t) (gl:glClear gl:GL_COLOR_BUFFER_BIT) (draw-sheet port sheet mode) (setf *drawing-flag* nil)) (defmethod draw-the-entire-scene ((port opengl-port)) (gl:glDrawBuffer gl:GL_BACK) (let ((sheet (opengl-port-top-level port))) (when sheet ; (with-sheet-medium (medium sheet) ; (with-slots (red green blue) (medium-background medium) ; (declare (type single-float red green blue)) ; (gl:glClearColor red green blue 0.0))) (opengl-draw port sheet t) (flush port sheet)))) #+nil (defmethod repaint-sheet :around ((sheet immediate-repainting-mixin) region) (declare (ignore region)) (if *drawing-flag* (call-next-method) (draw-the-entire-scene (port sheet)))) (defmethod handle-repaint :around ((sheet clim-repainting-mixin) region) (declare (ignore region)) (if *drawing-flag* (call-next-method) (draw-the-entire-scene (port sheet)))) ;;; OpenGl back-end event managing ;; OpenGL back-end is implemented following the ;; light-widget pattern. So, there is only the ;; top-level-sheet-pane which will have an ;; grpahical window. One consequence is that ;; every graphical system's event will have ;; the mirror of this pane as window argument. ; timeout is expressed in seconds (defmethod get-next-event ((port opengl-port) &key wait-function timeout) (declare (ignore wait-function)) (if timeout (loop with start-time of-type integer = (round (get-internal-run-time) internal-time-units-per-second) with end-time of-type integer = (+ start-time timeout) for time = (round (get-internal-run-time) internal-time-units-per-second) with event = nil while (and (null event) (<= time end-time)) do (unless (event-not-present-p port) (setf event (get-next-event-aux port))) finally (return (or event :timeout))) (get-next-event-aux port))) ;; ------------------------------------------------------------- ;; Explainings for sheet finding ;; ;; The purpose is to find the right sheet associated to its ;; drawing location from coordinates (x,y) on the screen. ;; The main idea is : ;; 1- associate with all grafted sheets a color (some kind of ;; blue level for example) ;; 2- when trying to recognize the sheet : ;; 2.1- redraw the entire scene, with only these blue level ;; colors and not the normal colors, with four clipping ;; planes defining an rectangle with dimensions 1x1 at ;; the (x,y) coordinates (the location's ones). ;; 2.2- Get the pixel color, and then retrieve the sheet ;; thanks to the association defined in part 1-. ;; The *current-sheet-signature* variable represents the last sheet found ;; by this operation. If pointer (or everything which defines ;; the (x,y) coordinates) is outside the main window, ;; *current-sheet-signature* is set to 0.0 . ;; ------------------------------------------------------------- (defparameter *current-sheet-signature* (the (unsigned-byte 24) 0)) (defmacro increment-signature (signature) `(setf ,signature (the (unsigned-byte 24) (+ (the (unsigned-byte 24) 1) ,signature))) ;`(setf ,signature (the (unsigned-byte 24) (random #xFFF))) ) (defun initialize-signature-count () (let ((count 0)) (declare (type (unsigned-byte 24) count)) (defun get-signature () (increment-signature count) count))) (defun find-related-sheet (port) (recognize-sheet port *current-sheet-signature*)) (defmacro pixel-to-color (pixel) `(logior (aref ,pixel 0) (ash (aref ,pixel 1) 8) (ash (aref ,pixel 2) 16))) #| ok, there is a very big vulnerability in this design, and that is that if your pixel layout changes, your signatures need to reflect this, or your events will disappear into the blue yonder... The following is for a 565 16 bit display, which is what I happen to use. I'll have a look at fixing this in a more portable fashion in a bit, until then, feel free to adjust the numbers, etc - BTS |# (defmacro color-to-signature (color) ; 565 `(logior (ash (logand ,color #b000000000000000011111000) -3) (ash (logand ,color #b000000001111110000000000) -5) (ash (logand ,color #b111110000000000000000000) -8))) (defmacro signature-to-color (signature) `(logior (ash (logand ,signature #b0000000000011111) 3) (ash (logand ,signature #b0000011111100000) 5) (ash (logand ,signature #b1111100000000000) 8))) ;(defmacro color-to-signature (color) color) ;(defmacro signature-to-color (signature) signature) ; this does the drawing (defun find-sheet-signature (port x y) (clim-ffi:with-c-data ((pixel (array unsigned-char 3))) (let ((sx (to-gl x)) (sy (to-gl y))) (declare (type double-float sx sy)) (gl:glReadBuffer gl:GL_BACK) (gl:glMatrixMode gl:GL_PROJECTION) (gl:glPushMatrix) (gl:glLoadIdentity) (gl:glOrtho sx (1+ sx) (1+ sy) sy -1d0 1d0) (gl:glMatrixMode gl:GL_MODELVIEW) (gl:glViewport 0 0 1 1) (opengl-draw port (opengl-port-top-level port) nil) (gl:glReadPixels 0 0 1 1 gl:GL_RGB gl:GL_UNSIGNED_BYTE pixel) (gl:glViewport (aref viewport-infos 0) (aref viewport-infos 1) (aref viewport-infos 2) (aref viewport-infos 3)) (gl:glMatrixMode gl:GL_PROJECTION) (gl:glPopMatrix) (gl:glMatrixMode gl:GL_MODELVIEW) #+nil (progn ; debugging - to see the fields (opengl-draw port (opengl-port-top-level port) nil) (format *debug-io* "pixel = ~A~%" (color-to-signature (pixel-to-color pixel))) (flush port (opengl-port-top-level port))) ; to see what's happening (color-to-signature (pixel-to-color pixel))))) ;; Event ;; window-map-event added, required by the back-end ;; This event only serve for one thing. That's why ;; its definition and use is very specialized. An ;; user MUST not use this event. (defclass window-map-event (window-event) () (:documentation "The goal of this event is to invoke the opengl-init function")) ;; Top-level-sheet-pane (defmethod handle-event ((pane top-level-sheet-pane) (event window-repaint-event)) (draw-the-entire-scene (port pane))) (defmethod handle-event ((pane top-level-sheet-pane) (event window-map-event)) (opengl-init (port pane))) (defmethod handle-event :before ((pane top-level-sheet-pane) (event window-configuration-event)) (opengl-reshape (window-configuration-event-width event) (window-configuration-event-height event))) ;; port specific function (defmethod port-compute-native-region ((port opengl-port) (sheet sheet)) (transform-region (sheet-native-transformation sheet) (sheet-region sheet))) (defmethod port-compute-native-transformation ((port opengl-port) (sheet sheet)) (sheet-delta-transformation sheet (opengl-port-top-level port))) ; 255 represents the Maximum number with (unsigned-byte 8) representation = (1111 1111)base2 (defmacro set-color (signature) `(let ((color (signature-to-color ,signature))) (gl:glColor3ub (logand color #xFF) (logand (ash color -8) #xFF) (logand (ash color -16) #xFF)))) ; this is where we draw the sheets in their signature colours, in order to determine ; where we clicked, I'm not convinced that this is a particularly good idea, myself (defun recompute-recognizing-drawing (sheet) (let* ((port (port sheet)) (infos (opengl-sheet-infos port sheet)) (native-region (sheet-native-region sheet))) (declare (type opengl-port port) (type cons infos) (type region native-region)) (etypecase native-region ; point (standard-point (gl:glNewList (cdr infos) gl:GL_COMPILE) (set-color (car infos)) (gl:glBegin gl:GL_POINTS) (gl:glVertex2d (to-gl (point-x native-region)) (to-gl (point-y native-region))) (gl:glEnd) (gl:glEndList)) ; line (line (multiple-value-bind (x1 y1) (line-start-point* native-region) (declare (type coordinate x1 y1)) (multiple-value-bind (x2 y2) (line-end-point* native-region) (declare (type coordinate x2 y2)) (gl:glNewList (cdr infos) gl:GL_COMPILE) (set-color (car infos)) (gl:glBegin gl:GL_LINES) (gl:glVertex2d (to-gl x1) (to-gl y1)) (gl:glVertex2d (to-gl x2) (to-gl y2)) (gl:glEnd) (gl:glEndList)))) ; polyline (standard-polyline (gl:glNewList (cdr infos) gl:GL_COMPILE) (set-color (car infos)) (if (polyline-closed native-region) (gl:glBegin gl:GL_LINE_LOOP) (gl:glBegin gl:GL_LINE_STRIP)) (map-over-polygon-coordinates (lambda (p) (gl:glVertex2d (to-gl (point-x p)) (to-gl (point-y p)))) native-region) (gl:glEnd) (gl:glEndList)) ; polygon #+nil (standard-polyline ; see above duplication - one is wrong - FIXME - BTS (gl:glNewList (cdr infos) gl:GL_COMPILE) (set-color (car infos)) (gl:glBegin gl:GL_POLYGON) (map-over-polygon-coordinates #'gl:glVertex2d native-region) (gl:glEnd) (gl:glEndList)) ; rectangle (standard-rectangle (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* native-region) (declare (type coordinate x1 y1 x2 y2)) (gl:glNewList (cdr infos) gl:GL_COMPILE) (set-color (car infos)) (gl:glRectd (to-gl x1) (to-gl y1) (to-gl x2) (to-gl y2)) (gl:glEndList))) ; ellipse and elliptical-arc ((or standard-ellipse standard-elliptical-arc) (let ((start-angle (ellipse-start-angle native-region)) (end-angle (ellipse-end-angle native-region)) (ellipse-transformation (slot-value native-region 'tr))) (declare (type double-float start-angle end-angle)) (multiple-value-bind (center-x center-y) (ellipse-center-point* native-region) (declare (type coordinate center-x center-y)) (gl:glNewList (cdr infos) gl:GL_COMPILE) (set-color (car infos)) (if (typep native-region 'standard-ellipse) (gl:glBegin gl:GL_POLYGON) (gl:glBegin gl:GL_LINE_STRIP)) (gl:glPushMatrix) (gl:glLoadIdentity) (gl:glTranslated center-x center-y 0d0) (loop with dtheta of-type double-float = (/ pi 100) ; half-ellipse is cut in 100 slices for theta of-type double-float from start-angle to end-angle by dtheta do (multiple-value-bind (x y) (transform-position ellipse-transformation (cos theta) (sin theta)) (declare (type double-float x y)) (gl:glVertex2d x y))) (gl:glPopMatrix) (gl:glEnd) (gl:glEndList)))) (nowhere-region ; what should I do here? - BTS nil) ; default : region intersection/union/difference are not handled. [yet?] ; error (format *debug-io* "Tried to draw an unknown type of shape ~A~%" (type-of native-region))))) (defmethod note-sheet-region-changed :after ((sheet clim-repainting-mixin)) (recompute-recognizing-drawing sheet)) (defmethod note-sheet-transformation-changed :after ((sheet clim-repainting-mixin)) (recompute-recognizing-drawing sheet)) (defmethod port-copy-area ((port opengl-port) sheet from-x from-y width height to-x to-y) (declare (type sheet sheet) (type coordinate from-x from-y to-x to-y) (type real width height)) (let ((native-transformation (sheet-native-transformation sheet))) (multiple-value-bind (x y) (bounding-rectangle* (sheet-region sheet)) (declare (type coordinate x y)) (multiple-value-bind (from-tx from-ty) (transform-position native-transformation (- from-x x) (- from-y y)) (declare (type coordinate from-tx from-ty)) (multiple-value-bind (to-tx to-ty) (transform-position native-transformation (- to-x x) (- to-y y)) (declare (type coordinate to-tx to-ty)) (multiple-value-bind (twidth theight) (transform-position native-transformation width height) (declare (type coordinate twidth theight)) (gl:glRasterPos2D (to-gl to-tx) (to-gl to-ty)) (gl:glCopyPixels (round from-tx) (round from-ty) (round twidth) (round theight) gl:GL_COLOR))))))) ;; Repaint protocol (defmacro with-special-choices ((sheet) &body body) `(progn ,@body)) (defmethod realize-mirror ((port opengl-port) (sheet sheet)) nil) (defmethod unrealize-mirror ((port opengl-port) (sheet sheet)) nil) (defmethod note-sheet-grafted :after ((sheet clim-repainting-mixin)) (port-register-signature (port sheet) sheet)) (defmethod note-sheet-degrafted :after ((sheet clim-repainting-mixin)) (port-unregister-signature (port sheet) sheet)) (defmethod window-clear ((sheet mirrored-sheet-mixin)) nil) (defmethod sheet-native-transformation :around ((sheet sheet)) (sheet-delta-transformation sheet (opengl-port-top-level (port sheet)))) (defmethod sheet-native-transformation :around ((sheet top-level-sheet-pane)) +identity-transformation+) (defmethod sheet-native-region :around ((sheet sheet)) (transform-region (sheet-native-transformation sheet) (sheet-region sheet))) (defmethod sheet-native-region :around ((sheet top-level-sheet-pane)) (sheet-region sheet)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/OpenGL/opengl-x-port-before.lisp0000644000175000017500000001070007776711603024515 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2001 by Julien Boninfante (boninfan@emi.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :CLIM-INTERNALS) ;; OpenGL with X mixin class (defclass opengl-graphical-system-port-mixin () ((display :initform nil :reader opengl-port-display) (screen :initform nil :reader opengl-port-screen) (root :initform nil :reader opengl-port-root) (font-table :initform (make-hash-table :test #'eq)) (top-level :type top-level-sheet-pane :initform nil :accessor opengl-port-top-level)) (:documentation "This port-mixin class store elements relative to the X-Windows system architecture")) (defmacro flush (port sheet) `(gl:glXSwapBuffers (opengl-port-display ,port) (sheet-direct-mirror ,sheet))) (defun find-array-address (array) (error "Don't call find-array-address!") #+cmu (alien::sap-int (cmucl-interface:array-data-address array)) #+sbcl ; I wonder if this will work... (declare (type (or (simple-array (signed-byte 8)) (simple-array (signed-byte 16)) (simple-array (signed-byte 32)) (simple-array (unsigned-byte 8)) (simple-array (unsigned-byte 16)) (simple-array (unsigned-byte 32)) (simple-array single-float) (simple-array double-float) (simple-array (complex single-float)) (simple-array (complex double-float))) array) (optimize (speed 3) (safety 0))) (sb-kernel::with-array-data ((data array) (start) (end)) (declare (ignore end)) (let ((addr (+ 8 (logandc1 7 (sb-kernel:get-lisp-obj-address data)))) (type-size (let ((type (array-element-type data))) (cond ((or (equal type '(signed-byte 8)) (equal type '(unsigned-byte 8))) 1) ((or (equal type '(signed-byte 16)) (equal type '(unsigned-byte 16))) 2) ((or (equal type '(signed-byte 32)) (equal type '(unsigned-byte 32))) 4) ((equal type 'single-float) 4) ((equal type 'double-float) 8) (t (error "Unknown specialized array element type")))))) (declare (type (unsigned-byte 32) addr) (optimize (speed 3) (safety 0) (sb-ext:inhibit-warnings 3))) (sb-sys:int-sap (the (unsigned-byte 32) (+ addr (* type-size start))))))) (defparameter viewport-infos (make-array 4 :element-type '(unsigned-byte 32))) (defun update-viewport-infos (x y width height) (declare (type fixnum x y width height)) (setf (aref viewport-infos 0) x (aref viewport-infos 1) y (aref viewport-infos 2) width (aref viewport-infos 3) height)) ;; This function must be defined relativy to a graphical system ;; because the coordinate system defines the orientation of ;; the frustrum. (defun opengl-reshape (width height) (declare (type fixnum width height)) (gl:glViewport 0 0 width height) (update-viewport-infos 0 0 width height) (gl:glMatrixMode gl:GL_PROJECTION) (gl:glLoadIdentity) ; using glOrtho with near=-1d0 et far=1d0 is equivalent to use glOrtho2D which is not implemented in the bindings (gl:glOrtho 0d0 (coerce width 'double-float) (coerce height 'double-float) 0d0 -1d0 1d0) (gl:glMatrixMode gl:GL_MODELVIEW) (gl:glLoadIdentity)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/OpenGL/opengl-frame-manager.lisp0000644000175000017500000000413307463151562024524 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2001 by Julien Boninfante (boninfan@emi.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :CLIM-INTERNALS) ;;; OPENGL-FRAME-MANAGER class (defclass opengl-frame-manager (frame-manager opengl-graphical-system-frame-manager-mixin) ()) #+nil (defmethod make-pane-1 ((fm opengl-frame-manager) (frame application-frame) type &rest args) (if (not (find-class type nil)) (setq type (intern (format nil "~A-PANE" type):clim))) (let ((sheet (apply #'make-instance type :frame frame :manager fm :port (port frame) args))) sheet)) (defmethod make-pane-1 ((fm opengl-frame-manager) (frame application-frame) type &rest args) (apply #'make-instance (or (find-symbol (concatenate 'string "OPENGL-" (symbol-name type)) :climi) (find-symbol (concatenate 'string "OPENGL-" (symbol-name type) "-PANE") :climi) (find-symbol (concatenate 'string (symbol-name type) "-PANE") :climi) type) :frame frame :manager fm :port (port frame) args)) #| (defmethod adopt-frame :after ((fm opengl-frame-manager) (frame menu-frame)) (xlib-gl:xmapwindow (sheet-direct-mirror (slot-value frame 'top-level-sheet)))) (defmethod adopt-frame :after ((fm opengl-frame-manager) (frame application-frame)) (xlib-gl:xmapwindow (sheet-direct-mirror (slot-value frame 'top-level-sheet)))) |# cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/OpenGL/opengl-x-graft.lisp0000644000175000017500000000361607463151562023377 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2001 by Julien Boninfante (boninfan@emi.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :CLIM-INTERNALS) ;;; OPENGL-GRAFT class (defclass opengl-graft (graft) () ) (defmethod graft-width ((graft opengl-graft) &key (units :device)) (let ((screen (opengl-port-screen (port graft)))) (ecase units (:device (xlib-gl:screen-width screen)) (:inches (/ (xlib-gl:screen-mwidth screen) 25.4s0)) (:millimeters (xlib-gl:screen-mwidth screen)) (:screen-sized 1)))) (defmethod graft-height ((graft opengl-graft) &key (units :device)) (let ((screen (opengl-port-screen (port graft)))) (ecase units (:device (xlib-gl:screen-height screen)) (:inches (/ (xlib-gl:screen-mheight screen) 25.4s0)) (:millimeters (xlib-gl:screen-mheight screen)) (:screen-sized 1)))) #+nil (defmethod graft-pixels-per-millimeter ((graft opengl-graft)) (let ((screen (opengl-port-screen (port graft)))) (/ (xlib-gl:screen-width screen) (xlib-gl:screen-mwidth screen)))) #+nil (defmethod graft-pixels-per-inch ((graft opengl-graft)) (* (graft-pixels-per-millimeter graft) 25.4s0)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/gtkairo/0000700000175000017500000000000011347763424020152 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/gtkairo/clim-fix.lisp0000640000175000017500000000444210561555366022566 0ustar pdmpdm;; FIXME: clim-cairo had more fixes here (in-package :climi) (defclass out-compositum (design) ((ink :initarg :ink :reader compositum-ink) (mask :initarg :mask :reader compositum-mask))) (defmethod print-object ((object out-compositum) stream) (print-unreadable-object (object stream :identity nil :type t) (format stream "~S ~S ~S ~S" :ink (compositum-ink object) :mask (compositum-mask object)))) (defmethod compose-out ((ink design) (mask design)) (make-instance 'out-compositum :ink ink :mask mask)) ;; FIXME: See bug 17. ;;;(defmethod transform-region (transformation (design design)) ;;; (make-instance 'transformed-design ;;; :transformation transformation ;;; :design design) ;;; (call-next-method)) (defmethod clim:handle-repaint :around ((s clim:sheet-with-medium-mixin) r) (let ((m (clim:sheet-medium s)) (r (clim:bounding-rectangle (clim:region-intersection r (clim:sheet-region s))))) (unless (eql r clim:+nowhere+) ;; Test case: Start CLIM-DEMO::DEMODEMO and watch the header string. ;; At the beginning, the text is nicely antialiased. Then start any ;; demo and move the new window around over the header. As the ;; header gets exposed again, the text is apparently redrawn ;; multiple times and looks like crap. This fixes it: (clim:with-drawing-options (m :clipping-region r) (clim:draw-design m r :ink clim:+background-ink+) (call-next-method s r))))) ;; cairo hack: adjust rectangle coordinates by half a pixel each to avoid ;; anti-aliasing (and follow-up output artifacts) (defun highlight-output-record-rectangle (record stream state) (with-identity-transformation (stream) (multiple-value-bind (x1 y1 x2 y2) (output-record-hit-detection-rectangle* record) (ecase state (:highlight (draw-rectangle* (sheet-medium stream) (+ (ceiling x1) 0.5d0) (+ (ceiling y1) 0.5d0) (- (floor (1- x2)) 0.5d0) (- (floor (1- y2)) 0.5d0) ;; XXX +FLIPPING-INK+? :filled nil :ink +foreground-ink+)) (:unhighlight ;; FIXME: repaint the hit detection rectangle. It could be ;; bigger than ;; the bounding rectangle. (repaint-sheet stream record))) (force-output stream)))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/gtkairo/graft.lisp0000600000175000017500000000315310420760433022136 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-CLX -*- ;;; (c) 2006 David Lichteblau (david@lichteblau.com) ;;; based on the null backend by: ;;; (c) 2005 Christophe Rhodes (c.rhodes@gold.ac.uk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-gtkairo) (defclass gtkairo-graft (graft) ()) (defmethod graft-width ((graft gtkairo-graft) &key (units :device)) (with-gtk () (let ((screen (gdk_screen_get_default))) (ecase units (:device (gdk_screen_get_width screen)) (:millimeters (gdk_screen_get_width_mm screen)) (:inches (/ (gdk_screen_get_width_mm screen) 25.4)) (:screen-sized 1))))) (defmethod graft-height ((graft gtkairo-graft) &key (units :device)) (with-gtk () (let ((screen (gdk_screen_get_default))) (ecase units (:device (gdk_screen_get_height screen)) (:millimeters (gdk_screen_get_height_mm screen)) (:inches (/ (gdk_screen_get_height_mm screen) 25.4)) (:screen-sized 1))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/gtkairo/port.lisp0000640000175000017500000007233710741375211022037 0ustar pdmpdm;;; -*- Mode: Lisp; -*- ;;; (c) 2006 David Lichteblau (david@lichteblau.com) ;;; based on the null backend by: ;;; (c) 2005 Christophe Rhodes (c.rhodes@gold.ac.uk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-gtkairo) ;;; Locking rule for this file: WITH-GTK is used by functions that ;;; directly call foreign functions from gtk_ or gdk_. (defmacro until (condition &body body) `(do () (,condition) ,@body)) (defmacro while (condition &body body) `(until (not ,condition) ,@body)) (defun round-coordinate (x) ;; Das machen wir einfach mal wie in CLIM-CLX. (floor (+ x .5))) ;;;; GTKAIRO-PORT (defclass gtkairo-pointer (standard-pointer) ((port :initarg :port :accessor port) (cursor :accessor pointer-cursor :initform :upper-left))) (defclass gtkairo-port (basic-port) ((pointer :accessor port-pointer) (events-head :accessor events-head) (events-tail :accessor events-tail) (widgets->sheets :initform (make-hash-table) :accessor widgets->sheets) (dirty-mediums :initform (make-hash-table) :accessor dirty-mediums) (gdk-metrik-medium :accessor gdk-metrik-medium) (cairo-metrik-medium :accessor cairo-metrik-medium) (pointer-grab-sheet :accessor pointer-grab-sheet :initform nil) (global-pango-context :accessor global-pango-context))) ;;;(defmethod print-object ((object gtkairo-port) stream) ;;; (print-unreadable-object (object stream :identity t :type t) ;;; (format stream "~S ~S" :id (slot-value object 'id)))) (defun parse-gtkairo-server-path (path) path) ;;; FIXME: if :port-type and :server-path-parser aren't CLIM-specified ;;; keywords, they should be altered to be in some mcclim-internal ;;; package instead. (setf (get :gtkairo :port-type) 'gtkairo-port) (setf (get :gtkairo :server-path-parser) 'parse-gtkairo-server-path) (defmethod initialize-instance :after ((port gtkairo-port) &rest initargs) (declare (ignore initargs)) (setf (events-head port) (list nil)) (setf (events-tail port) (events-head port)) (setf (port-pointer port) (make-instance 'gtkairo-pointer :port port)) (push (make-graft port) (climi::port-grafts port)) ;; FIXME: it seems bizarre for this to be necessary (push (make-instance 'gtkairo-frame-manager :port port) (slot-value port 'climi::frame-managers)) (when (zerop *g-threads-got-initialized*) (g_thread_init (cffi:null-pointer)) (gdk_threads_init) #-(or win32 windows mswindows) (gdk_error_trap_push)) (with-gtk () ;; FIXME: hier koennten wir mindestens ein anderes --display uebergeben ;; wenn wir wollten (gtk_init (cffi:null-pointer) (cffi:null-pointer)) (let* ((root (gdk_screen_get_root_window (gdk_screen_get_default))) (cr (gdk_cairo_create root))) (set-antialias cr) (setf (gdk-metrik-medium port) (make-instance 'gdk-metrik-medium :port port :gc (gdk_gc_new root))) (setf (cairo-metrik-medium port) (make-instance 'cairo-metrik-medium :port port :cr cr))) (setf (global-pango-context port) (gdk_pango_context_get))) (when clim-sys:*multiprocessing-p* (start-event-thread port))) (defmethod destroy-port :before ((port gtkairo-port)) ) (defun start-event-thread (port) (setf (climi::port-event-process port) (clim-sys:make-process (lambda () (loop (with-simple-restart (restart-event-loop "Restart CLIM's event loop.") (loop (process-next-event port))))) :name (format nil "~S's event process." port)))) ;;;; Mirrors (defclass mirror () ((mediums :initform '() :accessor mirror-mediums) (region :initform nil :accessor mirror-region))) (defclass widget-mirror (mirror) ((port :initarg :port :accessor mirror-port) (widget :initarg :widget :accessor mirror-widget) (mediums :initform '() :accessor mirror-mediums) (buffering-pixmap-dirty-p :initform t :accessor buffering-pixmap-dirty-p) (buffering-pixmap :initform nil :accessor mirror-buffering-pixmap))) (defclass window-mirror (widget-mirror) ((window :initarg :window :accessor mirror-window))) (defclass native-widget-mirror (widget-mirror) ((fixed :initarg :fixed :accessor mirror-fixed))) (defclass drawable-mirror (mirror) ((drawable :initarg :drawable :accessor mirror-drawable :accessor mirror-real-drawable) (mediums :initform '() :accessor mirror-mediums))) (defmethod mirror-real-drawable ((mirror widget-mirror)) (gtkwidget-gdkwindow (mirror-widget mirror))) (defmethod mirror-drawable ((mirror widget-mirror)) (let ((sheet (climi::port-lookup-sheet (mirror-port mirror) mirror))) (if (climi::pane-double-buffering sheet) (or (mirror-buffering-pixmap mirror) (setf (mirror-buffering-pixmap mirror) (let* ((window (mirror-real-drawable mirror)) (region (climi::sheet-mirror-region sheet)) (width (floor (bounding-rectangle-max-x region))) (height (floor (bounding-rectangle-max-y region))) (pixmap (gdk_pixmap_new window width height -1)) (cr (gdk_cairo_create pixmap))) (set-antialias cr) (cairo_set_source_rgba cr 1.0d0 1.0d0 1.0d0 1.0d0) (cairo_paint cr) (cairo_destroy cr) pixmap))) (mirror-real-drawable mirror)))) (defun widget->sheet (widget port) (gethash (cffi:pointer-address widget) (widgets->sheets port))) (defun (setf widget->sheet) (newval widget port) (let ((address (cffi:pointer-address widget)) (table (widgets->sheets port))) (if newval (setf (gethash address table) newval) (remhash address table)))) ;;; Pixmaps: The spec doesn't say what a pixmap is, but the McCLIM ;;; frontend wants us to use its PIXMAP class. So every backend ;;; copy&pastes PORT-(DE)ALLOCATE-PIXMAP to conform. Why doesn't BASIC-PORT ;;; do this for us then? (defmethod port-allocate-pixmap ((port gtkairo-port) sheet width height) (let ((pixmap (make-instance 'gtkairo-pixmap :sheet sheet :width width :height height :port port))) (when (sheet-grafted-p sheet) (realize-mirror port pixmap)) pixmap)) (defmethod port-deallocate-pixmap ((port gtkairo-port) pixmap) (when (climi::port-lookup-mirror port pixmap) (destroy-mirror port pixmap))) ;;;; REALIZE-MIRROR (defmethod realize-window-mirror (port sheet type) (with-gtk () (let* ((q (compose-space sheet)) (window (gtk_window_new type)) (widget (gtk_fixed_new)) (width (round-coordinate (space-requirement-width q))) (height (round-coordinate (space-requirement-height q))) (mirror (make-instance 'window-mirror :port port :window window :widget widget))) (gtk_window_set_title window (frame-pretty-name (pane-frame sheet))) (setf (widget->sheet widget port) sheet) (setf (widget->sheet window port) sheet) (connect-signals widget) (connect-window-signals window) (gtk_widget_set_double_buffered widget 0) (gtk_window_set_default_size window width height) (gtk_container_add window widget) (climi::port-register-mirror (port sheet) sheet mirror) mirror))) (defmethod realize-mirror ((port gtkairo-port) (sheet climi::top-level-sheet-pane)) (let ((mirror (realize-window-mirror port sheet GTK_WINDOW_TOPLEVEL))) (port-enable-sheet port sheet) mirror)) (defmethod realize-mirror ((port gtkairo-port) (sheet climi::unmanaged-top-level-sheet-pane)) (realize-window-mirror port sheet GTK_WINDOW_POPUP)) (defmacro with-gdkcolor ((var clim-color) &body body) `(invoke-with-gdkcolor (lambda (,var) ,@body) ,clim-color)) (defun invoke-with-gdkcolor (fn clim-color) (cffi:with-foreign-object (c 'gdkcolor) (setf (cffi:foreign-slot-value c 'gdkcolor 'pixel) 0) (setf (values (cffi:foreign-slot-value c 'gdkcolor 'r) (cffi:foreign-slot-value c 'gdkcolor 'g) (cffi:foreign-slot-value c 'gdkcolor 'b)) (multiple-value-bind (r g b) (color-rgb clim-color) (values (min (truncate (* r 65536)) 65535) (min (truncate (* g 65536)) 65535) (min (truncate (* b 65536)) 65535)))) (funcall fn c))) (defun gtk-widget-modify-bg (widget color) (with-gdkcolor (c color) (gtk_widget_modify_bg widget 0 c))) (defun gtk-widget-modify-fg (widget color) (with-gdkcolor (c color) (gtk_widget_modify_fg widget 0 c))) ;; copy&paste from port.lisp|CLX: (defun sheet-desired-color (sheet) (typecase sheet (sheet-with-medium-mixin (medium-background sheet)) (basic-pane ;; CHECKME [is this sensible?] seems to be (let ((background (pane-background sheet))) (if (typep background 'color) background +white+))) (t +white+))) (defmethod container-put ((parent sheet) parent-widget child x y) (gtk_fixed_put parent-widget child x y)) (defmethod container-move ((parent sheet) parent-widget child x y) (gtk_fixed_move parent-widget child x y)) (defmethod realize-mirror ((port gtkairo-port) (sheet mirrored-sheet-mixin)) (with-gtk () (let* ((parent (sheet-mirror (sheet-parent sheet))) (q (compose-space sheet)) (widget (gtk_fixed_new)) (width (round-coordinate (space-requirement-width q))) (height (round-coordinate (space-requirement-height q))) (mirror (make-instance 'widget-mirror :port port :widget widget))) (setf (widget->sheet widget port) sheet) ;; Das machen wir uns mal einfach und geben jedem Widget sein eigenes ;; Fenster, dann haben wir naemlich das Koordinatensystem und Clipping ;; wie aus CLX bekannt. An und fuer sich koennten wir das aber auch ;; selbst per Cairo erledigen. Muss man sich langfristig mal ueberlegen. (gtk_fixed_set_has_window widget 1) (gtk_widget_set_double_buffered widget 0) (connect-signals widget) (gtk_widget_set_size_request widget width height) (multiple-value-bind (x y) (transform-position (climi::%sheet-mirror-transformation sheet) 0 0) (setf x (round-coordinate x)) (setf y (round-coordinate y)) (container-put (sheet-parent sheet) (mirror-widget parent) widget x y)) (climi::port-register-mirror (port sheet) sheet mirror) (gtk-widget-modify-bg widget (sheet-desired-color sheet)) (when (sheet-enabled-p sheet) (gtk_widget_show widget)) mirror))) (defclass native-widget-mixin () ((widget :initform nil :accessor native-widget))) (defclass gtk-menu (basic-pane) ((label :initarg :label :accessor gtk-menu-label) (command-table :initform nil :initarg :command-table :accessor gtk-menu-command-table))) (defclass gtk-nonmenu (basic-pane) ((label :initarg :label :accessor gtk-nonmenu-label) (callback :initarg :value-changed-callback :accessor gtk-nonmenu-callback))) (defclass gtk-menu-bar (native-widget-mixin sheet-multiple-child-mixin basic-pane) ((contents :initarg :contents :accessor gtk-menu-bar-contents))) (defmethod realize-mirror ((port gtkairo-port) (sheet native-widget-mixin)) (with-gtk () (setf (native-widget sheet) (realize-native-widget sheet)) (let* ((widget (native-widget sheet)) (parent (sheet-mirror (sheet-parent sheet))) (q (compose-space sheet)) (fixed (gtk_fixed_new)) (width (round-coordinate (space-requirement-width q))) (height (round-coordinate (space-requirement-height q))) (mirror (make-instance 'native-widget-mirror :port port :fixed fixed :widget widget))) (setf (widget->sheet fixed port) sheet) (setf (widget->sheet widget port) sheet) (gtk_fixed_set_has_window fixed 1) (connect-native-signals sheet widget) (gtk_widget_set_size_request fixed width height) (gtk_widget_set_size_request widget width height) (multiple-value-bind (x y) (transform-position (climi::%sheet-mirror-transformation sheet) 0 0) (setf x (round-coordinate x)) (setf y (round-coordinate y)) (container-put (sheet-parent sheet) (mirror-widget parent) fixed x y)) (gtk_fixed_put fixed widget 0 0) (climi::port-register-mirror (port sheet) sheet mirror) (when (sheet-enabled-p sheet) (gtk_widget_show_all fixed)) mirror))) (defclass menu-mirror (widget-mirror) ((menu-item :initarg :menu-item :reader mirror-menu-item) (menu :initarg :menu :reader mirror-menu))) (defclass nonmenu-mirror (widget-mirror) ((menu-item :initarg :menu-item :reader mirror-menu-item))) (defmethod realize-mirror :after ((port gtkairo-port) (sheet gtk-menu-bar)) (dolist (menu (gtk-menu-bar-contents sheet)) (unless (integerp menu) ;? (sheet-adopt-child sheet menu)))) (defmethod realize-mirror ((port gtkairo-port) (sheet gtk-menu)) (unless (climi::port-lookup-mirror port sheet) (with-gtk () (let* ((menu-item (gtk_menu_item_new_with_label (gtk-menu-label sheet))) (menu (gtk_menu_new)) (parent (sheet-mirror (sheet-parent sheet))) (mirror (make-instance 'menu-mirror :menu menu :menu-item menu-item))) (setf (widget->sheet menu-item port) sheet) (setf (widget->sheet menu port) sheet) (append-menu-items port sheet menu (gtk-menu-command-table sheet)) (gtk_menu_item_set_submenu menu-item menu) (gtk_menu_shell_append (mirror-widget parent) menu-item) (climi::port-register-mirror (port sheet) sheet mirror) (when (sheet-enabled-p sheet) (gtk_widget_show_all menu-item)) mirror)))) (defmethod realize-mirror ((port gtkairo-port) (sheet gtk-nonmenu)) (unless (climi::port-lookup-mirror port sheet) (with-gtk () (let* ((menu-item (gtk_menu_item_new_with_label (gtk-nonmenu-label sheet))) (parent (sheet-mirror (sheet-parent sheet))) (mirror (make-instance 'nonmenu-mirror :menu-item menu-item))) (setf (widget->sheet menu-item port) sheet) (connect-signal menu-item "activate" 'magic-clicked-handler) (gtk_menu_shell_append (mirror-widget parent) menu-item) (climi::port-register-mirror (port sheet) sheet mirror) (when (sheet-enabled-p sheet) (gtk_widget_show_all menu-item)) mirror)))) (defmethod realize-mirror ((port gtkairo-port) (pixmap-sheet climi::pixmap)) (unless (climi::port-lookup-mirror port pixmap-sheet) (let* ((drawable (mirror-drawable (sheet-direct-mirror (climi::pixmap-sheet pixmap-sheet)))) (w (round (pixmap-width pixmap-sheet))) (h (round (pixmap-height pixmap-sheet))) (pixmap (gdk_pixmap_new drawable w h -1)) (mirror (make-instance 'drawable-mirror :drawable pixmap)) (gc (gdk_gc_new pixmap))) (cffi:with-foreign-object (c 'gdkcolor) (setf (cffi:foreign-slot-value c 'gdkcolor 'pixel) 0) (setf (values (cffi:foreign-slot-value c 'gdkcolor 'r) (cffi:foreign-slot-value c 'gdkcolor 'g) (cffi:foreign-slot-value c 'gdkcolor 'b)) (values 65535 65535 65535)) (gdk_gc_set_rgb_fg_color gc c)) (gdk_draw_rectangle pixmap gc 1 0 0 w h) (gdk_gc_unref gc) (climi::port-register-mirror port pixmap-sheet mirror) mirror))) ;;;; DESTROY-MIRROR (defun destroy-window-mirror (port sheet) (with-gtk () (let ((mirror (climi::port-lookup-mirror port sheet))) (destroy-mediums mirror) (gtk_widget_destroy (mirror-window mirror)) (gtk-main-iteration port) (climi::port-unregister-mirror port sheet mirror) (setf (widget->sheet (mirror-widget mirror) port) nil)))) (defun destroy-mediums (mirror) (mapc #'destroy-medium (mirror-mediums mirror)) (setf (mirror-mediums mirror) '())) (defmethod destroy-mirror ((port gtkairo-port) (sheet climi::top-level-sheet-pane)) (destroy-window-mirror port sheet)) (defmethod destroy-mirror ((port gtkairo-port) (sheet climi::unmanaged-top-level-sheet-pane)) (destroy-window-mirror port sheet)) (defmethod destroy-mirror ((port gtkairo-port) (sheet mirrored-sheet-mixin)) (with-gtk () (let ((mirror (climi::port-lookup-mirror port sheet))) (destroy-mediums mirror) (gtk_widget_destroy (mirror-widget mirror)) (when (mirror-buffering-pixmap mirror) (gdk_drawable_unref (mirror-drawable mirror))) (climi::port-unregister-mirror port sheet mirror) (setf (widget->sheet (mirror-widget mirror) port) nil)))) (defmethod destroy-mirror :after ((port gtkairo-port) (sheet native-widget-mixin)) (setf (native-widget sheet) nil)) (defmethod destroy-mirror ((port gtkairo-port) (pixmap-sheet climi::pixmap)) (with-gtk () (let ((mirror (climi::port-lookup-mirror port pixmap-sheet))) (when mirror (destroy-mediums mirror) (gdk_drawable_unref (mirror-drawable mirror)) (climi::port-unregister-mirror port pixmap-sheet mirror))))) (defmethod destroy-mirror ((port gtkairo-port) (pixmap-sheet gtk-menu)) (with-gtk () (let ((mirror (climi::port-lookup-mirror port pixmap-sheet))) (when mirror (climi::port-unregister-mirror port pixmap-sheet mirror))))) (defmethod destroy-mirror ((port gtkairo-port) (pixmap-sheet gtk-nonmenu)) (with-gtk () (let ((mirror (climi::port-lookup-mirror port pixmap-sheet))) (when mirror (climi::port-unregister-mirror port pixmap-sheet mirror))))) ;;;; Positioning and resizing (defun reset-mediums (mirror) (mapc #'destroy-medium (mirror-mediums mirror)) (when (mirror-buffering-pixmap mirror) (let* ((old (mirror-buffering-pixmap mirror)) (new (progn (setf (mirror-buffering-pixmap mirror) nil) (mirror-drawable mirror))) (gc (gdk_gc_new new))) (gdk_draw_drawable new gc old 0 0 0 0 -1 -1) (gdk_gc_unref gc) (gdk_drawable_unref old)) (setf (buffering-pixmap-dirty-p mirror) t))) (defmethod port-set-mirror-region ((port gtkairo-port) (mirror window-mirror) mirror-region) (with-gtk () (gtk_window_resize (mirror-window mirror) (floor (bounding-rectangle-max-x mirror-region)) (floor (bounding-rectangle-max-y mirror-region))) (reset-mediums mirror) ;; Nanu, ohne die Geometrie hier zu korrigieren kann das Fenster nur ;; vergroessert, nicht aber wieder verkleinert werden. (cffi:with-foreign-object (geometry 'gdkgeometry) (setf (cffi:foreign-slot-value geometry 'gdkgeometry 'min_width) 1) (setf (cffi:foreign-slot-value geometry 'gdkgeometry 'min_height) 1) (gtk_window_set_geometry_hints (mirror-window mirror) (mirror-window mirror) geometry 2)))) (defmethod port-set-mirror-region ((port gtkairo-port) (mirror mirror) mirror-region) (unless (and (mirror-region mirror) (region-equal (mirror-region mirror) mirror-region)) (with-gtk () (gtk_widget_set_size_request (mirror-widget mirror) (floor (bounding-rectangle-max-x mirror-region)) (floor (bounding-rectangle-max-y mirror-region))) (reset-mediums mirror)) (setf (mirror-region mirror) mirror-region))) (defmethod port-set-mirror-region ((port gtkairo-port) (mirror native-widget-mirror) mirror-region) (with-gtk () (let ((w (floor (bounding-rectangle-max-x mirror-region))) (h (floor (bounding-rectangle-max-y mirror-region)))) (gtk_widget_set_size_request (mirror-fixed mirror) w h) (gtk_widget_set_size_request (mirror-widget mirror) w h)))) (defmethod port-set-mirror-transformation ((port gtkairo-port) (mirror window-mirror) mirror-transformation) (with-gtk () (multiple-value-bind (x y) (transform-position mirror-transformation 0 0) (gtk_window_move (mirror-window mirror) (floor x) (floor y))) (reset-mediums mirror))) (defmethod port-set-mirror-transformation ((port gtkairo-port) (mirror mirror) mirror-transformation) (with-gtk () (let* ((w (mirror-widget mirror)) (parent-sheet (sheet-parent (climi::port-lookup-sheet port mirror))) (parent (cffi:foreign-slot-value w 'gtkwidget 'parent))) (multiple-value-bind (x y) (transform-position mirror-transformation 0 0) (container-move parent-sheet parent w (floor x) (floor y)))))) (defmethod port-set-mirror-transformation ((port gtkairo-port) (mirror native-widget-mirror) mirror-transformation) (with-gtk () (let* ((w (mirror-fixed mirror)) (parent-sheet (sheet-parent (climi::port-lookup-sheet port mirror))) (parent (cffi:foreign-slot-value w 'gtkwidget 'parent))) (multiple-value-bind (x y) (transform-position mirror-transformation 0 0) (container-move parent-sheet parent w (floor x) (floor y)))))) ;;;; An und aus (defmethod port-enable-sheet ((port gtkairo-port) (sheet mirrored-sheet-mixin)) (with-gtk () (let ((mirror (climi::port-lookup-mirror port sheet))) (gtk_widget_show (mirror-widget mirror))))) (defmethod port-enable-sheet ((port gtkairo-port) (sheet native-widget-mixin)) (with-gtk () (let ((mirror (climi::port-lookup-mirror port sheet))) (gtk_widget_show_all (mirror-fixed mirror))))) (defmethod port-enable-sheet ((port gtkairo-port) (sheet climi::top-level-sheet-pane)) (with-gtk () (let ((mirror (climi::port-lookup-mirror port sheet))) (gtk_widget_show (mirror-window mirror)) (gtk_widget_show (mirror-widget mirror))))) (defmethod port-enable-sheet ((port gtkairo-port) (sheet climi::unmanaged-top-level-sheet-pane)) (with-gtk () (let ((mirror (climi::port-lookup-mirror port sheet))) (gtk_widget_show (mirror-window mirror)) (gtk_widget_show (mirror-widget mirror))))) (defmethod port-disable-sheet ((port gtkairo-port) (sheet mirrored-sheet-mixin)) (with-gtk () (let ((mirror (climi::port-lookup-mirror port sheet))) (gtk_widget_hide (mirror-widget mirror))))) (defmethod port-disable-sheet ((port gtkairo-port) (sheet native-widget-mixin)) (with-gtk () (let ((mirror (climi::port-lookup-mirror port sheet))) (gtk_widget_hide_all (mirror-fixed mirror))))) (defmethod port-disable-sheet ((port gtkairo-port) (sheet climi::top-level-sheet-pane)) (with-gtk () (let ((mirror (climi::port-lookup-mirror port sheet))) (gtk_widget_hide (mirror-window mirror))))) ;;;; JUNK (defmethod mirror-transformation ((port gtkairo-port) mirror) ()) ;; die sind verkehrt, die gibt's gar nicht ;;;(defmethod port-set-sheet-transformation ;;; ((port gtkairo-port) (graft graft) transformation) ;;; ()) ;;; ;;;(defmethod port-set-sheet-transformation ;;; ((port gtkairo-port) (sheet mirrored-sheet-mixin) transformation) ;;; ()) ;;;; Vermischtes (defmethod port-motion-hints ((port gtkairo-port) (sheet mirrored-sheet-mixin)) (with-gtk () (logtest GDK_POINTER_MOTION_HINT_MASK (gtk_widget_get_events (mirror-widget (sheet-direct-mirror sheet)))))) (defmethod (setf port-motion-hints) (value (port gtkairo-port) (sheet mirrored-sheet-mixin)) (with-gtk () (let* ((widget (mirror-widget (sheet-direct-mirror sheet))) (oldval (gtk_widget_get_events widget)) (newval (if value (logior oldval GDK_POINTER_MOTION_HINT_MASK) (logandc2 oldval GDK_POINTER_MOTION_HINT_MASK)))) (gtk_widget_set_events widget newval)))) (defmethod make-graft ((port gtkairo-port) &key (orientation :default) (units :device)) (make-instance 'gtkairo-graft :port port :mirror (gensym) :orientation orientation :units units)) (defmethod text-style-mapping ((port gtkairo-port) text-style &optional character-set) (error "text-style-mapping called, what now?")) (defmethod (setf text-style-mapping) (font-name (port gtkairo-port) (text-style text-style) &optional character-set) (error "(setf text-style-mapping) called, what now?")) (defmethod port-character-width ((port gtkairo-port) text-style char) (error "port-character-width called, what now?")) (defmethod port-string-width ((port gtkairo-port) text-style string &key (start 0) end) (error "port-string-width called, what now?")) (defmethod port-mirror-width ((port gtkairo-port) sheet) (cffi:with-foreign-object (r 'gtkrequisition) (gtk_widget_size_request (mirror-widget (climi::port-lookup-mirror port sheet)) r) (cffi:foreign-slot-value r 'gtkrequisition 'width))) (defmethod port-mirror-height ((port gtkairo-port) sheet) (cffi:with-foreign-object (r 'gtkrequisition) (gtk_widget_size_request (mirror-widget (climi::port-lookup-mirror port sheet)) r) (cffi:foreign-slot-value r 'gtkrequisition 'height))) (defmethod port-mirror-width ((port gtkairo-port) (sheet gtkairo-graft)) (graft-width sheet)) (defmethod port-mirror-height ((port gtkairo-port) (sheet gtkairo-graft)) (graft-height sheet)) (defmethod graft ((port gtkairo-port)) (first (climi::port-grafts port))) (defun %gdk-display-get-pointer () (with-gtk () (cffi:with-foreign-object (x :int) (cffi:with-foreign-object (y :int) (cffi:with-foreign-object (mask :int) (gdk_display_get_pointer (gdk_display_get_default) (cffi:null-pointer) ;FIXME: screen x y mask) (values (cffi:mem-aref x :int) (cffi:mem-aref y :int) (cffi:mem-aref mask :int))))))) (defun mirror-pointer-position (mirror) (with-gtk () (cffi:with-foreign-object (x :int) (cffi:with-foreign-object (y :int) (gtk_widget_get_pointer (mirror-widget mirror) x y) (values (cffi:mem-aref x :int) (cffi:mem-aref y :int)))))) (defmethod pointer-position ((pointer gtkairo-pointer)) (%gdk-display-get-pointer)) (defmethod pointer-button-state ((pointer gtkairo-pointer)) (with-gtk () (gdkmodifiertype->all-buttons (nth-value 2 (%gdk-display-get-pointer))))) (defmethod port-modifier-state ((port gtkairo-port)) (with-gtk () (gdkmodifiertype->modifier-state (nth-value 2 (%gdk-display-get-pointer))))) ;;; port.lisp|CLX says: ;;; XXX Should we rely on port-pointer-sheet being correct? -- moore (defmethod synthesize-pointer-motion-event ((pointer gtkairo-pointer)) (with-gtk () (let* ((port (port pointer)) (sheet (climi::port-pointer-sheet port))) (when sheet (let ((mirror (sheet-direct-mirror sheet))) (when mirror (multiple-value-bind (root-x root-y state) (%gdk-display-get-pointer) ;; FIXME ;when same-screen-p (multiple-value-bind (x y) (mirror-pointer-position mirror) (make-instance 'pointer-motion-event :pointer 0 :button (gdkmodifiertype->one-button state) :x x :y y :graft-x root-x :graft-y root-y :sheet sheet :modifier-state (gdkmodifiertype->modifier-state state) ;; The event initialization code will give us a ;; reasonable timestamp. :timestamp 0))))))))) (defmethod port-frame-keyboard-input-focus ((port gtkairo-port) frame) (with-gtk () (let* ((sheet (frame-top-level-sheet frame)) (mirror (climi::port-lookup-mirror port sheet)) (widget (gtk_window_get_focus (mirror-window mirror)))) (if (cffi:null-pointer-p widget) nil (widget->sheet widget port))))) (defmethod (setf port-frame-keyboard-input-focus) (focus (port gtkairo-port) frame) (with-gtk () ;; could use gtk_window_set_focus here for symmetry, but we don't ;; have to. (gtk_widget_grab_focus (mirror-widget (sheet-mirror focus)))) focus) (defmethod port-force-output ((port gtkairo-port)) (with-gtk () (loop for medium being each hash-key in (dirty-mediums port) do (medium-force-output medium)) (gdk_display_flush (gdk_display_get_default)) ;; Don't know whether p-f-o is actually meant to XSync, which is ;; what gdk_flush does. But it seems useful to have _some_ function ;; for this, so let's use p-f-o until we find a better one. (gdk_flush) (dribble-x-errors))) ;; FIXME: What happens when CLIM code calls tracking-pointer recursively? (defmethod port-grab-pointer ((port gtkairo-port) pointer sheet) (with-gtk () (let* ((gtkwidget (mirror-widget (sheet-direct-mirror sheet))) (status (gdk_pointer_grab (gtkwidget-gdkwindow gtkwidget) 0 (logior GDK_POINTER_MOTION_MASK GDK_BUTTON_PRESS_MASK GDK_BUTTON_RELEASE_MASK) (cffi:null-pointer) (cffi:null-pointer) GDK_CURRENT_TIME))) ;; emergency ungrab: ;;; (sb-thread:make-thread (lambda () ;;; (sleep 10) ;;; (tr :timeout!) ;;; (with-gtk () ;;; (gdk_pointer_ungrab GDK_CURRENT_TIME)))) (when (zerop status) (setf (pointer-grab-sheet port) sheet))))) (defmethod port-ungrab-pointer ((port gtkairo-port) pointer sheet) (declare (ignore pointer sheet)) (with-gtk () (when (eq (pointer-grab-sheet port) sheet) (gdk_pointer_ungrab GDK_CURRENT_TIME) (setf (pointer-grab-sheet port) nil)))) (defmethod distribute-event :around ((port gtkairo-port) event) (let ((grab-sheet (pointer-grab-sheet port))) (if grab-sheet (queue-event grab-sheet event) (call-next-method)))) (defmethod set-sheet-pointer-cursor ((port gtkairo-port) sheet cursor) ()) (defmethod bind-selection ((port gtkairo-port) window &optional time) ()) (defmethod release-selection ((port gtkairo-port) &optional time) ()) (defmethod request-selection ((port gtkairo-port) requestor time) ()) (defmethod get-selection-from-event ((port gtkairo-port) event) ()) (defmethod send-selection ((port gtkairo-port) event string) nil) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/gtkairo/keys.lisp0000640000175000017500000001305010705412616022012 0ustar pdmpdm;; autogenerated by keygen.lisp (IN-PACKAGE :CLIM-GTKAIRO) (DEFINE-KEY 0 ((0) THROW-AWAY THROW-AWAY) (T NIL NIL)) (DEFINE-KEY 32 (T :| | #\ )) (DEFINE-KEY 33 (T :! #\!)) (DEFINE-KEY 34 (T :|"| #\")) (DEFINE-KEY 35 (T :|#| #\#)) (DEFINE-KEY 36 (T :$ #\$)) (DEFINE-KEY 37 (T :% #\%)) (DEFINE-KEY 38 (T :& #\&)) (DEFINE-KEY 39 (T :|'| #\')) (DEFINE-KEY 40 (T :|(| #\()) (DEFINE-KEY 41 (T :|)| #\))) (DEFINE-KEY 42 (T :* #\*)) (DEFINE-KEY 43 (T :+ #\+)) (DEFINE-KEY 44 (T :|,| #\,)) (DEFINE-KEY 45 (T :- #\-)) (DEFINE-KEY 46 (T :|.| #\.)) (DEFINE-KEY 47 (T :/ #\/)) (DEFINE-KEY 48 (T :|0| #\0)) (DEFINE-KEY 49 (T :|1| #\1)) (DEFINE-KEY 50 (T :|2| #\2)) (DEFINE-KEY 51 (T :|3| #\3)) (DEFINE-KEY 52 (T :|4| #\4)) (DEFINE-KEY 53 (T :|5| #\5)) (DEFINE-KEY 54 (T :|6| #\6)) (DEFINE-KEY 55 (T :|7| #\7)) (DEFINE-KEY 56 (T :|8| #\8)) (DEFINE-KEY 57 (T :|9| #\9)) (DEFINE-KEY 58 (T :|:| #\:)) (DEFINE-KEY 59 (T :|;| #\;)) (DEFINE-KEY 60 (T :< #\<)) (DEFINE-KEY 61 (T := #\=)) (DEFINE-KEY 62 (T :> #\>)) (DEFINE-KEY 63 (T :? #\?)) (DEFINE-KEY 64 (T :@ #\@)) (DEFINE-KEY 65 (T :A #\A)) (DEFINE-KEY 66 (T :B #\B)) (DEFINE-KEY 67 (T :C #\C)) (DEFINE-KEY 68 (T :D #\D)) (DEFINE-KEY 69 (T :E #\E)) (DEFINE-KEY 70 (T :F #\F)) (DEFINE-KEY 71 (T :G #\G)) (DEFINE-KEY 72 (T :H #\H)) (DEFINE-KEY 73 (T :I #\I)) (DEFINE-KEY 74 (T :J #\J)) (DEFINE-KEY 75 (T :K #\K)) (DEFINE-KEY 76 (T :L #\L)) (DEFINE-KEY 77 (T :M #\M)) (DEFINE-KEY 78 (T :N #\N)) (DEFINE-KEY 79 (T :O #\O)) (DEFINE-KEY 80 (T :P #\P)) (DEFINE-KEY 81 (T :Q #\Q)) (DEFINE-KEY 82 (T :R #\R)) (DEFINE-KEY 83 (T :S #\S)) (DEFINE-KEY 84 (T :T #\T)) (DEFINE-KEY 85 (T :U #\U)) (DEFINE-KEY 86 (T :V #\V)) (DEFINE-KEY 87 (T :W #\W)) (DEFINE-KEY 88 (T :X #\X)) (DEFINE-KEY 89 (T :Y #\Y)) (DEFINE-KEY 90 (T :Z #\Z)) (DEFINE-KEY 91 (T :[ #\[)) (DEFINE-KEY 92 (T :|\\| #\\)) (DEFINE-KEY 93 (T :] #\])) (DEFINE-KEY 95 (T :_ #\_)) (DEFINE-KEY 96 (T :|`| #\`)) (DEFINE-KEY 97 (T :|a| #\a)) (DEFINE-KEY 98 (T :|b| #\b)) (DEFINE-KEY 99 (T :|c| #\c)) (DEFINE-KEY 100 (T :|d| #\d)) (DEFINE-KEY 101 (T :|e| #\e)) (DEFINE-KEY 102 (T :|f| #\f)) (DEFINE-KEY 103 (T :|g| #\g)) (DEFINE-KEY 104 (T :|h| #\h)) (DEFINE-KEY 105 (T :|i| #\i)) (DEFINE-KEY 106 (T :|j| #\j)) (DEFINE-KEY 107 (T :|k| #\k)) (DEFINE-KEY 108 (T :|l| #\l)) (DEFINE-KEY 109 (T :|m| #\m)) (DEFINE-KEY 110 (T :|n| #\n)) (DEFINE-KEY 111 (T :|o| #\o)) (DEFINE-KEY 112 (T :|p| #\p)) (DEFINE-KEY 113 (T :|q| #\q)) (DEFINE-KEY 114 (T :|r| #\r)) (DEFINE-KEY 115 (T :|s| #\s)) (DEFINE-KEY 116 (T :|t| #\t)) (DEFINE-KEY 117 (T :|u| #\u)) (DEFINE-KEY 118 (T :|v| #\v)) (DEFINE-KEY 119 (T :|w| #\w)) (DEFINE-KEY 120 (T :|x| #\x)) (DEFINE-KEY 121 (T :|y| #\y)) (DEFINE-KEY 122 (T :|z| #\z)) (DEFINE-KEY 123 (T :{ #\{)) (DEFINE-KEY 124 (T :|\|| #\|)) (DEFINE-KEY 125 (T :} #\})) (DEFINE-KEY 65056 (T :ISO-LEFT-TAB NIL)) (DEFINE-KEY 65106 (T :DEAD-CIRCUMFLEX NIL)) (DEFINE-KEY 65107 (T :DEAD-TILDE NIL)) (DEFINE-KEY 65273 (T :POINTER-ENABLE-KEYS NIL)) (DEFINE-KEY 65288 (T :BACKSPACE #\Backspace)) (DEFINE-KEY 65289 (T :TAB #\Tab)) (DEFINE-KEY 65293 (T :RETURN #\Return)) (DEFINE-KEY 65299 ((9 1) :BREAK NIL) (T :PAUSE NIL)) (DEFINE-KEY 65300 (T :SCROLL-LOCK NIL)) (DEFINE-KEY 65301 (T :SYS-REQ NIL)) (DEFINE-KEY 65307 (T :ESCAPE NIL)) (DEFINE-KEY 65312 (T :MULTI-KEY NIL)) (DEFINE-KEY 65360 (T :HOME NIL)) (DEFINE-KEY 65361 (T :LEFT NIL)) (DEFINE-KEY 65362 (T :UP NIL)) (DEFINE-KEY 65363 (T :RIGHT NIL)) (DEFINE-KEY 65364 (T :DOWN NIL)) (DEFINE-KEY 65365 (T :PRIOR NIL)) (DEFINE-KEY 65366 (T :NEXT NIL)) (DEFINE-KEY 65367 (T :END NIL)) (DEFINE-KEY 65377 ((12 4 8 0) :PRINT NIL) (T :SYS-REQ NIL)) (DEFINE-KEY 65379 (T :INSERT NIL)) (DEFINE-KEY 65383 (T :MENU NIL)) (DEFINE-KEY 65387 ((12 4) :PAUSE NIL) (T :BREAK NIL)) (DEFINE-KEY 65407 (T :NUM-LOCK NIL)) (DEFINE-KEY 65421 (T :KP-ENTER NIL)) (DEFINE-KEY 65429 (T :KP-HOME NIL)) (DEFINE-KEY 65430 (T :KP-LEFT NIL)) (DEFINE-KEY 65431 (T :KP-UP NIL)) (DEFINE-KEY 65432 (T :KP-RIGHT NIL)) (DEFINE-KEY 65433 (T :KP-DOWN NIL)) (DEFINE-KEY 65434 (T :KP-PRIOR NIL)) (DEFINE-KEY 65435 (T :KP-NEXT NIL)) (DEFINE-KEY 65436 (T :KP-END NIL)) (DEFINE-KEY 65437 (T :KP-BEGIN NIL)) (DEFINE-KEY 65438 (T :KP-INSERT NIL)) (DEFINE-KEY 65439 (T :KP-DELETE NIL)) (DEFINE-KEY 65450 (T :KP-MULTIPLY NIL)) (DEFINE-KEY 65451 (T :KP-ADD NIL)) (DEFINE-KEY 65453 (T :KP-SUBTRACT NIL)) (DEFINE-KEY 65454 (T :KP-DECIMAL NIL)) (DEFINE-KEY 65455 (T :KP-DIVIDE NIL)) (DEFINE-KEY 65456 (T :KP-0 NIL)) (DEFINE-KEY 65457 (T :KP-1 NIL)) (DEFINE-KEY 65458 (T :KP-2 NIL)) (DEFINE-KEY 65459 (T :KP-3 NIL)) (DEFINE-KEY 65460 (T :KP-4 NIL)) (DEFINE-KEY 65461 (T :KP-5 NIL)) (DEFINE-KEY 65462 (T :KP-6 NIL)) (DEFINE-KEY 65463 (T :KP-7 NIL)) (DEFINE-KEY 65464 (T :KP-8 NIL)) (DEFINE-KEY 65465 (T :KP-9 NIL)) (DEFINE-KEY 65470 (T :F1 NIL)) (DEFINE-KEY 65471 (T :F2 NIL)) (DEFINE-KEY 65472 (T :F3 NIL)) (DEFINE-KEY 65473 (T :F4 NIL)) (DEFINE-KEY 65474 (T :F5 NIL)) (DEFINE-KEY 65475 (T :F6 NIL)) (DEFINE-KEY 65476 (T :F7 NIL)) (DEFINE-KEY 65477 (T :F8 NIL)) (DEFINE-KEY 65478 (T :F9 NIL)) (DEFINE-KEY 65479 (T :F10 NIL)) (DEFINE-KEY 65480 (T :F11 NIL)) (DEFINE-KEY 65505 (T :SHIFT-LEFT NIL)) (DEFINE-KEY 65506 (T :SHIFT-RIGHT NIL)) (DEFINE-KEY 65507 (T :CONTROL-LEFT NIL)) (DEFINE-KEY 65508 (T :CONTROL-RIGHT NIL)) (DEFINE-KEY 65509 (T :CAPS-LOCK NIL)) (DEFINE-KEY 65511 (T :META-LEFT NIL)) (DEFINE-KEY 65512 (T :META-RIGHT NIL)) (DEFINE-KEY 65535 (T :DELETE #\Rubout)) (DEFINE-KEY 268828535 (T :SUN-AUDIO-LOWER-VOLUME NIL)) (DEFINE-KEY 268828536 (T :SUN-AUDIO-MUTE NIL)) (DEFINE-KEY 268828537 (T :SUN-AUDIO-RAISE-VOLUME NIL)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/gtkairo/package.lisp0000640000175000017500000000027410561555366022450 0ustar pdmpdm;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- (in-package :common-lisp-user) (defpackage :clim-gtkairo (:use :clim :clim-lisp :clim-backend) (:export #:*default-font-families*)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/gtkairo/cairo-ffi.lisp0000640000175000017500000000751210561555366022716 0ustar pdmpdm;;; -*- Mode: Lisp; -*- ;;; (c) copyright 2005 by Gilbert Baumann ;;; (c) copyright 2006 David Lichteblau (david@lichteblau.com) ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this software and associated documentation files (the ;;; "Software"), to deal in the Software without restriction, including ;;; without limitation the rights to use, copy, modify, merge, publish, ;;; distribute, sublicense, and/or sell copies of the Software, and to ;;; permit persons to whom the Software is furnished to do so, subject to ;;; the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. ;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY ;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, ;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. (in-package :clim-gtkairo) (defmacro def-cairo-fun (name rtype &rest args) (let* (#-scl (str (string-upcase name)) #+scl (str (if (eq ext:*case-mode* :upper) (string-upcase name) (string-downcase name))) (actual (intern (concatenate 'string "%-" str) :clim-gtkairo)) (wrapper (intern str :clim-gtkairo)) (argnames (mapcar #'car args))) `(progn (cffi:defcfun (,name ,actual) ,rtype ,@args) (defun ,wrapper ,argnames (multiple-value-prog1 (,actual ,@argnames) (let ((status (cairo_status ,(car argnames)))) (unless (eq status :success) (error "~A returned with status ~A" ,name status)))))))) ;; user-visible structures (cffi:defcstruct cairo_text_extents (x_bearing :double) (y_bearing :double) (width :double) (height :double) (x_advance :double) (y_advance :double)) (cffi:defcstruct cairo_font_extents (ascent :double) (descent :double) (height :double) (max_x_advance :double) (max_y_advance :double)) (cffi:defcstruct cairo_glyph (index :unsigned-int) (x :double) (y :double)) (cffi:defcstruct cairo_matrix_t (xx :double) (yx :double) (xy :double) (yy :double) (x0 :double) (y0 :double)) ;; enums ;; (can't look these up yet, why?) (cffi:defcenum cairo_format_t :argb32 :rgb24 :a8 :a1) (cffi:defcenum cairo_operator_t :clear :src :over :in :out :atop :dest :dest_over :dest_in :dest_out :dest_atop :xor :add :saturate) (cffi:defcenum cairo_fill_rule_t :winding :even_odd) (cffi:defcenum cairo_line_cap_t :butt :round :square) (cffi:defcenum cairo_line_join_t :miter :round :bevel) (cffi:defcenum cairo_font_slant_t :normal :italic :oblique) (cffi:defcenum cairo_font_weight_t :normal :bold) (cffi:defcenum cairo_status_t :success :no_memory :invalid_restore :invalid_pop_group :no_current_point :invalid_matrix :invalid_status :null_pointer :invalid_string :invalid_path_data :read_error :write_error :surface_finished :surface_type_mismatch :pattern_type_mismatch :invalid_content :invalid_format :invalid_visual :file_not_found :invalid_dash) (cffi:defcenum cairo_filter_t :fast :good :best :nearest :bilinear :gaussian) (cffi:defcenum cairo_extend_t :none :repeat :reflect) (cffi:defcenum cairo_content_t (:cairo_content_color #x1000) (:cairo_content_alpha #x2000) (:cairo_content_color_alpha #x3000)) (cffi:defcenum cairo_antialias_t :CAIRO_ANTIALIAS_DEFAULT :CAIRO_ANTIALIAS_NONE :CAIRO_ANTIALIAS_GRAY :CAIRO_ANTIALIAS_SUBPIXEL) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/gtkairo/gadgets.lisp0000640000175000017500000007436410705412615022473 0ustar pdmpdm;;; -*- Mode: Lisp; -*- ;;; (c) 2006 David Lichteblau (david@lichteblau.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-gtkairo) (defclass gadget-event (window-event) ()) (defclass magic-gadget-event (gadget-event) ()) (defclass scrollbar-change-value-event (gadget-event) ((scroll-type :initarg :scroll-type :accessor event-scroll-type) (value :initarg :value :accessor event-value))) (defclass menu-clicked-event (gadget-event) ((item :initarg :item :accessor event-item))) (defclass context-menu-clicked-event (gadget-event) ((value :initarg :value :accessor event-value) (itemspec :initarg :itemspec :accessor event-itemspec))) (defclass context-menu-cancelled-event (gadget-event) ()) (defclass list-selection-event (gadget-event) ()) (defclass tab-button-event (gadget-event) ((page :initarg :page :accessor event-page) (button :initarg :button :accessor event-button))) (defclass tab-press-event (tab-button-event) ()) (defclass tab-release-event (tab-button-event) ()) ;;;; Classes ;; gtk-menu-* see port.lisp (defclass gtk-button (native-widget-mixin push-button) ()) (defclass gtk-check-button (native-widget-mixin toggle-button) ()) (defclass gtk-radio-button (native-widget-mixin toggle-button) ()) (defclass gtk-list (native-widget-mixin list-pane climi::meta-list-pane) ((title :initarg :title :initform "" :accessor list-pane-title) (tree-view :accessor list-pane-tree-view)) ;; fixme? (:default-initargs :value nil)) (defclass gtk-option-pane (native-widget-mixin option-pane climi::meta-list-pane) ()) (defclass native-slider (native-widget-mixin climi::slider-gadget) ((climi::show-value-p :type boolean :initform nil :initarg :show-value-p :accessor climi::gadget-show-value-p) (climi::decimal-places :initform 0 :initarg :decimal-places :reader climi::slider-decimal-places) (climi::number-of-quanta :initform nil :initarg :number-of-quanta :reader climi::slider-number-of-quanta))) (defclass gtk-vscale (native-slider) ()) (defclass gtk-hscale (native-slider) ()) (defclass native-scrollbar (native-widget-mixin scroll-bar) ()) (defclass gtk-vscrollbar (native-scrollbar) ()) (defclass gtk-hscrollbar (native-scrollbar) ()) (defclass gtk-label-pane (native-widget-mixin label-pane) ((label-pane-fixed :accessor label-pane-fixed) (label-pane-extra-width :accessor label-pane-extra-width) (label-pane-extra-height :accessor label-pane-extra-height))) (defclass gtk-tab-layout (native-widget-mixin clim-tab-layout:tab-layout) ((tab-layout-extra-width :accessor tab-layout-extra-width) (tab-layout-extra-height :accessor tab-layout-extra-height))) ;;;; Constructors (defmethod realize-native-widget ((sheet gtk-button)) (let ((button (gtk_button_new_with_label (climi::gadget-label sheet)))) (when (pane-background sheet) (gtk-widget-modify-bg button (pane-background sheet))) button)) (defmethod realize-native-widget ((sheet gtk-menu-bar)) (gtk_menu_bar_new)) (defmethod realize-native-widget ((sheet gtk-check-button)) (let ((widget (gtk_check_button_new_with_label (climi::gadget-label sheet)))) (gtk_toggle_button_set_active widget (if (gadget-value sheet) 1 0)) widget)) (defmethod realize-native-widget ((sheet gtk-label-pane)) (let ((frame (gtk_frame_new (climi::label-pane-label sheet))) (fixed (gtk_fixed_new)) (child (car (sheet-children sheet)))) (gtk_container_add frame fixed) (gtk_widget_show fixed) (when child (let* ((q (compose-space child)) (width1 (space-requirement-width q)) (height1 (space-requirement-height q))) (gtk_widget_set_size_request fixed width1 height1) (cffi:with-foreign-object (r 'gtkrequisition) (gtk_widget_size_request frame r) (cffi:with-foreign-slots ((width height) r gtkrequisition) (setf (label-pane-extra-width sheet) (- width width1)) (setf (label-pane-extra-height sheet) (- height height1)))))) (setf (label-pane-fixed sheet) fixed) frame)) (defmethod container-put ((parent gtk-label-pane) parent-widget child x y) (declare (ignore parent-widget)) (gtk_fixed_put (label-pane-fixed parent) child x y)) (defmethod container-move ((parent gtk-label-pane) parent-widget child x y) (declare (ignore parent-widget)) (gtk_fixed_move (label-pane-fixed parent) child x y)) (defconstant +g-type-string+ (ash 16 2)) (defun uninstall-scroller-pane (pane) (with-slots (climi::scroll-bar climi::vscrollbar climi::hscrollbar climi::x-spacing climi::y-spacing) pane (setf scroll-bar nil) (when climi::vscrollbar (sheet-disown-child pane climi::vscrollbar) (setf climi::vscrollbar nil)) (when climi::hscrollbar (sheet-disown-child pane climi::hscrollbar) (setf climi::hscrollbar nil)) (setf climi::x-spacing 0) (setf climi::y-spacing 0) (let ((r (sheet-region pane))) (allocate-space pane (bounding-rectangle-width r) (bounding-rectangle-height r))))) (defun list-pane-selection (sheet) (gtk_tree_view_get_selection (list-pane-tree-view sheet))) (defmethod realize-native-widget ((sheet gtk-list)) (cffi:with-foreign-object (types :ulong 2) (setf (cffi:mem-aref types :long 0) +g-type-string+) (setf (cffi:mem-aref types :long 1) 0) (let* ((model (gtk_list_store_newv 1 types)) (tv (gtk_tree_view_new_with_model model)) (column (gtk_tree_view_column_new)) (renderer (gtk_cell_renderer_text_new))) (setf (list-pane-tree-view sheet) tv) (gtk_tree_view_column_pack_start column renderer 1) (gtk_tree_view_insert_column tv column -1) (gtk_tree_view_column_add_attribute column renderer "text" 0) (gtk_tree_view_column_set_title column (list-pane-title sheet)) (reset-list-pane-items sheet) (gtk_tree_selection_set_mode (list-pane-selection sheet) (if (eq (climi::list-pane-mode sheet) :exclusive) :GTK_SELECTION_BROWSE :GTK_SELECTION_MULTIPLE)) (gtk-list-reset-selection sheet) (let ((ancestor (and (sheet-parent sheet) (sheet-parent (sheet-parent sheet)))) (result tv)) (when (typep ancestor 'scroller-pane) (uninstall-scroller-pane ancestor)) (let ((wrapper (gtk_scrolled_window_new (gtk_tree_view_get_hadjustment tv) (gtk_tree_view_get_vadjustment tv)))) (gtk_scrolled_window_set_policy wrapper GTK_POLICY_AUTOMATIC GTK_POLICY_AUTOMATIC) (gtk_container_add wrapper tv) (setf result wrapper)) (setf (list-pane-tree-view sheet) tv) ;?! (gtk_tree_selection_set_select_function (list-pane-selection sheet) (cffi:get-callback 'view-selection-callback) result (cffi:null-pointer)) result)))) (defun reset-list-pane-items (sheet) (let ((model (gtk_tree_view_get_model (list-pane-tree-view sheet))) (name-key (climi::list-pane-name-key sheet))) (gtk_list_store_clear model) (cffi:with-foreign-object (&iter 'gtktreeiter) (dolist (i (climi::list-pane-items sheet)) (gtk_list_store_append model &iter) (cffi:with-foreign-string (n (funcall name-key i) :encoding :utf-8) (cffi:with-foreign-object (&value 'gvalue) (setf (cffi:foreign-slot-value &value 'gvalue 'type) 0) (g_value_init &value +g-type-string+) (g_value_set_string &value n) (gtk_list_store_set_value model &iter 0 &value))))))) (defmethod realize-native-widget ((sheet gtk-option-pane)) (let* ((widget (gtk_combo_box_new_text)) (name-key (climi::list-pane-name-key sheet))) (dolist (i (climi::list-pane-items sheet)) (cffi:with-foreign-string (n (funcall name-key i) :encoding :utf-8) (gtk_combo_box_append_text widget n))) (option-pane-set-active sheet widget) widget)) (defun gtk-list-select-value (sheet value) (let ((path (gtk_tree_path_new_from_indices (position value (climi::list-pane-items sheet) :key (climi::list-pane-value-key sheet) :test (climi::list-pane-test sheet)) :int -1))) (gtk_tree_selection_select_path (list-pane-selection sheet) path) (gtk_tree_path_free path))) (defun gtk-list-reset-selection (sheet) (gtk_tree_selection_unselect_all (list-pane-selection sheet)) (let ((value (gadget-value sheet))) (if (eq (climi::list-pane-mode sheet) :exclusive) (when value ;fixme? (gtk-list-select-value sheet value)) (dolist (v value) (gtk-list-select-value sheet v))))) (defmethod (setf gadget-value) :after (value (gadget gtk-list) &key invoke-callback) (declare (ignore invoke-callback)) (with-gtk () (let ((mirror (sheet-direct-mirror gadget))) (when mirror (gtk-list-reset-selection gadget))))) (defmethod (setf climi::list-pane-items) (newval (pane gtk-list) &key invoke-callback) (declare (ignore invoke-callback)) (call-next-method) (with-gtk () (reset-list-pane-items pane))) (defmethod climi::generic-list-pane-item-values ((pane gtk-list)) (mapcar (climi::list-pane-value-key pane) (climi::list-pane-items pane))) (defmethod handle-event-p ((pane gtk-list) (event pointer-button-press-event)) (eql (pointer-event-button event) +pointer-right-button+)) (defun gtk-list-one-value (pane) (if (eq (climi::list-pane-mode pane) :exclusive) (if (and (slot-boundp pane 'climi::value) ;; FIXME: we still assume NIL == no value (gadget-value pane)) (values (gadget-value pane) t) (values nil nil)) (if (and (slot-boundp pane 'climi::value) (eql 1 (length (gadget-value pane)))) (values (car (gadget-value pane)) t) (values nil nil)))) (defmethod handle-event ((pane gtk-list) (event pointer-button-press-event)) (multiple-value-bind (value valuep) (gtk-list-one-value pane) (when valuep (let* ((i (position value (climi::generic-list-pane-item-values pane))) (item (elt (climi::list-pane-items pane) i))) (climi::meta-list-pane-call-presentation-menu pane item))))) (defmethod handle-event-p ((pane gtk-list) (event pointer-button-release-event)) nil) (defmethod realize-native-widget ((sheet gtk-tab-layout)) (let ((result (gtk_notebook_new)) (dummy-child (gtk_fixed_new)) (dummy-label (gtk_label_new "foo"))) (gtk_notebook_append_page result dummy-child dummy-label) (gtk_widget_show dummy-child) (let* ((q (reduce (lambda (x y) (space-requirement-combine #'max x y)) (mapcar #'compose-space (sheet-children sheet)) :initial-value (make-space-requirement :width 0 :min-width 0 :max-width 0 :height 0 :min-height 0 :max-height 0))) (width1 (space-requirement-width q)) (height1 (space-requirement-height q))) (gtk_widget_set_size_request dummy-child width1 height1) (cffi:with-foreign-object (r 'gtkrequisition) (gtk_widget_size_request result r) (cffi:with-foreign-slots ((width height) r gtkrequisition) (setf (tab-layout-extra-width sheet) (- width width1)) (setf (tab-layout-extra-height sheet) (- height height1)))) (gtk_notebook_remove_page result 0)) result)) (defmethod container-put ((parent gtk-tab-layout) parent-widget child x y) (declare (ignore x y)) (let* ((page (clim-tab-layout:sheet-to-page (widget->sheet child (port parent)))) (index (position page (clim-tab-layout:tab-layout-pages parent))) (label (gtk_label_new (clim-tab-layout:tab-page-title page))) (box (gtk_event_box_new))) (gtk_event_box_set_visible_window box 0) (gtk_container_add box label) (gtk_widget_show_all box) ;; naja, ein sheet ist das nicht (setf (widget->sheet box (port parent)) page) (connect-signal box "button-press-event" 'tab-button-handler) (gtk_widget_show child) (gtk_notebook_insert_page parent-widget child box index) (set-tab-page-attributes page label) ;; fixme: (reorder-notebook-pages parent) (setf (clim-tab-layout:tab-layout-enabled-page parent) (clim-tab-layout:tab-layout-enabled-page parent)))) (defmethod (setf clim-tab-layout:tab-layout-pages) :after (newval (parent gtk-tab-layout)) (declare (ignore newval)) (reorder-notebook-pages parent)) (defun reorder-notebook-pages (parent) (loop for page in (clim-tab-layout:tab-layout-pages parent) for i from 0 do (let* ((pane (clim-tab-layout:tab-page-pane page)) (mirror (climi::port-lookup-mirror (port parent) pane))) (when mirror (gtk_notebook_reorder_child (native-widget parent) (mirror-widget mirror) i))))) (defmethod container-move ((parent gtk-tab-layout) parent-widget child x y) (declare (ignore parent-widget child x y))) (defmethod allocate-space ((pane gtk-tab-layout) width height) (dolist (page (clim-tab-layout:tab-layout-pages pane)) (let ((child (clim-tab-layout:tab-page-pane page))) (move-sheet child 0 0) ;dummy (allocate-space child (- width (tab-layout-extra-width pane)) (- height (tab-layout-extra-height pane)))))) (defmethod allocate-space :around ((pane gtk-tab-layout) width height) ;; ARGH! Force the around method in panes.lisp to c-n-m. (setf (climi::pane-current-width pane) nil) (call-next-method)) (defmethod (setf clim-tab-layout:tab-layout-enabled-page) :after (newval (parent gtk-tab-layout)) (when (and (native-widget parent) newval) ;; fixme: (reorder-notebook-pages parent) (gtk_notebook_set_current_page (native-widget parent) (position newval (clim-tab-layout:tab-layout-pages parent))))) (defun option-pane-set-active (sheet widget) (gtk_combo_box_set_active widget (position (gadget-value sheet) (climi::list-pane-items sheet) :key (climi::list-pane-value-key sheet) :test (climi::list-pane-test sheet)))) (defmethod (setf gadget-value) :after (value (gadget gtk-option-pane) &key invoke-callback) (declare (ignore invoke-callback)) (with-gtk () (let ((mirror (sheet-direct-mirror gadget))) (when mirror (option-pane-set-active gadget (mirror-widget mirror)))))) (defun make-scale (fn sheet) (let* ((min (df (gadget-min-value sheet))) (max (df (gadget-max-value sheet))) (n (or (climi::slider-number-of-quanta sheet) 100)) (widget (funcall fn min max (/ (- max min) n)))) (gtk_scale_set_digits widget (climi::slider-decimal-places sheet)) (gtk_scale_set_draw_value widget (if (climi::gadget-show-value-p sheet) 1 0)) (gtk_adjustment_set_value (gtk_range_get_adjustment widget) (df (gadget-value sheet))) widget)) (defmethod realize-native-widget ((sheet gtk-vscale)) (make-scale #'gtk_vscale_new_with_range sheet)) (defmethod realize-native-widget ((sheet gtk-hscale)) (make-scale #'gtk_hscale_new_with_range sheet)) (defun make-scrollbar (fn sheet) (let* ((min (df (gadget-min-value sheet))) (page-size (df (climi::scroll-bar-thumb-size sheet))) (max (+ (df (gadget-max-value sheet)) page-size)) (adjustment (gtk_adjustment_new 0.0d0 min max 0.0d0 0.0d0 page-size))) (gtk_adjustment_set_value adjustment (df (gadget-value sheet))) (funcall fn adjustment))) (defmethod realize-native-widget ((sheet gtk-vscrollbar)) (make-scrollbar #'gtk_vscrollbar_new sheet)) (defmethod realize-native-widget ((sheet gtk-hscrollbar)) (make-scrollbar #'gtk_hscrollbar_new sheet)) (defmethod realize-native-widget ((sheet gtk-radio-button)) (let* ((first (some #'sheet-direct-mirror (sheet-children (gadget-client sheet)))) (group (if first (gtk_radio_button_get_group (mirror-widget first)) (cffi:null-pointer))) (result (gtk_radio_button_new_with_label group (climi::gadget-label sheet)))) (gtk_toggle_button_set_active result (if (eq sheet (gadget-value (gadget-client sheet))) 1 0)) result)) (defun append-menu-items (port sheet menu command-table-name) (let ((ct (find-command-table command-table-name))) (dolist (menu-item (slot-value ct 'climi::menu)) (let ((item (make-native-menu-item port sheet menu-item))) (gtk_menu_shell_append menu item))))) (defun make-native-menu-item (port sheet menu-item) (ecase (command-menu-item-type menu-item) (:divider (gtk_separator_menu_item_new)) (:command (let ((item (gtk_menu_item_new_with_label (climi::command-menu-item-name menu-item)))) ;; naja, ein sheet ist das nicht (setf (widget->sheet item port) menu-item) (connect-signal item "activate" 'menu-clicked-handler) item)) (:menu (let ((item (gtk_menu_item_new_with_label (climi::command-menu-item-name menu-item))) (menu (gtk_menu_new))) (setf (widget->sheet item port) sheet) (setf (widget->sheet menu port) sheet) (append-menu-items port sheet menu (command-menu-item-value menu-item)) (gtk_menu_item_set_submenu item menu) item)))) (defun destructure-mc-menu-item (x) (cond ((atom x) (values :item x x nil)) ((atom (cdr x)) (values :item (car x) (cdr x) nil)) (t (destructuring-bind (&key value style items documentation active type) (cdr x) (declare (ignore style documentation active)) (values (cond (items :menu) (type) (t :item)) (car x) (or value (car x)) items))))) ;;(defclass dummy-context-menu-sheet (climi::clim-sheet-input-mixin sheet) ()) (defclass dummy-context-menu-sheet (climi::standard-sheet-input-mixin sheet) ()) (defclass dummy-menu-item-sheet (sheet) ((parent :initarg :parent :accessor dummy-menu-item-sheet-parent) (value :initarg :value :accessor dummy-menu-item-sheet-value) (itemspec :initarg :itemspec :accessor dummy-menu-item-sheet-itemspec))) (defun make-context-menu (port sheet items &key printer) (let ((menu (gtk_menu_new))) (dolist (itemspec items) (multiple-value-bind (type display-object value sub-items) (destructure-mc-menu-item itemspec) (let* ((label (with-output-to-string (s) (funcall (or printer #'print-menu-item) display-object s))) (gtkmenuitem (ecase type (:divider (gtk_separator_menu_item_new)) (:label (gtk_menu_item_new_with_label label)) (:item (let ((item (gtk_menu_item_new_with_label label))) (setf (widget->sheet item port) (make-instance 'dummy-menu-item-sheet :parent sheet :value value :itemspec itemspec)) (connect-signal item "activate" 'context-menu-clicked-handler) item)) (:menu (let ((item (gtk_menu_item_new_with_label label)) (menu (make-context-menu port sheet sub-items))) (gtk_menu_item_set_submenu item menu) item))))) (gtk_menu_shell_append menu gtkmenuitem)))) (setf (widget->sheet menu port) sheet) (connect-signal menu "deactivate" 'popup-deactivated-handler) (gtk_widget_show_all menu) menu)) ;;;; Event definition (defmethod connect-native-signals ((sheet native-widget-mixin) widget) (connect-signal widget "clicked" 'magic-clicked-handler)) (defmethod connect-native-signals ((sheet native-slider) widget) (connect-signal widget "value-changed" 'magic-clicked-handler)) (defmethod connect-native-signals ((sheet native-scrollbar) widget) ;; (connect-signal widget "value-changed" 'magic-clicked-handler) (connect-signal widget "change-value" 'scrollbar-change-value-handler)) (defmethod connect-native-signals ((sheet gtk-menu-bar) widget) ;; no signals ) (defmethod connect-native-signals ((sheet gtk-list) widget) (setf (widget->sheet (list-pane-tree-view sheet) (port sheet)) sheet) (connect-signal (list-pane-tree-view sheet) "button-press-event" 'button-handler)) (defmethod connect-native-signals ((sheet gtk-label-pane) widget) ;; no signals ) (defmethod connect-native-signals ((sheet gtk-tab-layout) widget) ;; no signals ) (defmethod connect-native-signals ((sheet gtk-option-pane) widget) (connect-signal widget "changed" 'magic-clicked-handler)) ;;;; Event handling (defmethod handle-event ((pane gtk-button) (event magic-gadget-event)) (activate-callback pane (gadget-client pane) (gadget-id pane))) (defmethod handle-event ((pane gtk-check-button) (event magic-gadget-event)) (setf (gadget-value pane :invoke-callback t) (not (gadget-value pane)))) (defmethod handle-event ((pane gtk-radio-button) (event magic-gadget-event)) (setf (gadget-value pane :invoke-callback t) (not (gadget-value pane)))) (defmethod handle-event ((pane native-slider) (event magic-gadget-event)) (setf (gadget-value pane :invoke-callback t) (gtk_range_get_value (mirror-widget (sheet-direct-mirror pane))))) (defmethod handle-event ((pane native-scrollbar) (event magic-gadget-event)) (setf (gadget-value pane :invoke-callback t) (gtk_range_get_value (mirror-widget (sheet-direct-mirror pane))))) (defun clamp (low x hi) (min (max low x) hi)) (defmethod handle-event ((pane native-scrollbar) (event scrollbar-change-value-event)) (case (event-scroll-type event) (:gtk_scroll_jump (let ((value (clamp (gadget-min-value pane) (event-value event) (gadget-max-value pane)))) (setf (gadget-value pane :invoke-callback nil) value) (drag-callback pane (gadget-client pane) (gadget-id pane) value))) (:gtk_scroll_step_backward (scroll-up-line-callback pane (gadget-client pane) (gadget-id pane))) (:gtk_scroll_step_forward (scroll-down-line-callback pane (gadget-client pane) (gadget-id pane))) (:gtk_scroll_page_backward (scroll-up-page-callback pane (gadget-client pane) (gadget-id pane))) (:gtk_scroll_page_forward (scroll-down-page-callback pane (gadget-client pane) (gadget-id pane))))) (defmethod handle-event ((pane gtk-menu) (event menu-clicked-event)) (let ((item (event-item event))) (ecase (command-menu-item-type item) (:command (climi::throw-object-ptype item 'menu-item))))) ;;;(defmethod handle-event ;;; ((pane gtk-tab-layout) (event tab-release-event)) ;;; ) (defclass parent-ad-hoc-presentation (climi::ad-hoc-presentation) ((ad-hoc-children :initarg :ad-hoc-children :reader output-record-children))) (defmethod clim-tab-layout:note-tab-page-changed ((layout gtk-tab-layout) page) (with-gtk () (let* ((pane (clim-tab-layout:tab-page-pane page)) (mirror (climi::port-lookup-mirror (port layout) pane))) (when mirror (let ((box (gtk_notebook_get_tab_label (native-widget layout) (mirror-widget mirror)))) (set-tab-page-attributes page (gtk_bin_get_child box))))))) (defun set-tab-page-attributes (page label) ;; fixme: wieso funktioniert das in der tabdemo, nicht aber in beirc? (let ((ink (getf (clim-tab-layout:tab-page-drawing-options page) :ink))) (when ink (gtk-widget-modify-fg label ink))) (gtk_label_set_text label (clim-tab-layout:tab-page-title page)) (gtk_widget_queue_draw label)) (defmethod handle-event ((pane gtk-tab-layout) (event tab-press-event)) (let* ((page (event-page event)) (ptype (clim-tab-layout:tab-page-presentation-type page)) (inner-presentation (make-instance 'climi::ad-hoc-presentation :object page :single-box t :type 'clim-tab-layout:tab-page)) (presentation (make-instance 'parent-ad-hoc-presentation :ad-hoc-children (vector inner-presentation) :object page :single-box t :type ptype))) (case (event-button event) (#.+pointer-right-button+ (call-presentation-menu presentation *input-context* *application-frame* pane 42 42 :for-menu t :label (format nil "Operation on ~A" ptype))) (#.+pointer-left-button+ (throw-highlighted-presentation presentation *input-context* (make-instance 'pointer-button-press-event :sheet pane :x 42 :y 42 :modifier-state 0 :button (event-button event))))))) (defmethod handle-event ((pane gtk-nonmenu) (event magic-gadget-event)) (funcall (gtk-nonmenu-callback pane) pane nil)) (defvar *list-selection-result*) (cffi:defcallback list-selection-callback :void ((model :pointer) (path :pointer) (iter :pointer) (data :pointer)) model iter data (setf (gethash (cffi:mem-ref (gtk_tree_path_get_indices path) :int 0) *list-selection-result*) t)) (defmethod handle-event ((pane gtk-list) (event list-selection-event)) (with-gtk () (let ((*list-selection-result* (make-hash-table)) (value-key (climi::list-pane-value-key pane))) (gtk_tree_selection_selected_foreach (list-pane-selection pane) (cffi:get-callback 'list-selection-callback) (cffi:null-pointer)) (setf (gadget-value pane :invoke-callback t) (if (eq (climi::list-pane-mode pane) :exclusive) (loop for i being each hash-key in *list-selection-result* do (return (funcall value-key (elt (climi::list-pane-items pane) i)))) (loop for i from 0 for value in (climi::list-pane-items pane) when (gethash i *list-selection-result*) collect (funcall value-key value))))))) (defmethod handle-event ((pane gtk-option-pane) (event magic-gadget-event)) (setf (gadget-value pane :invoke-callback t) (funcall (climi::list-pane-value-key pane) (elt (climi::list-pane-items pane) (gtk_combo_box_get_active (mirror-widget (sheet-direct-mirror pane))))))) ;;; COMPOSE-SPACE ;; KLUDGE: this is getting called before the sheet has been realized. (defmethod compose-space ((gadget native-widget-mixin) &key width height) (declare (ignore width height)) (let* ((widget (native-widget gadget)) (widgetp widget)) (unless widgetp (setf widget (realize-native-widget gadget))) (prog1 (cffi:with-foreign-object (r 'gtkrequisition) (gtk_widget_size_request widget r) (cffi:with-foreign-slots ((width height) r gtkrequisition) (make-space-requirement :width width :height height))) (unless widgetp (gtk_widget_destroy widget) (setf (native-widget gadget) nil))))) (defmethod compose-space ((gadget gtk-menu-bar) &key width height) (declare (ignore width height)) (let* ((widget (native-widget gadget)) (widgetp widget) (item nil)) (unless widgetp (setf widget (realize-native-widget gadget)) (setf item (gtk_menu_item_new_with_label "foo")) (gtk_menu_shell_append widget item) (gtk_widget_show_all widget)) (prog1 (cffi:with-foreign-object (r 'gtkrequisition) (gtk_widget_size_request widget r) (cffi:with-foreign-slots ((height) r gtkrequisition) (make-space-requirement :height height :min-height height :max-height height))) (unless widgetp (gtk_widget_destroy widget) (setf (native-widget gadget) nil))))) (defmethod allocate-space ((pane gtk-label-pane) width height) (when (sheet-children pane) (move-sheet (first (sheet-children pane)) 0 0) (allocate-space (first (sheet-children pane)) (- width (label-pane-extra-width pane)) (- height (label-pane-extra-height pane))))) ;;; Vermischtes (defmethod (setf gadget-value) :after (value (gadget native-slider) &key invoke-callback) (declare (ignore invoke-callback)) (with-gtk () (let ((mirror (sheet-direct-mirror gadget))) (when mirror ;; see hack in magic-clicked-handler (gtk_adjustment_set_value (gtk_range_get_adjustment (mirror-widget mirror)) (df value)))))) (defmethod (setf gadget-value) :after (value (gadget gtk-radio-button) &key invoke-callback) (declare (ignore invoke-callback)) (with-gtk () (let ((mirror (sheet-direct-mirror gadget))) (when mirror ;; see hack in magic-clicked-handler (gtk_toggle_button_set_active (mirror-widget mirror) (if value 1 0)))))) (defmethod (setf gadget-value) :after (value (gadget gtk-check-button) &key invoke-callback) (declare (ignore invoke-callback)) (with-gtk () (let ((mirror (sheet-direct-mirror gadget))) (when mirror ;; see hack in magic-clicked-handler (gtk_toggle_button_set_active (mirror-widget mirror) (if value 1 0)))))) (defmethod realize-native-widget :around ((gadget native-widget-mixin)) (let ((widget (call-next-method))) (when (typep gadget 'gadget) (gtk_widget_set_sensitive widget (if (gadget-active-p gadget) 1 0))) widget)) (defmethod activate-gadget :after ((gadget native-widget-mixin)) (with-gtk () (when (native-widget gadget) (gtk_widget_set_sensitive (native-widget gadget) 1)))) (defmethod deactivate-gadget :after ((gadget native-widget-mixin)) (with-gtk () (when (native-widget gadget) (gtk_widget_set_sensitive (native-widget gadget) 0)))) ;;; Scroll bars. ;; This is all totally broken. Why does thumb-size default to 1/4 when it's ;; not a ratio but given in value units? Why is min==max all the time? ;; And why doesn't this work! :-( (defun update-scrollbar-adjustment (sheet) (when (sheet-direct-mirror sheet) (with-gtk () (let* ((min (df (gadget-min-value sheet))) (value (df (gadget-value sheet))) (page-size (df (climi::scroll-bar-thumb-size sheet))) (max (+ (df (gadget-max-value sheet)) page-size))) (gtk_range_set_adjustment (mirror-widget (sheet-direct-mirror sheet)) (gtk_adjustment_new value min max 0.0d0 0.0d0 page-size)))))) (defmethod (setf gadget-min-value) :after (new-value (pane native-scrollbar)) (declare (ignore new-value)) (update-scrollbar-adjustment pane)) (defmethod (setf gadget-max-value) :after (new-value (pane native-scrollbar)) (declare (ignore new-value)) (update-scrollbar-adjustment pane)) (defmethod (setf gadget-value) :after (new-value (pane native-scrollbar) &key invoke-callback) (declare (ignore new-value invoke-callback)) (update-scrollbar-adjustment pane)) (climi::defmethod* (setf climi::scroll-bar-values) (min-value max-value thumb-size value (scroll-bar native-scrollbar)) (setf (slot-value scroll-bar 'climi::min-value) min-value (slot-value scroll-bar 'climi::max-value) max-value (slot-value scroll-bar 'climi::thumb-size) thumb-size (slot-value scroll-bar 'climi::value) value) (update-scrollbar-adjustment scroll-bar)) (defmethod port-set-mirror-region :after ((port gtkairo-port) (mirror native-scrollbar) mirror-region) (update-scrollbar-adjustment (widget->sheet (mirror-widget mirror) port))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/gtkairo/frame-manager.lisp0000640000175000017500000001434710561555366023565 0ustar pdmpdm;;; -*- Mode: Lisp; -*- ;;; (c) 2006 David Lichteblau (david@lichteblau.com) ;;; based on the null backend by: ;;; (c) 2005 Christophe Rhodes (c.rhodes@gold.ac.uk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-gtkairo) (defclass gtkairo-frame-manager (frame-manager) ()) ;; fixme! we're supposed to dispatch on the abstract name, not resolve ;; it to the (incorrect) concrete generic class name and dispatch on that. (defun resolve-abstract-pane-name (type) (when (get type 'climi::concrete-pane-class-name) (setf type (get type 'climi::concrete-pane-class-name))) (class-name (or (find-class (intern (concatenate 'string (symbol-name type) "-PANE") :climi) nil) (if (keywordp type) (find-class (intern (symbol-name type) :climi)) (find-class type))))) (defmethod make-pane-1 ((fm gtkairo-frame-manager) (frame application-frame) type &rest initargs) (apply #'make-pane-2 (resolve-abstract-pane-name type) :frame frame :manager fm :port (port frame) initargs)) ;; make CMUCL happy (defgeneric make-pane-2 (type &rest args &key &allow-other-keys)) (defmethod make-pane-2 (type &rest initargs) (apply #'make-instance type initargs)) (defmethod make-pane-2 ((type (eql 'push-button-pane)) &rest initargs) (apply #'make-instance 'gtk-button initargs)) (defmethod make-pane-2 ((type (eql 'climi::menu-button-leaf-pane)) &rest initargs) (apply #'make-instance 'gtk-nonmenu initargs)) (defmethod make-pane-2 ((type (eql 'climi::menu-button-submenu-pane)) &rest initargs) (apply #'make-instance 'gtk-menu initargs)) (defmethod make-pane-2 ((type (eql 'climi::menu-bar)) &rest initargs) (apply #'make-instance 'gtk-menu-bar initargs)) ;;;(defmethod make-pane-2 ((type (eql 'clim:check-box-pane)) &rest initargs) ;;; (apply #'make-instance gtkairo-check-box-pane initargs)) ;;;(defmethod make-pane-2 ((type (eql 'clim:radio-box-pane)) &rest initargs) ;;; (apply #'make-instance gtkairo-radio-box-pane initargs)) (defmethod make-pane-2 ((type (eql 'clim:slider-pane)) &rest initargs &key orientation) (apply #'make-instance (if (eq orientation :vertical) 'gtk-vscale 'gtk-hscale) initargs)) (defmethod make-pane-2 ((type (eql 'clim:scroll-bar-pane)) &rest initargs &key orientation) (apply #'make-instance (if (eq orientation :vertical) 'gtk-vscrollbar 'gtk-hscrollbar) initargs)) (defmethod make-pane-2 ((type (eql 'clim:toggle-button-pane)) &rest initargs &key indicator-type) (apply #'make-instance (ecase indicator-type (:one-of 'gtk-radio-button) ((:some-of nil) 'gtk-check-button)) initargs)) (defmethod make-pane-2 ((type (eql 'clim:generic-list-pane)) &rest initargs) (apply #'make-instance 'gtk-list initargs)) (defmethod make-pane-2 ((type (eql 'clim-tab-layout:tab-layout-pane)) &rest initargs) (apply #'make-instance 'gtk-tab-layout initargs)) (defmethod make-pane-2 ((type (eql 'clim:label-pane)) &rest initargs) (apply #'make-instance 'gtk-label-pane initargs)) (defmethod make-pane-2 ((type (eql 'clim:generic-option-pane)) &rest initargs) (apply #'make-instance 'gtk-option-pane initargs)) (defmethod adopt-frame :after ((fm gtkairo-frame-manager) (frame application-frame)) ()) (defmethod note-space-requirements-changed :after ((graft gtkairo-graft) pane) ()) ;;; ";; Temporary kludge." says the CLX backend. Ha-ha. (defmethod adopt-frame :before ((fm gtkairo-frame-manager) (frame climi::menu-frame)) (when (eq (slot-value frame 'climi::top) nil) (multiple-value-bind (x y) (%gdk-display-get-pointer) (setf (slot-value frame 'climi::left) x (slot-value frame 'climi::top) y)))) (defmethod adopt-frame :after ((fm gtkairo-frame-manager) (frame climi::menu-frame)) (port-enable-sheet (car climi::*all-ports*) (slot-value frame 'climi::top-level-sheet))) (defmethod frame-manager-menu-choose ((frame-manager gtkairo-frame-manager) items &key associated-window printer presentation-type (default-item nil default-item-p) text-style label cache unique-id id-test cache-value cache-test max-width max-height n-rows n-columns x-spacing y-spacing row-wise cell-align-x cell-align-y scroll-bars pointer-documentation) (declare ;; XXX hallo? (ignore presentation-type default-item default-item-p text-style label cache unique-id id-test cache-value cache-test max-width max-height n-rows n-columns x-spacing y-spacing row-wise cell-align-x cell-align-y scroll-bars pointer-documentation)) (let* ((frame (if associated-window (pane-frame associated-window) *application-frame*)) (port (port frame)) (sheet (make-instance 'dummy-context-menu-sheet)) (menu (make-context-menu port sheet items :printer printer))) (invoke-later (lambda () (invoke-later (lambda () (gdk_pointer_ungrab GDK_CURRENT_TIME))) (gtk_menu_popup menu (cffi:null-pointer) (cffi:null-pointer) (cffi:null-pointer) (cffi:null-pointer) *last-seen-button* (gtk_get_current_event_time)))) (let ((event (event-read sheet))) ;; `deactivate' is signalled on the menu before `clicked' on the item, ;; so let's make sure we have processed all events before deciding ;; whether the was a `clicked' or not (gtk-main-iteration port) (when (typep (event-peek sheet) 'context-menu-clicked-event) (setf event (event-read sheet))) (etypecase event (context-menu-clicked-event (values (event-value event) (event-itemspec event) event)) (context-menu-cancelled-event nil))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/gtkairo/gdk.lisp0000640000175000017500000003012110544026237021603 0ustar pdmpdm;;; -*- Mode: Lisp; -*- ;;; (c) copyright 2006 David Lichteblau (david@lichteblau.com) ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this software and associated documentation files (the ;;; "Software"), to deal in the Software without restriction, including ;;; without limitation the rights to use, copy, modify, merge, publish, ;;; distribute, sublicense, and/or sell copies of the Software, and to ;;; permit persons to whom the Software is furnished to do so, subject to ;;; the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. ;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY ;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, ;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. (in-package :clim-gtkairo) ;;; Locking rule for this file: Dokumented entry points in the CLIM ;;; package use WITH-GTK, internal functions can rely on that. (defun rc (x) (floor (+ x .5))) (defun rd (d) (floor (+ (abs d) .5))) (defclass gdk-medium (gtkairo-medium) ((gc :initform nil :initarg :gc))) (defmethod destroy-medium ((medium gdk-medium)) (with-slots (gc) medium (when gc (gdk_gc_unref gc) (setf gc nil)))) (defmethod metrik-medium-for ((medium gdk-medium)) (gdk-metrik-medium (port medium))) (defgeneric gc (medium ink)) (defmethod gc :before (medium ink) (declare (ignore ink)) (with-slots (gc) medium (unless gc (setf gc (gdk_gc_new (dr medium))) (update-clipping-region medium) (update-line-style medium))) (when (medium-sheet medium) ;ignore the metrik-medium (setf (gethash medium (dirty-mediums (port medium))) t))) (defmethod gc (medium (ink color)) (with-slots (gc) medium (with-gdkcolor (c (or ink (medium-ink medium))) (gdk_gc_set_rgb_fg_color gc c)) (with-gdkcolor (c (medium-background medium)) (gdk_gc_set_rgb_bg_color gc c)) (gdk_gc_set_function gc :GDK_COPY) gc)) (defmethod gc (medium (ink (eql t))) (gc medium (medium-ink medium))) (defmethod gc (medium (ink (eql +foreground-ink+))) (gc medium (medium-foreground medium))) (defmethod gc (medium (ink (eql +background-ink+))) (gc medium (medium-background medium))) (defmethod gc (medium (ink (eql +flipping-ink+))) (with-slots (gc) medium (with-gdkcolor (c (medium-foreground medium)) (with-gdkcolor (d (medium-background medium)) (gdk_colormap_alloc_color (gdk_colormap_get_system) c 0 1) (gdk_colormap_alloc_color (gdk_colormap_get_system) d 0 1) (setf (cffi:foreign-slot-value c 'gdkcolor 'pixel) (logxor (cffi:foreign-slot-value c 'gdkcolor 'pixel) (cffi:foreign-slot-value d 'gdkcolor 'pixel)))) (gdk_gc_set_foreground gc c) (gdk_gc_set_background gc c)) (gdk_gc_set_function gc :GDK_XOR) gc)) (defmethod (setf medium-clipping-region) :after (region (medium gdk-medium)) (declare (ignore region)) (with-slots (gc) medium (when gc (update-clipping-region medium)))) (defun update-clipping-region (medium) (with-slots (gc) medium (let ((region (gdk_region_new))) (let ((clim-region (climi::medium-device-region medium))) (unless (region-equal clim-region +nowhere+) (loop for (x y w h) in (clipping-region->rect-seq clim-region) do (cffi:with-foreign-object (r 'gdkrectangle) (setf (cffi:foreign-slot-value r 'gdkrectangle 'x) x) (setf (cffi:foreign-slot-value r 'gdkrectangle 'y) y) (setf (cffi:foreign-slot-value r 'gdkrectangle 'width) w) (setf (cffi:foreign-slot-value r 'gdkrectangle 'height) h) (gdk_region_union_with_rect region r )))) #+(or) (when (region-equal clim-region +everywhere+) (gdk_region_union region (gdk_drawable_get_clip_region (dr medium))))) (gdk_gc_set_clip_region gc region) (gdk_region_destroy region)))) (defmethod (setf medium-line-style) :after (line-style (medium gdk-medium)) (declare (ignore line-style)) (with-slots (gc) medium (when gc (update-line-style medium)))) (defun update-line-style (medium) (with-slots (gc) medium (let ((line-style (medium-line-style medium))) (gdk_gc_set_line_attributes gc (round (line-style-thickness line-style)) (if (line-style-dashes line-style) :GDK_LINE_ON_OFF_DASH :GDK_LINE_SOLID) (ecase (line-style-cap-shape line-style) (:no-end-point :GDK_CAP_NOT_LAST) (:butt :GDK_CAP_BUTT) (:round :GDK_CAP_ROUND) (:square :GDK_CAP_PROJECTING)) (ecase (line-style-joint-shape line-style) (:miter :GDK_JOIN_MITER) (:bevel :GDK_JOIN_BEVEL) (:round :GDK_JOIN_ROUND) (:none ;; ?? :GDK_JOIN_ROUND))) (let ((dashes (coerce (line-style-dashes line-style) 'vector))) (case (line-style-dashes line-style) ((t) (setf dashes (vector 10 10))) ((nil) (setf dashes (vector 1)))) (when (member (line-style-unit line-style) '(:point :normal)) (setf dashes (map 'vector (lambda (x) (untransform-size (medium-transformation medium) x)) dashes))) (cffi:with-foreign-object (adashes :int8 (length dashes)) (loop for i from 0 for x across dashes do (setf (cffi:mem-aref adashes :int8 i) (rc x))) (gdk_gc_set_dashes gc 0 adashes (length dashes))))))) (defmethod invoke-with-medium (fn (medium gdk-medium)) (when (climi::port-lookup-mirror (port medium) (medium-sheet medium)) (with-gtk () (funcall fn)))) (defmethod invoke-with-medium (fn (medium gdk-metrik-medium)) (with-gtk () (funcall fn))) (defun dr (medium) (mirror-drawable (medium-mirror medium))) (defmethod medium-draw-point* ((medium gdk-medium) x y) (with-medium (medium) (let ((tr (sheet-native-transformation (medium-sheet medium)))) (climi::with-transformed-position (tr x y) (gdk_draw_point (dr medium) (gc medium t) (rc x) (rc y)))))) (defmethod medium-draw-points* ((medium gdk-medium) coord-seq) (with-medium (medium) (let ((tr (sheet-native-transformation (medium-sheet medium))) (dr (dr medium)) (gc (gc medium t))) (loop for (x y) on (coerce coord-seq 'list) by #'cddr do (climi::with-transformed-position (tr x y) (gdk_draw_point dr gc (rc x) (rc y))))))) (defmethod medium-draw-line* ((medium gdk-medium) x1 y1 x2 y2) (with-medium (medium) (let ((tr (sheet-native-transformation (medium-sheet medium)))) (climi::with-transformed-position (tr x1 y1) (climi::with-transformed-position (tr x2 y2) (gdk_draw_line (dr medium) (gc medium t) (rc x1) (rc y1) (rc x2) (rc y2))))))) (defmethod medium-draw-lines* ((medium gdk-medium) position-seq) (with-medium (medium) (let ((tr (sheet-native-transformation (medium-sheet medium))) (dr (dr medium)) (gc (gc medium t))) (loop for (x1 y1 x2 y2) on (coerce position-seq 'list) by #'cddddr do (climi::with-transformed-position (tr x1 y1) (climi::with-transformed-position (tr x2 y2) (gdk_draw_line dr gc (rc x1) (rc y1) (rc x2) (rc y2)))))))) (defun typed-pointer-+ (pointer type i) (cffi:inc-pointer pointer (* i (cffi:foreign-type-size type)))) (defmethod medium-draw-polygon* ((medium gdk-medium) xys closed filled) (climi::with-transformed-positions ((sheet-native-transformation (medium-sheet medium)) xys) (let ((n (truncate (length xys) 2)) (fixup (and closed (not filled))) (dr (dr medium)) (gc (gc medium t))) (when fixup (incf n)) (cffi:with-foreign-object (points 'gdkpoint n) (loop for i from 0 for p = (typed-pointer-+ points 'gdkpoint i) for (x y) on (coerce xys 'list) by #'cddr do (setf (cffi:foreign-slot-value p 'gdkpoint 'x) (rc x)) (setf (cffi:foreign-slot-value p 'gdkpoint 'y) (rc y))) (when fixup (let ((q (typed-pointer-+ points 'gdkpoint (1- n)))) (setf (cffi:foreign-slot-value q 'gdkpoint 'x) (cffi:foreign-slot-value points 'gdkpoint 'x)) (setf (cffi:foreign-slot-value q 'gdkpoint 'x) (cffi:foreign-slot-value points 'gdkpoint 'y)))) (if closed (gdk_draw_polygon dr gc (if filled 1 0) points n) (gdk_draw_lines dr gc points n)))))) (defmethod medium-draw-rectangle* ((medium gdk-medium) x1 y1 x2 y2 filled) (with-medium (medium) (let ((tr (sheet-native-transformation (medium-sheet medium)))) (climi::with-transformed-position (tr x1 y1) (climi::with-transformed-position (tr x2 y2) (gdk_draw_rectangle (dr medium) (gc medium t) (if filled 1 0) (rc (min x1 x2)) (rc (min y1 y2)) (rd (- x2 x1)) (rd (- y2 y1)))))))) (defmethod medium-draw-rectangles* ((medium gdk-medium) position-seq filled) (with-medium (medium) (let ((tr (sheet-native-transformation (medium-sheet medium))) (dr (dr medium)) (gc (gc medium t))) (loop for i below (length position-seq) by 4 do (let ((x1 (df (elt position-seq (+ i 0)))) (y1 (df (elt position-seq (+ i 1)))) (x2 (df (elt position-seq (+ i 2)))) (y2 (df (elt position-seq (+ i 3))))) (climi::with-transformed-position (tr x1 y1) (climi::with-transformed-position (tr x2 y2) (gdk_draw_rectangle dr gc (if filled 1 0) (rc (min x1 x2)) (rc (min y1 y2)) (rd (- x2 x1)) (rd (- y2 y1)))))))))) ;; taken from clim-clx (defmethod medium-draw-ellipse* ((medium gdk-medium) center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy start-angle end-angle filled) (unless (or (= radius-2-dx radius-1-dy 0) (= radius-1-dx radius-2-dy 0)) (error "MEDIUM-DRAW-ELLIPSE* not for non axis-aligned ellipses.")) (with-medium (medium) (climi::with-transformed-position ((sheet-native-transformation (medium-sheet medium)) center-x center-y) (let* ((start-angle (* start-angle #.(/ 11520 pi))) (end-angle (* end-angle #.(/ 11520 pi))) (radius-dx (abs (+ radius-1-dx radius-2-dx))) (radius-dy (abs (+ radius-1-dy radius-2-dy))) (min-x (round-coordinate (- center-x radius-dx))) (min-y (round-coordinate (- center-y radius-dy))) (max-x (round-coordinate (+ center-x radius-dx))) (max-y (round-coordinate (+ center-y radius-dy)))) (gdk_draw_arc (dr medium) (gc medium t) (if filled 1 0) min-x min-y (- max-x min-x) (- max-y min-y) (round start-angle) (round end-angle)))))) (defmethod invoke-with-pango-layout (fn (medium gdk-medium) &key text-style text) (with-pango-context (context nil) (let ((layout (pango_layout_new context))) (unwind-protect (progn (configure-pango-layout layout :text-style text-style :text text) (funcall fn layout)) (g_object_unref layout))))) (defmethod medium-draw-text* ((medium gdk-medium) text x y start end align-x align-y toward-x toward-y transform-glyphs) (with-medium (medium) (setf end (or end (length text))) (unless (eql start end) (let ((tr (sheet-native-transformation (medium-sheet medium)))) (climi::with-transformed-position (tr x y) (with-pango-layout (layout medium :text-style medium :text (subseq text start end)) (let ((y2 (nth-value 1 (pango-layout-line-get-pixel-extents layout 0)))) (gdk_draw_layout (dr medium) (gc medium t) (rc x) (rc (+ y y2)) layout)))))))) (defmethod medium-finish-output ((medium gdk-medium)) (medium-force-output medium)) (defmethod medium-force-output ((medium gdk-medium)) (remhash medium (dirty-mediums (port medium))) (with-medium (medium) (when (slot-value medium 'gc) (invalidate-mirror (medium-mirror medium) (medium-sheet medium))))) (defmethod medium-beep ((medium gdk-medium)) ;; fixme: visual beep? ) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/gtkairo/NOTES0000600000175000017500000001242710422652205020760 0ustar pdmpdmGilbert Baumann's notes, copied from clim-cairo-2005-03-20/cairo-medium.lisp. ;; - blitting ;; ;; The X11 Cairo backend currently crashes my X server when blittering from ;; one surface to itself. [That is, if we draw to a surface using very same ;; surface as the pattern]. [ Well, no X11 here anywore. Is anything like this still relevant? ] ;; - pixmaps ;; ;; These should be easy to provide. [ David: done ] ;; - alpha impedance mismatch ;; ;; Cairo uses pre-multiplied alpha while CLIM doesn't. So we need to convert ;; things around as needed. [ David: ??? ] ;; - real general designs and optimization short cuts ;; - new drawing options: ;; - :transform-glyphs-p ;; - :alu ;; - MEDIUM-DRAW-ELLIPSE* ;; Need to find a good bezier approximation of circles. ;; - MEDIUM-BEEP [ David: nix is, gepiepe kann ich nicht leiden. ;-) Ein "visual beep" waere aber schick. Vielleicht kann man da ja was basteln? ] ;; - device text styles ;; - find a substitue for CAIRO-FONT-SET-TRANSFORM ;; - abolish this silly CLIM-INTERNALS::DO-GRAPHICS-WITH-OPTIONS ;; - INVOKE-WITH-DRAWING-OPTIONS ;; - care for the proper text transformations. ;; - we need a systematic overview about what drawing option components are ;; transformed under what circumstances in cairo and in clim. ;; - i believe a "cr" is really nothing more than a kind of graphics context, so ;; this time implement a proper cache for those, so that we spend less time ;; tossing options around. [ David: Hmm, let's do some profiling before setting up a cache. Cairo people seem to recommend creating a cairo context for each and every redraw and then throwing it away, and we only create one for every medium, so that shouldn't be too slow. What's important is to not leak the cairo context. Right now I let the sheet destroy contexts when the mirror is destroyed, is that the right thing to do? ] ;; - more alu operations in clim ;; ;; For CAD applications it is really handy to have an OR operation. (Which ;; could be approximated in effect with :saturate). We would need to extend ;; the CLIM general design specification to include alu operations. [As ;; currently there really are only the OVER and FLIPPING operators available]. ;; - More proper separation of a vanilla Cairo media and specific Cario medium ;; like X11, Glitz, PNG, PDF etc. ;; - a WITH-CAIRO macro which can setup the proper FPU mode to make it break ;; less. [ David: oh yes, that's what I had to do in WITH-GTK. Terrible. ] ;;;; NOTES ;; RESOURCES, WHO TO FREE IT? -- It seems that if you destroy a window, a Render ;; picture associated with said window is also destroyed. ;; CAIRO-SET-TARGET-DRAWABLE and perhaps CAIRO-DESTROY do want to destroy that ;; picture on their own. So when we destroy a window we need to know all cairo ;; contexts floating around which associate to the window at hand and target ;; them at the root window (or better the spare window, more below) before we ;; destroy a window. And we need to do this recursively. And we need the extra ;; book keeping. [ David: nix verstehen. Was ist denn ein render picture? Hilfe! ] ;; UNGRAFTED MEDIA -- It happens that an application wants to use a medium ;; before its sheet is grafted. In those situations we'd need a spare window to ;; target the associated cairo medium at. We could use the root window, but bad ;; things happen if the user actually does some drawing instead of merely ;; querying stuff like text extents. So I want to allocate a specific unmapped ;; spare window for those occasions. ;; ;; [There really are two situations: a) using an ungrafted medium, b) ;; using a medium that is grafted to a sheet which itself is not ;; grafted]. [ David: I'm using the root window for text size operations (harmless) and completely ignore drawing operations otherwise. ] ;; FLIPPING INKS -- Cairo can't and for ideological reasons perhaps never will ;; support flipping inks. I myself hate flipping inks even more so than ;; bit-blittering, but there are still a few ancient applications around, which ;; use it. So we'd need to think about some way to support it. One idea is to ;; render the shape to an A1 temporary pixmap surface and use good old X11 to ;; make that pixmap flip pixels around. This breaks some abtractions established ;; by Cairo and will perhaps stop working around 2012. The fun thing is: ;; Flipping will now turn into a rather slow operation. [ David: I have implemented this strategy now. We draw flipping ink to a gdk pixmap, then copy that over with GDK_XOR. And indeed, Goatee now is extremely slow over remote X because it uses flipping ink. FIXME: Although simple cases work, sometimes flipping ink now causes garbage output to appear. ] ;; - flipping ink ;; ;; Below is some example code to make Cairo render the alpha channel to a one ;; bit depth pixmap on the server. This pixmap can then later be used with X ;; Core requests to flip pixels around. Still, in general flipping inks don't ;; play nice when you have an alpha channel. ;; ;; But: A flippink can't be solved by just setting up the proper Cairo pattern ;; to a Cairo context, but drawing the shape itself must happen on our ;; temporary surface. [ David: see above for my implemenation of flipping ink. Not sure how the alpha channel is meant to be handled though. ] cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/gtkairo/keygen.lisp0000640000175000017500000001464110543743022022326 0ustar pdmpdm;;; -*- Mode: Lisp; -*- ;;; (c) 2006 David Lichteblau (david@lichteblau.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-gtkairo) #+(or) (defparameter *key-table* (clim-gtkairo::collect-key-table)) #+(or) (print-key-table) (define-application-frame keygen () () (:panes (target :application)) (:layouts (default target)) (:top-level ())) (defmacro with-backend (name &body body) `(let* ((clim:*default-server-path* (list ,name)) (clim::*default-frame-manager* (car (climi::frame-managers (find-port))))) ,@body)) (defun collect-key-table () (with-backend :clx (run-frame-top-level (make-application-frame 'keygen :top-level-lambda (lambda (clx) (with-backend :gtkairo (run-frame-top-level (make-application-frame 'keygen :top-level-lambda (lambda (gtk) (collect-key-table-1 clx gtk)))))))))) (defun collect-key-table-1 (clx gtk) (let ((real-handler (fdefinition 'key-handler-impl)) (table (make-hash-table))) (unwind-protect (progn (setf (fdefinition 'key-handler-impl) (lambda (widget event) (cffi:with-foreign-slots ((type time state keyval) event gdkeventkey) (setf (gethash time table) (list (state-without-buttons state) keyval))) (funcall real-handler widget event))) (collect-key-table-2 clx gtk table)) (setf (fdefinition 'key-handler-impl) real-handler)))) (defmacro do-modifiers ((var) &rest body) `(dolist (.shift. '(0 1)) (dolist (.meta. '(0 4)) (dolist (.control. '(0 8)) (let ((,var (logior .shift. .meta. .control.))) ,@body))))) (defun collect-key-table-2 (clx gtk native-events) (let* ((clx-target (find-pane-named clx 'target)) (clx-win (clim:sheet-mirror clx-target)) (dpy (xlib:window-display clx-win)) (screen (xlib:display-default-screen dpy)) (min (xlib:display-min-keycode dpy)) (max (xlib:display-max-keycode dpy)) (gtk-target (find-pane-named gtk 'target)) (gtk-win (xlib::lookup-window dpy (gdk_x11_drawable_get_xid (cffi:foreign-slot-value (mirror-widget (clim:sheet-mirror gtk-target)) 'gtkwidget 'gdkwindow)))) (time 0) (clx-events (make-hash-table)) (gtk-events (make-hash-table))) (format t "Waiting for windows to come up...~%") (sleep 5) (do-modifiers (state) (format t "Sending events for state ~D...~%" state) (loop for code from min to max do (dolist (type '(:key-press :key-release)) (send-key-event screen clx-win state type code :time time) (send-key-event screen gtk-win state type code :time time) (slurp-events clx-target clx-events t) (slurp-events gtk-target gtk-events) (incf time)))) (format t "Waiting for events to come in...~%") (sleep 5) (slurp-events clx-target clx-events) (slurp-events gtk-target gtk-events) (format t "Done.~%") (let ((result (make-array time)) (real-failures 0) (mod-failures 0) (misses 0)) (dotimes (x time) (let* ((e (gethash x clx-events)) (f (gethash x gtk-events)) (a (de e)) (b (de f))) (cond ((null f) (incf misses)) ((equal a b) ;; (format t "PASS ~A~%" a) ) ((equal (cdr a) (cdr b)) (format t "FAIL ~A/~A~%" a b) (incf mod-failures)) (t (format t "FAIL ~A/~A~%" a b) (incf real-failures))) (setf (elt result x) (cons e (gethash x native-events))))) (format t "~D failures, ~D modifier failures, ~D misses~%" real-failures mod-failures misses) result))) (defun slurp-events (target table &optional block) (loop for e = (slurp-key-event target block) while e do (setf (gethash (event-timestamp e) table) e) (setf block nil))) (defun de (ev) (if ev (list (event-modifier-state ev) (keyboard-event-key-name ev) (keyboard-event-character ev)) nil)) (defun send-key-event (screen win state type code &key time) (xlib:send-event win type (list type) :code code :state state :window win :root (xlib:screen-root screen) :time (or time 0) :x 1 :y 2 :root-x 10 :root-y 20 :same-screen-p t)) (defun slurp-key-event (pane &optional block) (loop for event = (if block (event-read pane) (event-read-no-hang pane)) until (typep event '(or null key-press-event key-release-event)) finally (return event))) (defun cwd () (slot-value (asdf:find-system :clim-gtkairo) 'asdf::relative-pathname)) (defun print-key-table () (let ((table (make-hash-table))) (loop for (ok state value) across *key-table* do (when value (let* ((name (if ok (keyboard-event-key-name ok) 'throw-away)) (char (if ok (keyboard-event-character ok) 'throw-away)) (def (gethash value table))) (dolist (clause def (push (list (list state) name char) (gethash value table))) (when (and (eql (second clause) name) (eql (third clause) char)) (pushnew state (car clause)) (return)))))) (with-open-file (s (merge-pathnames "Backends/gtkairo/keys.lisp" (cwd)) :direction :output :if-exists :rename-and-delete) (write-line ";; autogenerated by keygen.lisp" s) (print '(in-package :clim-gtkairo) s) (loop for (value . spec) :in (sort (loop for value being each hash-key in table using (hash-value spec) collect (cons value spec)) #'< :key #'car) do (print `(define-key ,value ,@(simplify-spec spec)) s))))) (defun simplify-spec (clauses) (flet ((count-keys (x) (length (car x)))) (let* ((max (reduce #'max clauses :key #'count-keys)) (clause (find max clauses :key #'count-keys))) (append (remove clause clauses) `((t ,@(cdr clause))))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/gtkairo/medium.lisp0000640000175000017500000001725510561555366022344 0ustar pdmpdm;;; -*- Mode: Lisp; -*- ;;; (c) copyright 2005 by Gilbert Baumann ;;; (c) copyright 2006 David Lichteblau (david@lichteblau.com) ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this software and associated documentation files (the ;;; "Software"), to deal in the Software without restriction, including ;;; without limitation the rights to use, copy, modify, merge, publish, ;;; distribute, sublicense, and/or sell copies of the Software, and to ;;; permit persons to whom the Software is furnished to do so, subject to ;;; the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. ;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY ;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, ;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. (in-package :clim-gtkairo) ;;; Locking rule for this file: Dokumented entry points in the CLIM ;;; package use WITH-GTK, internal functions can rely on that. (defun df (x) (coerce x 'double-float)) (defclass gtkairo-medium (climi::basic-medium clim:medium) ((port :initarg :port :accessor port))) (defclass metrik-medium-mixin () ()) (defclass cairo-metrik-medium (metrik-medium-mixin cairo-medium) ()) (defclass gdk-metrik-medium (metrik-medium-mixin gdk-medium) ()) (defgeneric invoke-with-medium (fn medium)) (defmacro with-medium ((medium) &body body) `(invoke-with-medium (lambda () ,@body) ,medium)) (defgeneric metrik-medium-for (medium)) (defun gtkwidget-gdkwindow (widget) (cffi:foreign-slot-value widget 'gtkwidget 'gdkwindow)) (defun medium-mirror (medium) (or (climi::port-lookup-mirror (port medium) (medium-sheet medium)) (error "oops, drawing operation on unmirrored sheet ~A" medium))) (defmethod engraft-medium :after ((medium gtkairo-medium) port sheet) ) (defmethod degraft-medium :after ((medium gtkairo-medium) port sheet) ) (defvar *medium-type* :cairo) #+(or) (setf *medium-type* :gdk) #+(or) (setf *medium-type* :cairo) (defmethod make-medium ((port gtkairo-port) sheet) (make-instance (ecase *medium-type* (:gdk 'gdk-medium) (:cairo 'cairo-medium)) :port port :sheet sheet)) ;; copy&paste from medium.lisp|CLX: ;; this seems to work, but find out why all of these +nowhere+s are coming from ;; and kill them at the source... (defun clipping-region->rect-seq (clipping-region) (loop for region in (nreverse (mapcan (lambda (v) (unless (eq v +nowhere+) (list v))) (region-set-regions clipping-region :normalize :y-banding))) as rectangle = (bounding-rectangle region) for clip-x = (round-coordinate (rectangle-min-x rectangle)) for clip-y = (round-coordinate (rectangle-min-y rectangle)) collect (list clip-x clip-y (- (round-coordinate (rectangle-max-x rectangle)) clip-x) (- (round-coordinate (rectangle-max-y rectangle)) clip-y)))) (defun untransform-size (transformation size) (multiple-value-bind (dx dy) (untransform-distance transformation size 0) (sqrt (+ (expt dx 2) (expt dy 2))))) (defun transform-size (transformation size) (multiple-value-bind (dx dy) (transform-distance transformation size 0) (sqrt (+ (expt dx 2) (expt dy 2))))) (defmethod invalidate-mirror ((mirror drawable-mirror) sheet) (declare (ignore sheet))) (defmethod invalidate-mirror ((mirror widget-mirror) sheet) (let* ((drawable (mirror-drawable mirror)) (real-drawable (mirror-real-drawable mirror))) (unless (cffi:pointer-eq drawable real-drawable) (let* ((region (climi::sheet-mirror-region sheet)) (width (floor (bounding-rectangle-max-x region))) (height (floor (bounding-rectangle-max-y region)))) (cffi:with-foreign-object (r 'gdkrectangle) (setf (cffi:foreign-slot-value r 'gdkrectangle 'width) width) (setf (cffi:foreign-slot-value r 'gdkrectangle 'height) height) (gdk_window_invalidate_rect real-drawable r 0)))))) ;;;; ------------------------------------------------------------------------ ;;;; Text Styles ;;;; ;;; Diverse dieser Funktionen werden auf Mediums aufgerufen, deren Sheet ;;; noch keinen Mirror hat, und muessen tatsaechlich schon die richtige ;;; Antwort liefern. Daher leite ich einfach generell all diese ;;; Anfragen auf ein zuvor angelegtes Medium fuer das Root-Fenster um. (let ((hash (make-hash-table :test 'equal))) (defmethod text-style-ascent (text-style (medium gtkairo-medium)) (let ((key (cons (class-name (class-of medium)) text-style))) (or #-debug-metrik (gethash key hash) (setf (gethash key hash) (text-style-ascent text-style (metrik-medium-for medium))))))) (let ((hash (make-hash-table :test 'equal))) (defmethod text-style-descent (text-style (medium gtkairo-medium)) (let ((key (cons (class-name (class-of medium)) text-style))) (or #-debug-metrik (gethash key hash) (setf (gethash key hash) (text-style-descent text-style (metrik-medium-for medium))))))) (let ((hash (make-hash-table :test 'equal))) (defmethod text-style-height (text-style (medium gtkairo-medium)) (let ((key (cons (class-name (class-of medium)) text-style))) (or #-debug-metrik (gethash key hash) (setf (gethash key hash) (text-style-height text-style (metrik-medium-for medium))))))) (let ((hash (make-hash-table :test 'equal))) (defmethod text-style-width (text-style (medium gtkairo-medium)) (let ((key (cons (class-name (class-of medium)) text-style))) (or #-debug-metrik (gethash key hash) (setf (gethash key hash) (text-style-width text-style (metrik-medium-for medium))))))) (let ((hash (make-hash-table :test 'equal))) (defmethod text-style-fixed-width-p (text-style (medium gtkairo-medium)) (let ((key (cons (class-name (class-of medium)) text-style))) (or #-debug-metrik (gethash key hash) (setf (gethash key hash) (text-style-fixed-width-p text-style (metrik-medium-for medium))))))) (defmethod text-size ((medium gtkairo-medium) string &key text-style (start 0) end) (with-gtk () (when (characterp string) (setf string (string string))) (setf text-style (or text-style (medium-text-style medium))) (setf text-style (merge-text-styles text-style (medium-default-text-style medium))) (text-size (metrik-medium-for medium) string :text-style text-style :start start :end (or end (length string))))) (defmethod climi::text-bounding-rectangle* ((medium gtkairo-medium) string &key text-style (start 0) end) (with-gtk () (when (characterp string) (setf string (string string))) (setf text-style (or text-style (medium-text-style medium))) (setf text-style (merge-text-styles text-style (medium-default-text-style medium))) (climi::text-bounding-rectangle* (metrik-medium-for medium) string :text-style text-style :start start :end (or end (length string))))) ;;;; ------------------------------------------------------------------------ ;;;; Hmm ;;;; (defmethod medium-current-text-style ((medium gtkairo-medium)) (merge-text-styles (medium-text-style medium) (medium-default-text-style medium))) (defmethod medium-merged-text-style ((medium gtkairo-medium)) (merge-text-styles (medium-text-style medium) (medium-default-text-style medium))) ;;;; ------------------------------------------------------------------------ cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/gtkairo/ffi.lisp0000644000175000017500000014101211345155772021617 0ustar pdmpdm;;; -*- Mode: Lisp; -*- (in-package :clim-gtkairo) (cffi:defcstruct Depth (depth :int) ;int (nvisuals :int) ;int (visuals :pointer) ;Visual * ) (defcenum GConnectFlags (:G_CONNECT_AFTER 1) :G_CONNECT_SWAPPED) (defcenum GdkCapStyle :GDK_CAP_NOT_LAST :GDK_CAP_BUTT :GDK_CAP_ROUND :GDK_CAP_PROJECTING) (defcenum GdkCrossingMode :GDK_CROSSING_NORMAL :GDK_CROSSING_GRAB :GDK_CROSSING_UNGRAB) (defcenum GdkDragAction (:GDK_ACTION_DEFAULT 1) :GDK_ACTION_COPY (:GDK_ACTION_MOVE 4) (:GDK_ACTION_LINK 8) (:GDK_ACTION_PRIVATE 16) (:GDK_ACTION_ASK 32)) (defcenum GdkDragProtocol :GDK_DRAG_PROTO_MOTIF :GDK_DRAG_PROTO_XDND :GDK_DRAG_PROTO_ROOTWIN :GDK_DRAG_PROTO_NONE :GDK_DRAG_PROTO_WIN32_DROPFILES :GDK_DRAG_PROTO_OLE2 :GDK_DRAG_PROTO_LOCAL) (defcenum GdkEventMask (:GDK_EXPOSURE_MASK 2) (:GDK_POINTER_MOTION_MASK 4) (:GDK_POINTER_MOTION_HINT_MASK 8) (:GDK_BUTTON_MOTION_MASK 16) (:GDK_BUTTON1_MOTION_MASK 32) (:GDK_BUTTON2_MOTION_MASK 64) (:GDK_BUTTON3_MOTION_MASK 128) (:GDK_BUTTON_PRESS_MASK 256) (:GDK_BUTTON_RELEASE_MASK 512) (:GDK_KEY_PRESS_MASK 1024) (:GDK_KEY_RELEASE_MASK 2048) (:GDK_ENTER_NOTIFY_MASK 4096) (:GDK_LEAVE_NOTIFY_MASK 8192) (:GDK_FOCUS_CHANGE_MASK 16384) (:GDK_STRUCTURE_MASK 32768) (:GDK_PROPERTY_CHANGE_MASK 65536) (:GDK_VISIBILITY_NOTIFY_MASK 131072) (:GDK_PROXIMITY_IN_MASK 262144) (:GDK_PROXIMITY_OUT_MASK 524288) (:GDK_SUBSTRUCTURE_MASK 1048576) (:GDK_SCROLL_MASK 2097152) (:GDK_ALL_EVENTS_MASK 4194302)) (defcenum GdkEventType (:GDK_NOTHING -1) :GDK_DELETE :GDK_DESTROY :GDK_EXPOSE :GDK_MOTION_NOTIFY :GDK_BUTTON_PRESS :GDK_2BUTTON_PRESS :GDK_3BUTTON_PRESS :GDK_BUTTON_RELEASE :GDK_KEY_PRESS :GDK_KEY_RELEASE :GDK_ENTER_NOTIFY :GDK_LEAVE_NOTIFY :GDK_FOCUS_CHANGE :GDK_CONFIGURE :GDK_MAP :GDK_UNMAP :GDK_PROPERTY_NOTIFY :GDK_SELECTION_CLEAR :GDK_SELECTION_REQUEST :GDK_SELECTION_NOTIFY :GDK_PROXIMITY_IN :GDK_PROXIMITY_OUT :GDK_DRAG_ENTER :GDK_DRAG_LEAVE :GDK_DRAG_MOTION :GDK_DRAG_STATUS :GDK_DROP_START :GDK_DROP_FINISHED :GDK_CLIENT_EVENT :GDK_VISIBILITY_NOTIFY :GDK_NO_EXPOSE :GDK_SCROLL :GDK_WINDOW_STATE :GDK_SETTING :GDK_OWNER_CHANGE :GDK_GRAB_BROKEN) (defcenum GdkFunction :GDK_COPY :GDK_INVERT :GDK_XOR :GDK_CLEAR :GDK_AND :GDK_AND_REVERSE :GDK_AND_INVERT :GDK_NOOP :GDK_OR :GDK_EQUIV :GDK_OR_REVERSE :GDK_COPY_INVERT :GDK_OR_INVERT :GDK_NAND :GDK_NOR :GDK_SET) (defcenum GdkGrabStatus :GDK_GRAB_SUCCESS :GDK_GRAB_ALREADY_GRABBED :GDK_GRAB_INVALID_TIME :GDK_GRAB_NOT_VIEWABLE :GDK_GRAB_FROZEN) (defcenum GdkJoinStyle :GDK_JOIN_MITER :GDK_JOIN_ROUND :GDK_JOIN_BEVEL) (defcenum GdkLineStyle :GDK_LINE_SOLID :GDK_LINE_ON_OFF_DASH :GDK_LINE_DOUBLE_DASH) (defcenum GdkModifierType (:GDK_SHIFT_MASK 1) :GDK_LOCK_MASK (:GDK_CONTROL_MASK 4) (:GDK_MOD1_MASK 8) (:GDK_MOD2_MASK 16) (:GDK_MOD3_MASK 32) (:GDK_MOD4_MASK 64) (:GDK_MOD5_MASK 128) (:GDK_BUTTON1_MASK 256) (:GDK_BUTTON2_MASK 512) (:GDK_BUTTON3_MASK 1024) (:GDK_BUTTON4_MASK 2048) (:GDK_BUTTON5_MASK 4096) (:GDK_RELEASE_MASK 1073741824) (:GDK_MODIFIER_MASK 1073750015)) (defcenum GdkNotifyType :GDK_NOTIFY_ANCESTOR :GDK_NOTIFY_VIRTUAL :GDK_NOTIFY_INFERIOR :GDK_NOTIFY_NONLINEAR :GDK_NOTIFY_NONLINEAR_VIRTUAL :GDK_NOTIFY_UNKNOWN) (defcenum GdkWindowHints (:GDK_HINT_POS 1) :GDK_HINT_MIN_SIZE (:GDK_HINT_MAX_SIZE 4) (:GDK_HINT_BASE_SIZE 8) (:GDK_HINT_ASPECT 16) (:GDK_HINT_RESIZE_INC 32) (:GDK_HINT_WIN_GRAVITY 64) (:GDK_HINT_USER_POS 128) (:GDK_HINT_USER_SIZE 256)) (defcenum GtkPolicyType :GTK_POLICY_ALWAYS :GTK_POLICY_AUTOMATIC :GTK_POLICY_NEVER) (defcenum GtkScrollType :GTK_SCROLL_NONE :GTK_SCROLL_JUMP :GTK_SCROLL_STEP_BACKWARD :GTK_SCROLL_STEP_FORWARD :GTK_SCROLL_PAGE_BACKWARD :GTK_SCROLL_PAGE_FORWARD :GTK_SCROLL_STEP_UP :GTK_SCROLL_STEP_DOWN :GTK_SCROLL_PAGE_UP :GTK_SCROLL_PAGE_DOWN :GTK_SCROLL_STEP_LEFT :GTK_SCROLL_STEP_RIGHT :GTK_SCROLL_PAGE_LEFT :GTK_SCROLL_PAGE_RIGHT :GTK_SCROLL_START :GTK_SCROLL_END) (defcenum GtkSelectionMode :GTK_SELECTION_NONE :GTK_SELECTION_SINGLE :GTK_SELECTION_BROWSE :GTK_SELECTION_MULTIPLE (:GTK_SELECTION_EXTENDED 3)) (defcenum GtkStateType :GTK_STATE_NORMAL :GTK_STATE_ACTIVE :GTK_STATE_PRELIGHT :GTK_STATE_SELECTED :GTK_STATE_INSENSITIVE) (defcenum GtkWindowType :GTK_WINDOW_TOPLEVEL :GTK_WINDOW_POPUP) (defcenum PangoStyle :PANGO_STYLE_NORMAL :PANGO_STYLE_OBLIQUE :PANGO_STYLE_ITALIC) (defcenum PangoWeight (:PANGO_WEIGHT_ULTRALIGHT 200) (:PANGO_WEIGHT_LIGHT 300) (:PANGO_WEIGHT_NORMAL 400) (:PANGO_WEIGHT_SEMIBOLD 600) (:PANGO_WEIGHT_BOLD 700) (:PANGO_WEIGHT_ULTRABOLD 800) (:PANGO_WEIGHT_HEAVY 900)) (cffi:defcstruct Screen (ext_data :pointer) ;XExtData * (display :pointer) ;struct _XDisplay * (root :unsigned-long) ;Window (width :int) ;int (height :int) ;int (mwidth :int) ;int (mheight :int) ;int (ndepths :int) ;int (depths :pointer) ;Depth * (root_depth :int) ;int (root_visual :pointer) ;Visual * (default_gc :pointer) ;GC (cmap :unsigned-long) ;Colormap (white_pixel :unsigned-long) ;long unsigned int (black_pixel :unsigned-long) ;long unsigned int (max_maps :int) ;int (min_maps :int) ;int (backing_store :int) ;int (save_unders :int) ;int (root_input_mask :long) ;long int ) (defcfun "cairo_arc" :void (arg0 :pointer) ;cairo_t * (arg1 :double) ;double (arg2 :double) ;double (arg3 :double) ;double (arg4 :double) ;double (arg5 :double) ;double ) (defcfun "cairo_arc_negative" :void (arg0 :pointer) ;cairo_t * (arg1 :double) ;double (arg2 :double) ;double (arg3 :double) ;double (arg4 :double) ;double (arg5 :double) ;double ) (defcfun "cairo_clip" :void (arg0 :pointer) ;cairo_t * ) (defcfun "cairo_copy_page" :void (arg0 :pointer) ;cairo_t * ) (defcfun "cairo_create" :pointer (arg0 :pointer) ;cairo_surface_t * ) (defcfun "cairo_curve_to" :void (arg0 :pointer) ;cairo_t * (arg1 :double) ;double (arg2 :double) ;double (arg3 :double) ;double (arg4 :double) ;double (arg5 :double) ;double (arg6 :double) ;double ) (defcfun "cairo_destroy" :void (arg0 :pointer) ;cairo_t * ) (defcfun "cairo_fill" :void (arg0 :pointer) ;cairo_t * ) (defcfun "cairo_fill_extents" :void (arg0 :pointer) ;cairo_t * (arg1 :pointer) ;double * (arg2 :pointer) ;double * (arg3 :pointer) ;double * (arg4 :pointer) ;double * ) (defcfun "cairo_fill_preserve" :pointer (arg0 :pointer) ;cairo_t * ) (defcfun "cairo_font_extents" :void (arg0 :pointer) ;cairo_t * (arg1 :pointer) ;cairo_font_extents_t * ) (defcfun "cairo_font_face_status" cairo_status_t (arg0 :pointer) ;cairo_font_face_t * ) (defcfun "cairo_format_stride_for_width" :int (arg0 cairo_format_t) (arg1 :int) ) (defcfun "cairo_get_font_face" :pointer (arg0 :pointer) ;cairo_t * ) (defcfun "cairo_get_target" :pointer (arg0 :pointer) ;cairo_t * ) (defcfun "cairo_glyph_extents" :void (arg0 :pointer) ;cairo_t * (arg1 :pointer) ;cairo_glyph_t * (arg2 :int) ;int (arg3 :pointer) ;cairo_text_extents_t * ) (defcfun "cairo_glyph_path" :void (arg0 :pointer) ;cairo_t * (arg1 :pointer) ;cairo_glyph_t * (arg2 :int) ;int ) (defcfun "cairo_identity_matrix" :void (arg0 :pointer) ;cairo_t * ) (defcfun "cairo_image_surface_create" :pointer (arg0 cairo_format_t) (arg1 :int) ;int (arg2 :int) ;int ) (defcfun "cairo_image_surface_create_for_data" :pointer (arg0 utf8-string) ;unsigned char * (arg1 cairo_format_t) (arg2 :int) ;int (arg3 :int) ;int (arg4 :int) ;int ) (defcfun "cairo_in_fill" :int (arg0 :pointer) ;cairo_t * (arg1 :double) ;double (arg2 :double) ;double ) (defcfun "cairo_in_stroke" :int (arg0 :pointer) ;cairo_t * (arg1 :double) ;double (arg2 :double) ;double ) (defcfun "cairo_line_to" :void (arg0 :pointer) ;cairo_t * (arg1 :double) ;double (arg2 :double) ;double ) (defcfun "cairo_matrix_init" :pointer (arg0 :pointer) ;cairo_matrix_t * (arg1 :double) ;double (arg2 :double) ;double (arg3 :double) ;double (arg4 :double) ;double (arg5 :double) ;double (arg6 :double) ;double ) (defcfun "cairo_matrix_rotate" :void (arg0 :pointer) ;cairo_matrix_t * (arg1 :double) ;double ) (defcfun "cairo_matrix_translate" :void (arg0 :pointer) ;cairo_matrix_t * (arg1 :double) ;double (arg2 :double) ;double ) (defcfun "cairo_move_to" :pointer (arg0 :pointer) ;cairo_t * (arg1 :double) ;double (arg2 :double) ;double ) (defcfun "cairo_new_path" :pointer (arg0 :pointer) ;cairo_t * ) (defcfun "cairo_paint" :void (arg0 :pointer) ;cairo_t * ) (defcfun "cairo_pattern_create_for_surface" :pointer (arg0 :pointer) ;cairo_surface_t * ) (defcfun "cairo_pattern_create_linear" :pointer (arg0 :double) ;double (arg1 :double) ;double (arg2 :double) ;double (arg3 :double) ;double ) (defcfun "cairo_pattern_create_radial" :pointer (arg0 :double) ;double (arg1 :double) ;double (arg2 :double) ;double (arg3 :double) ;double (arg4 :double) ;double (arg5 :double) ;double ) (defcfun "cairo_pattern_destroy" :void (arg0 :pointer) ;cairo_pattern_t * ) (defcfun "cairo_pattern_get_extend" cairo_extend_t (arg0 :pointer) ;cairo_pattern_t * ) (defcfun "cairo_pattern_get_filter" cairo_filter_t (arg0 :pointer) ;cairo_pattern_t * ) (defcfun "cairo_pattern_get_matrix" :void (arg0 :pointer) ;cairo_pattern_t * (arg1 :pointer) ;cairo_matrix_t * ) (defcfun "cairo_pattern_reference" :pointer (arg0 :pointer) ;cairo_pattern_t * ) (defcfun "cairo_pattern_set_extend" :void (arg0 :pointer) ;cairo_pattern_t * (arg1 cairo_extend_t)) (defcfun "cairo_pattern_set_filter" :void (arg0 :pointer) ;cairo_pattern_t * (arg1 cairo_filter_t)) (defcfun "cairo_pattern_set_matrix" :void (arg0 :pointer) ;cairo_pattern_t * (arg1 :pointer) ;const cairo_matrix_t * ) (defcfun "cairo_rectangle" :void (arg0 :pointer) ;cairo_t * (arg1 :double) ;double (arg2 :double) ;double (arg3 :double) ;double (arg4 :double) ;double ) (defcfun "cairo_reference" :pointer (arg0 :pointer) ;cairo_t * ) (defcfun "cairo_rel_curve_to" :void (arg0 :pointer) ;cairo_t * (arg1 :double) ;double (arg2 :double) ;double (arg3 :double) ;double (arg4 :double) ;double (arg5 :double) ;double (arg6 :double) ;double ) (defcfun "cairo_rel_move_to" :void (arg0 :pointer) ;cairo_t * (arg1 :double) ;double (arg2 :double) ;double ) (defcfun "cairo_reset_clip" :void (arg0 :pointer) ;cairo_t * ) (defcfun "cairo_rotate" :void (arg0 :pointer) ;cairo_t * (arg1 :double) ;double ) (defcfun "cairo_scale" :void (arg0 :pointer) ;cairo_t * (arg1 :double) ;double (arg2 :double) ;double ) (defcfun "cairo_select_font_face" :void (arg0 :pointer) ;cairo_t * (arg1 utf8-string) ;const char * (arg2 cairo_font_slant_t) (arg3 cairo_font_weight_t)) (defcfun "cairo_set_antialias" :void (arg0 :pointer) ;cairo_t * (arg1 cairo_antialias_t)) (defcfun "cairo_set_dash" :void (arg0 :pointer) ;cairo_t * (arg1 :pointer) ;const double * (arg2 :int) ;int (arg3 :double) ;double ) (defcfun "cairo_set_fill_rule" :void (arg0 :pointer) ;cairo_t * (arg1 cairo_fill_rule_t)) (defcfun "cairo_set_font_size" :void (arg0 :pointer) ;cairo_t * (arg1 :double) ;double ) (defcfun "cairo_set_line_cap" :void (arg0 :pointer) ;cairo_t * (arg1 cairo_line_cap_t)) (defcfun "cairo_set_line_join" :void (arg0 :pointer) ;cairo_t * (arg1 cairo_line_join_t)) (defcfun "cairo_set_line_width" :void (arg0 :pointer) ;cairo_t * (arg1 :double) ;double ) (defcfun "cairo_set_matrix" :void (arg0 :pointer) ;cairo_t * (arg1 :pointer) ;const cairo_matrix_t * ) (defcfun "cairo_set_miter_limit" :void (arg0 :pointer) ;cairo_t * (arg1 :double) ;double ) (defcfun "cairo_set_operator" :void (arg0 :pointer) ;cairo_t * (arg1 cairo_operator_t)) (defcfun "cairo_set_source" :void (arg0 :pointer) ;cairo_t * (arg1 :pointer) ;cairo_pattern_t * ) (defcfun "cairo_set_source_rgb" :void (arg0 :pointer) ;cairo_t * (arg1 :double) ;double (arg2 :double) ;double (arg3 :double) ;double ) (defcfun "cairo_set_source_rgba" :void (arg0 :pointer) ;cairo_t * (arg1 :double) ;double (arg2 :double) ;double (arg3 :double) ;double (arg4 :double) ;double ) (defcfun "cairo_set_source_surface" :void (arg0 :pointer) ;cairo_t * (arg1 :pointer) ;cairo_surface_t * (arg2 :double) (arg3 :double) ) (defcfun "cairo_set_tolerance" :void (arg0 :pointer) ;cairo_t * (arg1 :double) ;double ) (defcfun "cairo_show_glyphs" :void (arg0 :pointer) ;cairo_t * (arg1 :pointer) ;cairo_glyph_t * (arg2 :int) ;int ) (defcfun "cairo_show_page" :void (arg0 :pointer) ;cairo_t * ) (defcfun "cairo_show_text" :void (arg0 :pointer) ;cairo_t * (arg1 utf8-string) ;const char * ) (defcfun "cairo_status" cairo_status_t (arg0 :pointer) ;cairo_t * ) (defcfun "cairo_stroke" :void (arg0 :pointer) ;cairo_t * ) (defcfun "cairo_stroke_extents" :void (arg0 :pointer) ;cairo_t * (arg1 :pointer) ;double * (arg2 :pointer) ;double * (arg3 :pointer) ;double * (arg4 :pointer) ;double * ) (defcfun "cairo_stroke_preserve" :pointer (arg0 :pointer) ;cairo_t * ) (defcfun "cairo_surface_create_similar" :pointer (arg0 :pointer) ;cairo_surface_t * (arg1 cairo_content_t) (arg2 :int) ;int (arg3 :int) ;int ) (defcfun "cairo_surface_destroy" :pointer (arg0 :pointer) ;cairo_surface_t * ) (defcfun "cairo_surface_flush" :void (arg0 :pointer) ;cairo_surface_t * ) (defcfun "cairo_surface_mark_dirty" :void (arg0 :pointer) ;cairo_surface_t * ) (defcfun "cairo_surface_reference" :pointer (arg0 :pointer) ;cairo_surface_t * ) (defcfun "cairo_text_extents" :void (arg0 :pointer) ;cairo_t * (arg1 utf8-string) ;const char * (arg2 :pointer) ;cairo_text_extents_t * ) (defcfun "cairo_text_path" :void (arg0 :pointer) ;cairo_t * (arg1 utf8-string) ;const char * ) (defcfun "cairo_translate" :void (arg0 :pointer) ;cairo_t * (arg1 :double) ;double (arg2 :double) ;double ) (defcfun "g_free" :void (mem :pointer) ;gpointer ) (defcfun "g_idle_add" :unsigned-int (function :pointer) ;GSourceFunc (data :pointer) ;gpointer ) (defcfun "g_object_unref" :void (_object :pointer) ;gpointer ) (defcfun "g_signal_connect_data" :unsigned-long (instance :pointer) ;gpointer (detailed_signal utf8-string) ;const gchar * (c_handler :pointer) ;GCallback (data :pointer) ;gpointer (destroy_data :pointer) ;GClosureNotify (connect_flags GConnectFlags)) (defcfun "g_thread_init" :void (init :pointer) ;GThreadFunctions * ) (defcfun "g_value_init" :pointer (value :pointer) ;GValue * (g_type :unsigned-long) ;GType ) (defcfun "g_value_set_string" :void (value :pointer) ;GValue * (v_string utf8-string) ;const gchar * ) (defcfun "gdk_cairo_create" :pointer (drawable :pointer) ;GdkDrawable * ) (defcfun "gdk_colormap_alloc_color" :int (colormap :pointer) ;GdkColormap * (color :pointer) ;GdkColor * (writeable :int) ;gboolean (best_match :int) ;gboolean ) (defcfun "gdk_colormap_get_system" :pointer) (defcfun "gdk_display_flush" :void (display :pointer) ;GdkDisplay * ) (defcfun "gdk_display_get_default" :pointer) (defcfun "gdk_display_get_pointer" :void (display :pointer) ;GdkDisplay * (screen :pointer) ;GdkScreen ** (x :pointer) ;gint * (y :pointer) ;gint * (mask :pointer) ;GdkModifierType * ) (defcfun "gdk_drag_motion" :int (context :pointer) ;GdkDragContext * (dest_window :pointer) ;GdkWindow * (protocol GdkDragProtocol) (x_root :int) ;gint (y_root :int) ;gint (suggested_action GdkDragAction) (possible_actions GdkDragAction) (time :uint32) ;guint32 ) (defcfun "gdk_drag_status" :void (context :pointer) ;GdkDragContext * (action GdkDragAction) (time :uint32) ;guint32 ) (defcfun "gdk_draw_arc" :void (drawable :pointer) ;GdkDrawable * (gc :pointer) ;GdkGC * (filled :int) ;gboolean (x :int) ;gint (y :int) ;gint (width :int) ;gint (height :int) ;gint (angle1 :int) ;gint (angle2 :int) ;gint ) (defcfun "gdk_draw_drawable" :void (drawable :pointer) ;GdkDrawable * (gc :pointer) ;GdkGC * (src :pointer) ;GdkDrawable * (xsrc :int) ;gint (ysrc :int) ;gint (xdest :int) ;gint (ydest :int) ;gint (width :int) ;gint (height :int) ;gint ) (defcfun "gdk_draw_layout" :void (drawable :pointer) ;GdkDrawable * (gc :pointer) ;GdkGC * (x :int) ;int (y :int) ;int (layout :pointer) ;PangoLayout * ) (defcfun "gdk_draw_line" :void (drawable :pointer) ;GdkDrawable * (gc :pointer) ;GdkGC * (x1 :int) ;gint (y1 :int) ;gint (x2 :int) ;gint (y2 :int) ;gint ) (defcfun "gdk_draw_lines" :void (drawable :pointer) ;GdkDrawable * (gc :pointer) ;GdkGC * (points :pointer) ;GdkPoint * (npoints :int) ;gint ) (defcfun "gdk_draw_point" :void (drawable :pointer) ;GdkDrawable * (gc :pointer) ;GdkGC * (x :int) ;gint (y :int) ;gint ) (defcfun "gdk_draw_polygon" :void (drawable :pointer) ;GdkDrawable * (gc :pointer) ;GdkGC * (filled :int) ;gboolean (points :pointer) ;GdkPoint * (npoints :int) ;gint ) (defcfun "gdk_draw_rectangle" :void (drawable :pointer) ;GdkDrawable * (gc :pointer) ;GdkGC * (filled :int) ;gboolean (x :int) ;gint (y :int) ;gint (width :int) ;gint (height :int) ;gint ) (defcfun "gdk_drawable_get_clip_region" :pointer (drawable :pointer) ;GdkDrawable * ) (defcfun "gdk_drawable_get_depth" :int (drawable :pointer) ;GdkDrawable * ) (defcfun "gdk_drawable_unref" :void (drawable :pointer) ;GdkDrawable * ) (defcfun "gdk_error_trap_pop" :int) (defcfun "gdk_error_trap_push" :void) (defcfun "gdk_flush" :void) (defcfun "gdk_gc_new" :pointer (drawable :pointer) ;GdkDrawable * ) (defcfun "gdk_gc_set_background" :void (gc :pointer) ;GdkGC * (color :pointer) ;const GdkColor * ) (defcfun "gdk_gc_set_clip_region" :void (gc :pointer) ;GdkGC * (region :pointer) ;GdkRegion * ) (defcfun "gdk_gc_set_dashes" :void (gc :pointer) ;GdkGC * (dash_offset :int) ;gint (dash_list :pointer) ;gint8 * (n :int) ;gint ) (defcfun "gdk_gc_set_foreground" :void (gc :pointer) ;GdkGC * (color :pointer) ;const GdkColor * ) (defcfun "gdk_gc_set_function" :void (gc :pointer) ;GdkGC * (function GdkFunction)) (defcfun "gdk_gc_set_line_attributes" :void (gc :pointer) ;GdkGC * (line_width :int) ;gint (line_style GdkLineStyle) (cap_style GdkCapStyle) (join_style GdkJoinStyle)) (defcfun "gdk_gc_set_rgb_bg_color" :void (gc :pointer) ;GdkGC * (color :pointer) ;const GdkColor * ) (defcfun "gdk_gc_set_rgb_fg_color" :void (gc :pointer) ;GdkGC * (color :pointer) ;const GdkColor * ) (defcfun "gdk_gc_unref" :void (gc :pointer) ;GdkGC * ) (defcfun "gdk_pango_context_get" :pointer) (defcfun "gdk_pango_context_get_for_screen" :pointer (screen :pointer) ;GdkScreen * ) (defcfun "gdk_pixmap_new" :pointer (drawable :pointer) ;GdkDrawable * (width :int) ;gint (height :int) ;gint (depth :int) ;gint ) (defcfun "gdk_pointer_grab" GdkGrabStatus (window :pointer) ;GdkWindow * (owner_events :int) ;gboolean (event_mask GdkEventMask) (confine_to :pointer) ;GdkWindow * (cursor :pointer) ;GdkCursor * (time :uint32) ;guint32 ) (defcfun "gdk_pointer_ungrab" :void (time :uint32) ;guint32 ) (defcfun "gdk_region_destroy" :void (r :pointer) ;GdkRegion * ) (defcfun "gdk_region_new" :pointer) (defcfun "gdk_region_union" :void (region :pointer) ;GdkRegion * (other :pointer) ;GdkRegion * ) (defcfun "gdk_region_union_with_rect" :void (region :pointer) ;GdkRegion * (rect :pointer) ;GdkRectangle * ) (defcfun "gdk_screen_get_default" :pointer) (defcfun "gdk_screen_get_height" :int (screen :pointer) ;GdkScreen * ) (defcfun "gdk_screen_get_height_mm" :int (screen :pointer) ;GdkScreen * ) (defcfun "gdk_screen_get_root_window" :pointer (screen :pointer) ;GdkScreen * ) (defcfun "gdk_screen_get_width" :int (screen :pointer) ;GdkScreen * ) (defcfun "gdk_screen_get_width_mm" :int (screen :pointer) ;GdkScreen * ) (defcfun "gdk_threads_enter" :void) (defcfun "gdk_threads_init" :void) (defcfun "gdk_threads_leave" :void) (defcfun "gdk_window_clear_area" :void (window :pointer) ;GdkWindow * (x :int) ;gint (y :int) ;gint (width :int) ;gint (height :int) ;gint ) (defcfun "gdk_window_get_root_origin" :void (window :pointer) ;GdkWindow * (x :pointer) ;gint * (y :pointer) ;gint * ) (defcfun "gdk_window_invalidate_rect" :void (window :pointer) ;GdkWindow * (rect :pointer) ;GdkRectangle * (invalidate_children :int) ;gboolean ) (defcfun "gtk_adjustment_new" :pointer (value :double) ;gdouble (lower :double) ;gdouble (upper :double) ;gdouble (step_increment :double) ;gdouble (page_increment :double) ;gdouble (page_size :double) ;gdouble ) (defcfun "gtk_adjustment_set_value" :void (adjustment :pointer) ;GtkAdjustment * (value :double) ;gdouble ) (defcfun "gtk_bin_get_child" :pointer (bin :pointer) ;GtkBin * ) (defcfun "gtk_button_new_with_label" :pointer (label utf8-string) ;const gchar * ) (defcfun "gtk_cell_renderer_text_new" :pointer) (defcfun "gtk_check_button_new_with_label" :pointer (label utf8-string) ;const gchar * ) (defcfun "gtk_combo_box_append_text" :void (combo_box :pointer) ;GtkComboBox * (text utf8-string) ;const gchar * ) (defcfun "gtk_combo_box_get_active" :int (combo_box :pointer) ;GtkComboBox * ) (defcfun "gtk_combo_box_new_text" :pointer) (defcfun "gtk_combo_box_set_active" :void (combo_box :pointer) ;GtkComboBox * (index_ :int) ;gint ) (defcfun "gtk_container_add" :void (container :pointer) ;GtkContainer * (widget :pointer) ;GtkWidget * ) (defcfun "gtk_event_box_new" :pointer) (defcfun "gtk_event_box_set_above_child" :void (event_box :pointer) ;GtkEventBox * (above_child :int) ;gboolean ) (defcfun "gtk_event_box_set_visible_window" :void (event_box :pointer) ;GtkEventBox * (visible_window :int) ;gboolean ) (defcfun "gtk_events_pending" :int) (defcfun "gtk_fixed_move" :void (fixed :pointer) ;GtkFixed * (widget :pointer) ;GtkWidget * (x :int) ;gint (y :int) ;gint ) (defcfun "gtk_fixed_new" :pointer) (defcfun "gtk_fixed_put" :void (fixed :pointer) ;GtkFixed * (widget :pointer) ;GtkWidget * (x :int) ;gint (y :int) ;gint ) (defcfun "gtk_fixed_set_has_window" :void (fixed :pointer) ;GtkFixed * (has_window :int) ;gboolean ) (defcfun "gtk_frame_new" :pointer (label utf8-string) ;const gchar * ) (defcfun "gtk_get_current_event_time" :uint32) (defcfun "gtk_hscale_new_with_range" :pointer (min :double) ;gdouble (max :double) ;gdouble (step :double) ;gdouble ) (defcfun "gtk_hscrollbar_new" :pointer (adjustment :pointer) ;GtkAdjustment * ) (defcfun "gtk_init" :void (argc :pointer) ;int * (argv :pointer) ;char *** ) (defcfun "gtk_label_new" :pointer (str utf8-string) ;const gchar * ) (defcfun "gtk_label_set_text" :void (label :pointer) ;GtkLabel * (str utf8-string) ;const gchar * ) (defcfun "gtk_list_store_append" :void (list_store :pointer) ;GtkListStore * (iter :pointer) ;GtkTreeIter * ) (defcfun "gtk_list_store_clear" :void (list_store :pointer) ;GtkListStore * ) (defcfun "gtk_list_store_newv" :pointer (n_columns :int) ;gint (types :pointer) ;GType * ) (defcfun "gtk_list_store_set_value" :void (list_store :pointer) ;GtkListStore * (iter :pointer) ;GtkTreeIter * (column :int) ;gint (value :pointer) ;GValue * ) (defcfun "gtk_main_iteration_do" :int (blocking :int) ;gboolean ) (defcfun "gtk_menu_bar_new" :pointer) (defcfun "gtk_menu_item_new_with_label" :pointer (label utf8-string) ;const gchar * ) (defcfun "gtk_menu_item_set_submenu" :void (menu_item :pointer) ;GtkMenuItem * (submenu :pointer) ;GtkWidget * ) (defcfun "gtk_menu_new" :pointer) (defcfun "gtk_menu_popup" :void (menu :pointer) ;GtkMenu * (parent_menu_shell :pointer) ;GtkWidget * (parent_menu_item :pointer) ;GtkWidget * (func :pointer) ;GtkMenuPositionFunc (data :pointer) ;gpointer (button :unsigned-int) ;guint (activate_time :uint32) ;guint32 ) (defcfun "gtk_menu_shell_append" :void (menu_shell :pointer) ;GtkMenuShell * (child :pointer) ;GtkWidget * ) (defcfun "gtk_notebook_append_page" :int (notebook :pointer) ;GtkNotebook * (child :pointer) ;GtkWidget * (tab_label :pointer) ;GtkWidget * ) (defcfun "gtk_notebook_get_current_page" :int (notebook :pointer) ;GtkNotebook * ) (defcfun "gtk_notebook_get_tab_label" :pointer (notebook :pointer) ;GtkNotebook * (child :pointer) ;GtkWidget * ) (defcfun "gtk_notebook_insert_page" :int (notebook :pointer) ;GtkNotebook * (child :pointer) ;GtkWidget * (tab_label :pointer) ;GtkWidget * (position :int) ;gint ) (defcfun "gtk_notebook_new" :pointer) (defcfun "gtk_notebook_remove_page" :void (notebook :pointer) ;GtkNotebook * (page_num :int) ;gint ) (defcfun "gtk_notebook_reorder_child" :void (notebook :pointer) ;GtkNotebook * (child :pointer) ;GtkWidget * (position :int) ;gint ) (defcfun "gtk_notebook_set_current_page" :void (notebook :pointer) ;GtkNotebook * (page_num :int) ;gint ) (defcfun "gtk_radio_button_get_group" :pointer (radio_button :pointer) ;GtkRadioButton * ) (defcfun "gtk_radio_button_new_with_label" :pointer (group :pointer) ;GSList * (label utf8-string) ;const gchar * ) (defcfun "gtk_range_get_adjustment" :pointer (range :pointer) ;GtkRange * ) (defcfun "gtk_range_get_value" :double (range :pointer) ;GtkRange * ) (defcfun "gtk_range_set_adjustment" :void (range :pointer) ;GtkRange * (adjustment :pointer) ;GtkAdjustment * ) (defcfun "gtk_scale_set_digits" :void (scale :pointer) ;GtkScale * (digits :int) ;gint ) (defcfun "gtk_scale_set_draw_value" :void (scale :pointer) ;GtkScale * (draw_value :int) ;gboolean ) (defcfun "gtk_scrolled_window_new" :pointer (hadjustment :pointer) ;GtkAdjustment * (vadjustment :pointer) ;GtkAdjustment * ) (defcfun "gtk_scrolled_window_set_policy" :void (scrolled_window :pointer) ;GtkScrolledWindow * (hscrollbar_policy GtkPolicyType) (vscrollbar_policy GtkPolicyType)) (defcfun "gtk_separator_menu_item_new" :pointer) (defcfun "gtk_toggle_button_set_active" :void (toggle_button :pointer) ;GtkToggleButton * (is_active :int) ;gboolean ) (defcfun "gtk_tree_path_free" :void (path :pointer) ;GtkTreePath * ) (defcfun "gtk_tree_path_get_indices" :pointer (path :pointer) ;GtkTreePath * ) (defcfun "gtk_tree_selection_select_path" :void (selection :pointer) ;GtkTreeSelection * (path :pointer) ;GtkTreePath * ) (defcfun "gtk_tree_selection_selected_foreach" :void (selection :pointer) ;GtkTreeSelection * (func :pointer) ;GtkTreeSelectionForeachFunc (data :pointer) ;gpointer ) (defcfun "gtk_tree_selection_set_mode" :void (selection :pointer) ;GtkTreeSelection * (type GtkSelectionMode)) (defcfun "gtk_tree_selection_set_select_function" :void (selection :pointer) ;GtkTreeSelection * (func :pointer) ;GtkTreeSelectionFunc (data :pointer) ;gpointer (destroy :pointer) ;GtkDestroyNotify ) (defcfun "gtk_tree_selection_unselect_all" :void (selection :pointer) ;GtkTreeSelection * ) (defcfun "gtk_tree_view_column_add_attribute" :void (tree_column :pointer) ;GtkTreeViewColumn * (cell_renderer :pointer) ;GtkCellRenderer * (attribute utf8-string) ;const gchar * (column :int) ;gint ) (defcfun "gtk_tree_view_column_new" :pointer) (defcfun "gtk_tree_view_column_pack_start" :void (tree_column :pointer) ;GtkTreeViewColumn * (cell :pointer) ;GtkCellRenderer * (expand :int) ;gboolean ) (defcfun "gtk_tree_view_column_set_title" :void (tree_column :pointer) ;GtkTreeViewColumn * (title utf8-string) ;const gchar * ) (defcfun "gtk_tree_view_get_hadjustment" :pointer (tree_view :pointer) ;GtkTreeView * ) (defcfun "gtk_tree_view_get_model" :pointer (tree_view :pointer) ;GtkTreeView * ) (defcfun "gtk_tree_view_get_selection" :pointer (tree_view :pointer) ;GtkTreeView * ) (defcfun "gtk_tree_view_get_vadjustment" :pointer (tree_view :pointer) ;GtkTreeView * ) (defcfun "gtk_tree_view_insert_column" :int (tree_view :pointer) ;GtkTreeView * (column :pointer) ;GtkTreeViewColumn * (position :int) ;gint ) (defcfun "gtk_tree_view_new_with_model" :pointer (model :pointer) ;GtkTreeModel * ) (defcfun "gtk_vscale_new_with_range" :pointer (min :double) ;gdouble (max :double) ;gdouble (step :double) ;gdouble ) (defcfun "gtk_vscrollbar_new" :pointer (adjustment :pointer) ;GtkAdjustment * ) (defcfun "gtk_widget_add_events" :void (widget :pointer) ;GtkWidget * (events :int) ;gint ) (defcfun "gtk_widget_destroy" :void (widget :pointer) ;GtkWidget * ) (defcfun "gtk_widget_get_child_requisition" :void (widget :pointer) ;GtkWidget * (requisition :pointer) ;GtkRequisition * ) (defcfun "gtk_widget_get_events" :int (widget :pointer) ;GtkWidget * ) (defcfun "gtk_widget_get_parent" :pointer (widget :pointer) ;GtkWidget * ) (defcfun "gtk_widget_get_pointer" :void (widget :pointer) ;GtkWidget * (x :pointer) ;gint * (y :pointer) ;gint * ) (defcfun "gtk_widget_get_size_request" :void (widget :pointer) ;GtkWidget * (width :pointer) ;gint * (height :pointer) ;gint * ) (defcfun "gtk_widget_grab_focus" :void (widget :pointer) ;GtkWidget * ) (defcfun "gtk_widget_hide" :void (widget :pointer) ;GtkWidget * ) (defcfun "gtk_widget_hide_all" :void (widget :pointer) ;GtkWidget * ) (defcfun "gtk_widget_modify_bg" :void (widget :pointer) ;GtkWidget * (state GtkStateType) (color :pointer) ;const GdkColor * ) (defcfun "gtk_widget_modify_fg" :void (widget :pointer) ;GtkWidget * (state GtkStateType) (color :pointer) ;const GdkColor * ) (defcfun "gtk_widget_queue_draw" :void (widget :pointer) ;GtkWidget * ) (defcfun "gtk_widget_set_double_buffered" :void (widget :pointer) ;GtkWidget * (double_buffered :int) ;gboolean ) (defcfun "gtk_widget_set_events" :void (widget :pointer) ;GtkWidget * (events :int) ;gint ) (defcfun "gtk_widget_set_sensitive" :void (widget :pointer) ;GtkWidget * (sensitive :int) ;gboolean ) (defcfun "gtk_widget_set_size_request" :void (widget :pointer) ;GtkWidget * (width :int) ;gint (height :int) ;gint ) (defcfun "gtk_widget_show" :void (widget :pointer) ;GtkWidget * ) (defcfun "gtk_widget_show_all" :void (widget :pointer) ;GtkWidget * ) (defcfun "gtk_widget_size_request" :void (widget :pointer) ;GtkWidget * (requisition :pointer) ;GtkRequisition * ) (defcfun "gtk_window_get_focus" :pointer (window :pointer)) (defcfun "gtk_window_move" :void (window :pointer) ;GtkWindow * (x :int) ;gint (y :int) ;gint ) (defcfun "gtk_window_new" :pointer (type GtkWindowType)) (defcfun "gtk_window_resize" :void (window :pointer) ;GtkWindow * (width :int) ;gint (height :int) ;gint ) (defcfun "gtk_window_set_default_size" :void (window :pointer) ;GtkWindow * (width :int) ;gint (height :int) ;gint ) (defcfun "gtk_window_set_geometry_hints" :void (window :pointer) ;GtkWindow * (geometry_widget :pointer) ;GtkWidget * (geometry :pointer) ;GdkGeometry * (geom_mask GdkWindowHints)) (defcfun "gtk_window_set_title" :void (window :pointer) ;GtkWindow * (title utf8-string) ;const gchar * ) (defcfun "pango_cairo_create_layout" :pointer (cr :pointer) ;cairo_t * ) (defcfun "pango_cairo_show_layout" :void (cr :pointer) ;cairo_t * (layout :pointer) ;PangoLayout * ) (defcfun "pango_context_get_font_map" :pointer (context :pointer) ;PangoContext * ) (defcfun "pango_context_get_metrics" :pointer (context :pointer) ;PangoContext * (desc :pointer) ;const PangoFontDescription * (language :pointer) ;PangoLanguage * ) (defcfun "pango_context_list_families" :void (context :pointer) ;PangoContext * (families :pointer) ;PangoFontFamily *** (n_families :pointer) ;int * ) (defcfun "pango_context_load_font" :pointer (context :pointer) ;PangoContext * (desc :pointer) ;const PangoFontDescription * ) (defcfun "pango_font_describe" :pointer (font :pointer) ;PangoFont * ) (defcfun "pango_font_description_free" :void (desc :pointer) ;PangoFontDescription * ) (defcfun "pango_font_description_from_string" :pointer (str utf8-string) ;const char * ) (defcfun "pango_font_description_get_family" utf8-string (desc :pointer) ;const PangoFontDescription * ) (defcfun "pango_font_description_new" :pointer) (defcfun "pango_font_description_set_absolute_size" :void (desc :pointer) ;PangoFontDescription * (size :double) ;double ) (defcfun "pango_font_description_set_family" :void (desc :pointer) ;PangoFontDescription * (family utf8-string) ;const char * ) (defcfun "pango_font_description_set_size" :void (desc :pointer) ;PangoFontDescription * (size :int) ;gint ) (defcfun "pango_font_description_set_style" :void (desc :pointer) ;PangoFontDescription * (style PangoStyle)) (defcfun "pango_font_description_set_weight" :void (desc :pointer) ;PangoFontDescription * (weight PangoWeight)) (defcfun "pango_font_description_to_string" utf8-string (desc :pointer) ;const PangoFontDescription * ) (defcfun "pango_font_face_get_face_name" utf8-string (face :pointer) ;PangoFontFace * ) (defcfun "pango_font_face_list_sizes" :void (face :pointer) ;PangoFontFace * (sizes :pointer) ;int ** (n_sizes :pointer) ;int * ) (defcfun "pango_font_family_get_name" utf8-string (family :pointer) ;PangoFontFamily * ) (defcfun "pango_font_family_is_monospace" :int (family :pointer) ;PangoFontFamily * ) (defcfun "pango_font_family_list_faces" :void (family :pointer) ;PangoFontFamily * (faces :pointer) ;PangoFontFace *** (n_faces :pointer) ;int * ) (defcfun "pango_font_map_load_font" :pointer (fontmap :pointer) ;PangoFontMap * (context :pointer) ;PangoContext * (desc :pointer) ;const PangoFontDescription * ) (defcfun "pango_font_metrics_get_approximate_char_width" :int (metrics :pointer) ;PangoFontMetrics * ) (defcfun "pango_font_metrics_get_ascent" :int (metrics :pointer) ;PangoFontMetrics * ) (defcfun "pango_font_metrics_get_descent" :int (metrics :pointer) ;PangoFontMetrics * ) (defcfun "pango_font_metrics_unref" :void (metrics :pointer) ;PangoFontMetrics * ) (defcfun "pango_layout_get_context" :pointer (layout :pointer) ;PangoLayout * ) (defcfun "pango_layout_get_line" :pointer (layout :pointer) ;PangoLayout * (line :int) ;int ) (defcfun "pango_layout_get_line_count" :int (layout :pointer) ;PangoLayout * ) (defcfun "pango_layout_get_pixel_extents" :void (layout :pointer) ;PangoLayout * (ink_rect :pointer) ;PangoRectangle * (logical_rect :pointer) ;PangoRectangle * ) (defcfun "pango_layout_get_pixel_size" :void (layout :pointer) ;PangoLayout * (width :pointer) ;int * (height :pointer) ;int * ) (defcfun "pango_layout_get_size" :void (layout :pointer) ;PangoLayout * (width :pointer) ;int * (height :pointer) ;int * ) (defcfun "pango_layout_line_get_pixel_extents" :void (layout_line :pointer) ;PangoLayoutLine * (ink_rect :pointer) ;PangoRectangle * (logical_rect :pointer) ;PangoRectangle * ) (defcfun "pango_layout_new" :pointer (context :pointer) ;PangoContext * ) (defcfun "pango_layout_set_font_description" :void (layout :pointer) ;PangoLayout * (desc :pointer) ;const PangoFontDescription * ) (defcfun "pango_layout_set_single_paragraph_mode" :void (layout :pointer) ;PangoLayout * (setting :int) ;gboolean ) (defcfun "pango_layout_set_spacing" :void (layout :pointer) ;PangoLayout * (spacing :int) ;int ) (defcfun "pango_layout_set_text" :void (layout :pointer) ;PangoLayout * (text utf8-string) ;const char * (length :int) ;int ) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/gtkairo/pango.lisp0000640000175000017500000003370410545255050022152 0ustar pdmpdm;;; -*- Mode: Lisp; -*- ;;; (c) copyright 2006 David Lichteblau (david@lichteblau.com) ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this software and associated documentation files (the ;;; "Software"), to deal in the Software without restriction, including ;;; without limitation the rights to use, copy, modify, merge, publish, ;;; distribute, sublicense, and/or sell copies of the Software, and to ;;; permit persons to whom the Software is furnished to do so, subject to ;;; the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. ;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY ;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, ;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. (in-package :clim-gtkairo) ;;;; Helper macros. (defmacro with-pango-layout ((layout-var medium &key text-style text) &body body) `(invoke-with-pango-layout (lambda (,layout-var) ,@body) ,medium :text-style ,text-style :text ,text)) (defmacro with-text-style-font-description ((var text-style) &body body) `(invoke-with-text-style-font-description (lambda (,var) ,@body) ,text-style)) (defmacro with-font-description ((var description) &body body) `(invoke-with-font-description (lambda (,var) ,@body) ,description)) (defmacro with-font-metrics ((var context desc) &body body) `(invoke-with-font-metrics (lambda (,var) ,@body) ,context ,desc)) (defmacro with-pango-context ((var medium) &body body) `(invoke-with-pango-context (lambda (,var) ,@body) ,medium)) (defun configure-pango-layout (layout &key text-style text) (when text-style (with-text-style-font-description (desc (etypecase text-style (text-style text-style) (medium (merge-text-styles (medium-text-style text-style) (medium-default-text-style text-style))))) (pango_layout_set_font_description layout desc))) (when text (pango_layout_set_text layout text -1))) (defgeneric invoke-with-pango-layout (fn medium &key text-style text)) (defun invoke-with-font-description (fn desc) (unwind-protect (funcall fn desc) (pango_font_description_free desc))) (defun invoke-with-text-style-font-description (fn text-style) (with-font-description (desc (make-font-description text-style)) (funcall fn desc))) (defun invoke-with-font-metrics (fn context desc) (let ((metrics (pango_context_get_metrics context desc (cffi:null-pointer)))) (unwind-protect (funcall fn metrics) (pango_font_metrics_unref metrics)))) (defun invoke-with-pango-context (fn medium) (declare (ignore medium)) ;fixme! (let ((context (gdk_pango_context_get))) (unwind-protect (funcall fn context) (g_object_unref context)))) ;;;; Pango text drawing and metric functions. (defvar *default-font-families* ;; Finding a good monospace font isn't easy: ;; - "Free Mono" is totally broken. ;; - "Courier", "Nimbus Mono L", "Andale Mono" have weird "Bold" face ;; metrics. ;; - "Courier New" and "Bitstream Vera Sans Mono" work well. ;; (Test case is Climacs.) '(:fix "Courier New" :serif "serif" :sans-serif "sans") "A plist mapping the standard font family keywords :fix, :serif, and :sans-serif to Pango font names. Example: (setf (getf *default-font-families* :fix) \"Bitstream Vera Sans Mono\")") (defun make-font-description (text-style) (multiple-value-bind (family face size) (text-style-components (merge-text-styles text-style *default-text-style*)) (when (listp face) ;; Ein Pfusch ist das! (setf face (intern (format nil "~A-~A" (symbol-name (first face)) (symbol-name (second face))) :keyword))) (let ((family (if (stringp family) family (or (getf *default-font-families* (if (eq family :fixed) :fix family)) (error "unknown font family: ~A" family)))) (size (case size ;; points: ;;; (:tiny 6) ;;; (:very-small 8) ;;; (:small 10) ;;; (:normal 12) ;;; (:large 14) ;;; (:very-large 16) ;;; (:huge 24) ;; pixels: (:tiny 8) (:very-small 11) (:small 13) (:normal 16) (:large 18) (:very-large 21) (:huge 32) (otherwise (truncate size)))) desc) (if (stringp face) (setf desc (pango_font_description_from_string (concatenate 'string ", " face))) (let ((weight (ecase face ((:roman :italic :oblique) :PANGO_WEIGHT_NORMAL) ((:bold :bold-italic :italic-bold :bold-oblique :oblique-bold) :PANGO_WEIGHT_BOLD))) (style (ecase face ((:roman :bold) :PANGO_STYLE_NORMAL) ((:italic :bold-italic :italic-bold) :PANGO_STYLE_ITALIC) ((:oblique :bold-oblique :oblique-bold) :PANGO_STYLE_OBLIQUE)))) (setf desc (pango_font_description_new)) (pango_font_description_set_weight desc weight) (pango_font_description_set_style desc style))) (pango_font_description_set_family desc family) (pango_font_description_set_absolute_size desc (df (* size PANGO_SCALE))) desc))) (defun pango-layout-get-pixel-size (layout) ;;; (cffi:with-foreign-object (rect 'pangorectangle) ;;; (pango_layout_get_pixel_extents ;;; layout ;;; (cffi:null-pointer) ;;; rect) ;;; (cffi:with-foreign-slots ((x y width height) rect pangorectangle) ;;; (tr x y width height) ;;; (values width (- height y)))) (cffi:with-foreign-object (&w :int) (cffi:with-foreign-object (&h :int) (pango_layout_get_pixel_size layout &w &h) (values (cffi:mem-aref &w :int) (cffi:mem-aref &h :int))))) (defun pango-layout-line-get-pixel-extents (layout line-index) (when (minusp line-index) (incf line-index (pango_layout_get_line_count layout))) (cffi:with-foreign-object (rect 'pangorectangle) (pango_layout_line_get_pixel_extents (pango_layout_get_line layout line-index) (cffi:null-pointer) rect) (cffi:with-foreign-slots ((x y width height) rect pangorectangle) (values x y width height)))) (defun pango-layout-get-ink-rectangle (layout) (cffi:with-foreign-object (rect 'pangorectangle) (pango_layout_get_pixel_extents layout rect (cffi:null-pointer)) (cffi:with-foreign-slots ((x y width height) rect pangorectangle) (values x y width height)))) (defmethod text-size :before ((medium cairo-metrik-medium) string &key text-style (start 0) end) (with-medium (medium) (with-slots (cr) medium (cairo_identity_matrix cr)))) (defmethod text-size ((medium metrik-medium-mixin) string &key text-style (start 0) end) (with-medium (medium) ;; -> width height final-x final-y baseline (when (characterp string) (setf string (string string))) (setf text-style (or text-style (make-text-style nil nil nil))) (setf text-style (merge-text-styles text-style (medium-default-text-style medium))) (with-pango-layout (layout medium :text-style text-style :text (unless (eql start end) (subseq string start end))) (multiple-value-bind (width height) (pango-layout-get-pixel-size layout) (multiple-value-bind (first-x first-y first-width first-height) (pango-layout-line-get-pixel-extents layout 0) (declare (ignorable first-x first-y first-width first-height)) (multiple-value-bind (final-x final-y final-width final-height) (pango-layout-line-get-pixel-extents layout -1) (declare (ignorable final-x final-y final-width final-height)) (values width height final-width (- height final-height) (abs first-y)))))))) (defmethod climi::text-bounding-rectangle* :before ((medium cairo-metrik-medium) string &key text-style (start 0) end) (with-medium (medium) (with-slots (cr) medium (cairo_identity_matrix cr)))) (defmethod climi::text-bounding-rectangle* ((medium metrik-medium-mixin) string &key text-style (start 0) end) (with-medium (medium) ;; -> left ascent right descent (when (characterp string) (setf string (string string))) (setf text-style (or text-style (make-text-style nil nil nil))) (setf text-style (merge-text-styles text-style (medium-default-text-style medium))) (with-pango-layout (layout medium :text-style text-style :text (unless (eql start end) (subseq string start end))) (multiple-value-bind (x y width height) (pango-layout-get-ink-rectangle layout) (let* ((first-y (nth-value 1 (pango-layout-line-get-pixel-extents layout 0))) (ascent (- (abs first-y) y))) (values x (ceiling (- ascent)) (ceiling (+ width (max 0 x))) (ceiling (- height ascent)))))))) ;; (pango_layout_get_context layout) (defun resolve-font-description (context desc) (pango_font_describe (pango_context_load_font context desc))) (defun font-description-to-font-family (context desc) (with-font-description (desc* (resolve-font-description context desc)) (find (pango_font_description_get_family desc*) (pango-context-list-families context) :key #'pango_font_family_get_name :test #'equal))) (defmethod text-style-fixed-width-p (text-style (medium metrik-medium-mixin)) (with-gtk () (with-pango-context (context medium) (with-text-style-font-description (desc text-style) (let ((family (font-description-to-font-family context desc))) (assert family) (not (zerop (pango_font_family_is_monospace family)))))))) (defmethod text-style-ascent (text-style (medium metrik-medium-mixin)) ;;; (with-gtk () ;;; (with-pango-context (context medium) ;;; (with-text-style-font-description (desc text-style) ;;; (with-font-metrics (metrics context desc) ;;; (ceiling (pango_font_metrics_get_ascent metrics) PANGO_SCALE))))) ;; here's a dummy implementation guaranteing ascent+descent=height: (multiple-value-bind (width height final-x final-y baseline) (text-size medium "foo" :text-style text-style) (declare (ignore width height final-x final-y)) baseline)) (defmethod text-style-descent (text-style (medium metrik-medium-mixin)) ;;; (with-gtk () ;;; (with-pango-context (context medium) ;;; (with-text-style-font-description (desc text-style) ;;; (with-font-metrics (metrics context desc) ;;; (ceiling (pango_font_metrics_get_descent metrics) PANGO_SCALE))))) ;; here's a dummy implementation guaranteing ascent+descent=height: (multiple-value-bind (width height final-x final-y baseline) (text-size medium "foo" :text-style text-style) (declare (ignore width final-x final-y)) (- height baseline))) (defmethod text-style-height (text-style (medium metrik-medium-mixin)) (nth-value 1 (text-size medium "foo" :text-style text-style)) ;;; (+ (text-style-ascent text-style medium) ;;; (text-style-descent text-style medium)) ) (defmethod text-style-width (text-style (medium metrik-medium-mixin)) (with-gtk () (with-pango-context (context medium) (with-text-style-font-description (desc text-style) (with-font-metrics (metrics context desc) (ceiling (pango_font_metrics_get_approximate_char_width metrics) PANGO_SCALE)))))) ;; font listing (defclass pango-font-family (clim-extensions:font-family) ((native-family :initarg :native-family :accessor native-family))) (defclass pango-font-face (clim-extensions:font-face) ((native-face :initarg :native-face :accessor native-face))) (defun invoke-lister (fn type) (cffi:with-foreign-object (&array :pointer) (cffi:with-foreign-object (&n :int) (funcall fn &array &n) (let ((array (cffi:mem-aref &array :pointer))) (if (cffi:null-pointer-p array) :null (prog1 (loop for i from 0 below (cffi:mem-aref &n :int) collect (cffi:mem-aref array type i)) (g_free array))))))) (defun pango-context-list-families (context) (invoke-lister (lambda (&families &n) (pango_context_list_families context &families &n)) :pointer)) (defun pango-font-family-list-faces (family) (invoke-lister (lambda (&faces &n) (pango_font_family_list_faces family &faces &n)) :pointer)) (defun pango-font-face-list-sizes (face) (invoke-lister (lambda (&sizes &n) (pango_font_face_list_sizes face &sizes &n)) :int)) (defmethod clim-extensions:port-all-font-families ((port gtkairo-port) &key invalidate-cache) (declare (ignore invalidate-cache)) (sort (mapcar (lambda (native-family) (make-instance 'pango-font-family :native-family native-family :port port :name (pango_font_family_get_name native-family))) (pango-context-list-families (global-pango-context port))) #'string< :key #'clim-extensions:font-family-name)) (defmethod clim-extensions:font-family-all-faces ((family pango-font-family)) (sort (mapcar (lambda (native-face) (make-instance 'pango-font-face :native-face native-face :family family :name (pango_font_face_get_face_name native-face))) (pango-font-family-list-faces (native-family family))) #'string< :key #'clim-extensions:font-face-name)) (defmethod clim-extensions:font-face-all-sizes ((face pango-font-face)) (let ((sizes (pango-font-face-list-sizes (native-face face)))) (if (eq sizes :null) (loop for i from 0 below 200 collect i) (mapcar (lambda (p) ;; das mit dem round kommt mir aber nicht koscher vor (round (/ p PANGO_SCALE))) sizes)))) (defmethod clim-extensions:font-face-scalable-p ((face pango-font-face)) (eq :null (pango-font-face-list-sizes (native-face face)))) (defmethod clim-extensions:font-face-text-style ((face pango-font-face) &optional size) (make-text-style (clim-extensions:font-family-name (clim-extensions:font-face-family face)) (clim-extensions:font-face-name face) size)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/gtkairo/cairo.lisp0000644000175000017500000007733211345155772022165 0ustar pdmpdm;;; -*- Mode: Lisp; -*- ;;; (c) copyright 2005 by Gilbert Baumann ;;; (c) copyright 2006 David Lichteblau (david@lichteblau.com) ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this software and associated documentation files (the ;;; "Software"), to deal in the Software without restriction, including ;;; without limitation the rights to use, copy, modify, merge, publish, ;;; distribute, sublicense, and/or sell copies of the Software, and to ;;; permit persons to whom the Software is furnished to do so, subject to ;;; the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. ;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY ;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, ;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. (in-package :clim-gtkairo) ;;; Locking rule for this file: Dokumented entry points in the CLIM ;;; package use WITH-GTK, internal functions can rely on that. (defclass cairo-medium (gtkairo-medium) ((cr :initform nil :initarg :cr :accessor cr) (flipping-original-cr :initform nil :accessor flipping-original-cr) (flipping-pixmap :initform nil :accessor flipping-pixmap) (flipping-region :accessor flipping-region) (surface :initarg :surface :accessor surface) (last-seen-sheet :accessor last-seen-sheet) (last-seen-region :accessor last-seen-region))) (defmethod initialize-instance :after ((instance cairo-medium) &key cr) (unless cr (setf (last-seen-sheet instance) nil))) (defparameter *antialiasingp* t) (defmethod invoke-with-medium (fn (medium cairo-medium)) (when (or (cr medium) (climi::port-lookup-mirror (port medium) (medium-sheet medium))) (with-gtk () (multiple-value-prog1 (funcall fn) (when (flipping-original-cr medium) (apply-flipping-ink medium)))))) (defun sheet-changed-behind-our-back-p (medium) (and (slot-boundp medium 'last-seen-sheet) (or (not (eq (last-seen-sheet medium) (medium-sheet medium))) (not (region-equal (last-seen-region medium) (sheet-region (medium-sheet medium))))))) (defmethod metrik-medium-for ((medium cairo-medium)) (cairo-metrik-medium (port medium))) (defun set-antialias (cr) (cairo_set_antialias cr (if *antialiasingp* :CAIRO_ANTIALIAS_DEFAULT :CAIRO_ANTIALIAS_NONE))) (defun sync-sheet (medium) (when (medium-sheet medium) ;ignore the metrik-medium (setf (gethash medium (dirty-mediums (port medium))) t)) (when (or (null (cr medium)) (sheet-changed-behind-our-back-p medium)) (with-medium (medium) (let* ((mirror (medium-mirror medium)) (drawable (mirror-drawable mirror))) (setf (cr medium) (gdk_cairo_create drawable)) (dispose-flipping-pixmap medium) (pushnew medium (mirror-mediums mirror)) (set-antialias (cr medium))) (setf (last-seen-sheet medium) (medium-sheet medium)) (setf (last-seen-region medium) (sheet-region (medium-sheet medium)))))) (defun dispose-flipping-pixmap (medium) (when (flipping-pixmap medium) (gdk_drawable_unref (flipping-pixmap medium)) (setf (flipping-pixmap medium) nil))) ;;;; ------------------------------------------------------------------------ ;;;; Drawing Options ;;;; (defun sync-transformation (medium &optional extra-transformation) (with-slots (cr) medium (cffi:with-foreign-object (matrix 'cairo_matrix_t) (let ((tr (if (medium-sheet medium) (sheet-native-transformation (medium-sheet medium)) clim:+identity-transformation+))) (when extra-transformation (setf tr (compose-transformations extra-transformation tr))) (multiple-value-bind (mxx mxy myx myy tx ty) (climi::get-transformation tr) ;; Make sure not to hand transformations to cairo that it won't ;; like, since debugging gets ugly once a cairo context goes ;; into an error state: (invert-transformation tr) (cairo_matrix_init matrix (df mxx) (df mxy) (df myx) (df myy) (df tx) (df ty)) (cairo_set_matrix cr matrix)))))) (defmacro with-cairo-matrix ((matrix transformation) &body body) `(cffi:with-foreign-object (,matrix 'cairo_matrix_t) (multiple-value-bind (mxx mxy myx myy tx ty) (climi::get-transformation ,transformation) (cairo_matrix_init ,matrix (df mxx) (df mxy) (df myx) (df myy) (df tx) (df ty)) (locally ,@body)))) ;;; ink (defmethod sync-ink :before (medium new-value) (with-slots (cr) medium (cairo_set_operator cr :over))) (defmethod sync-ink (medium (new-value (eql clim:+foreground-ink+))) (sync-ink medium (clim:medium-foreground medium))) ;### circles? (defmethod sync-ink (medium (new-value (eql clim:+background-ink+))) (sync-ink medium (clim:medium-background medium))) ;### circles? (defmethod sync-ink (medium (new-value clim:opacity)) (with-slots (cr) medium (cond ((= 0 (opacity-value new-value)) (cairo_set_source_rgba cr 0d0 0d0 0d0 0d0)) ((= 1 (opacity-value new-value)) (sync-ink medium (clim:medium-foreground medium))) (t (sync-ink medium (clim:compose-in (clim:medium-foreground medium) new-value)))))) (defmethod sync-ink (medium (new-value climi::uniform-compositum)) (with-slots (cr) medium (with-slots ((ink climi::ink) (mask climi::mask)) new-value (multiple-value-bind (red green blue) (clim:color-rgb ink) (cairo_set_source_rgba cr (df red) (df green) (df blue) (df (clim:opacity-value mask))))))) (defmethod sync-ink (medium (new-value clim:color)) (with-slots (cr) medium (multiple-value-bind (red green blue) (clim:color-rgb new-value) (cairo_set_source_rgba cr (df red) (df green) (df blue) (df 1.0d0))))) (defvar *pattern-hash* (make-hash-table)) (defun pattern-cairo-pattern (medium pattern) (or (gethash pattern *pattern-hash*) (setf (gethash pattern *pattern-hash*) (let ((s (make-cairo-surface medium (pattern-width pattern) (pattern-height pattern)))) (draw-design s pattern) (cairo_pattern_create_for_surface (slot-value s 'surface)))))) (defmethod sync-ink (medium (pattern climi::indexed-pattern)) (with-slots (cr) medium (let ((s (make-cairo-surface medium (pattern-width pattern) (pattern-height pattern)))) (draw-design s pattern) (let ((p (cairo_pattern_create_for_surface (slot-value s 'surface)))) (cairo_set_source cr p) p)))) (defmethod sync-ink (medium (pattern climi::indexed-pattern)) (with-slots (cr) medium (let ((p (pattern-cairo-pattern medium pattern))) (cairo_set_source cr p) p))) (defmethod sync-ink (medium (design clim-internals::transformed-design)) (with-slots ((design climi::design) (transformation climi::transformation)) design ;; ### hmm (let ((p (sync-ink medium design))) (with-cairo-matrix (matrix (invert-transformation transformation)) (cairo_pattern_set_matrix p matrix)) p))) (defun apply-flipping-ink (medium) (let ((from-surface (cairo_get_target (cr medium))) (from-drawable (flipping-pixmap medium)) (to-surface (cairo_get_target (flipping-original-cr medium))) (to-drawable (medium-gdkdrawable medium))) (cairo_surface_flush from-surface) (cairo_surface_flush to-surface) (let ((gc (gdk_gc_new to-drawable)) (region (flipping-region medium))) (gdk_gc_set_function gc :GDK_XOR) (gdk_draw_drawable to-drawable gc from-drawable (floor (bounding-rectangle-min-x region)) (floor (bounding-rectangle-min-y region)) (floor (bounding-rectangle-min-x region)) (floor (bounding-rectangle-min-y region)) (ceiling (bounding-rectangle-max-x region)) (ceiling (bounding-rectangle-max-y region))) (gdk_gc_unref gc)) (cairo_surface_mark_dirty to-surface)) (cairo_destroy (cr medium)) (setf (cr medium) (flipping-original-cr medium)) (setf (flipping-original-cr medium) nil)) (defmethod sync-ink (medium (design climi::standard-flipping-ink)) (setf (flipping-original-cr medium) (cr medium)) (let* ((mirror (medium-mirror medium)) (drawable (mirror-drawable mirror))) (let* ((region (climi::sheet-mirror-region (medium-sheet medium))) (width (floor (bounding-rectangle-max-x region))) (height (floor (bounding-rectangle-max-y region))) (pixmap (or (flipping-pixmap medium) (setf (flipping-pixmap medium) (gdk_pixmap_new drawable width height -1))))) (setf (cr medium) (gdk_cairo_create pixmap)) (set-antialias (cr medium)) (setf (flipping-region medium) region) (cairo_paint (cr medium)) (sync-transformation medium) (sync-ink medium +white+)))) (defmethod sync-ink (medium new-value) (warn "SYNC-INK lost ~S." new-value)) ;;; clipping region (defun sync-clipping-region (medium region) (with-slots (cr) medium (cairo_reset_clip cr) (unless (eq region +everywhere+) (unless (eq region +nowhere+) (loop for (x y w h) in (clipping-region->rect-seq region) do (cairo_rectangle cr (df x) (df y) (df w) (df h)))) (cairo_clip cr)) (cairo_new_path cr))) ;;; line-style (defun sync-line-style (medium line-style) (with-slots (cr) medium (cairo_set_line_cap cr (case (line-style-cap-shape line-style) (:butt :butt) (:square :square) (:round :round) (:no-end-point :round))) ;### (cond ((null (line-style-dashes line-style)) (cairo_set_dash cr (cffi:null-pointer) 0 0d0)) ;hmm ((eq t (line-style-dashes line-style)) (let ((d 10)) (cairo-set-dash* cr (case (line-style-unit line-style) ((:point :normal) (map 'vector (lambda (x) (untransform-size (medium-transformation medium) x)) (list d))) (:coordinate (list d)))))) (t ;; line-style-unit! (cairo-set-dash* cr (case (line-style-unit line-style) ((:point :normal) (map 'vector (lambda (x) (untransform-size (medium-transformation medium) x)) (line-style-dashes line-style))) (:coordinate (line-style-dashes line-style)))))) (cairo_set_line_join cr (case (line-style-joint-shape line-style) (:miter :miter) (:bevel :bevel) (:round :round) (:none :round))) ;### (cairo_set_line_width cr (max 1.0d0 (df (case (line-style-unit line-style) ((:point :normal) (untransform-size (medium-transformation medium) (line-style-thickness line-style))) (:coordinate (line-style-thickness line-style)))))) )) (defun cairo-set-dash* (cr dashes) (let ((ndash (length dashes))) (cffi:with-foreign-object (adashes :double ndash) (loop for i below ndash do (setf (cffi:mem-aref adashes :double i) (df (elt dashes i)))) (cairo_set_dash cr adashes ndash 0d0)))) (defun sync-drawing-options (medium) (sync-transformation medium) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (sync-line-style medium (medium-line-style medium))) ;;;; ------------------------------------------------------------------------ ;;;; Drawing Operations ;;;; (defmethod medium-draw-point* ((medium cairo-medium) x y) (with-medium (medium) (sync-sheet medium) (sync-transformation medium) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (sync-line-style medium (medium-line-style medium)) (with-slots (cr) medium (cairo_set_line_cap cr :round) (setf x (df x)) (setf y (df y)) (cairo_move_to cr x y) (cairo_line_to cr (+ x 0.5) (+ y 0.5)) (cairo_stroke cr)))) (defmethod medium-draw-points* ((medium cairo-medium) coord-seq) (with-medium (medium) (sync-sheet medium) (sync-transformation medium) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (sync-line-style medium (medium-line-style medium)) (with-slots (cr) medium (cairo_set_line_cap cr :round) (loop for i below (length coord-seq) by 2 do (let ((x (df (elt coord-seq (+ i 0)))) (y (df (elt coord-seq (+ i 1))))) (cairo_move_to cr x y) (cairo_line_to cr (+ x 0.5) (+ y 0.5)) (cairo_stroke cr)))))) (defmethod medium-draw-line* ((medium cairo-medium) x1 y1 x2 y2) (with-medium (medium) (sync-sheet medium) (sync-transformation medium) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (sync-line-style medium (medium-line-style medium)) (with-slots (cr) medium (cairo_move_to cr (df x1) (df y1)) (cairo_line_to cr (df x2) (df y2)) (cairo_stroke cr)))) (defmethod medium-draw-lines* ((medium cairo-medium) position-seq) (with-medium (medium) (sync-sheet medium) (sync-transformation medium) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (sync-line-style medium (medium-line-style medium)) (with-slots (cr) medium (loop for i below (length position-seq) by 4 do (cairo_move_to cr (df (elt position-seq (+ i 0))) (df (elt position-seq (+ i 1)))) (cairo_line_to cr (df (elt position-seq (+ i 2))) (df (elt position-seq (+ i 3))))) (cairo_stroke cr)))) (defmethod medium-draw-polygon* ((medium cairo-medium) coord-seq closed filled) (with-medium (medium) (sync-sheet medium) (sync-transformation medium) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (unless filled (sync-line-style medium (medium-line-style medium))) (with-slots (cr) medium (cairo_move_to cr (df (elt coord-seq 0)) (df (elt coord-seq 1))) (loop for i from 2 below (length coord-seq) by 2 do (cairo_line_to cr (df (elt coord-seq i)) (df (elt coord-seq (+ i 1))))) (when closed (cairo_line_to cr (df (elt coord-seq 0)) (df (elt coord-seq 1)))) (if filled (cairo_fill cr) (cairo_stroke cr))))) (defmethod medium-draw-rectangle* ((medium cairo-medium) x1 y1 x2 y2 filled) (with-medium (medium) (sync-sheet medium) (sync-transformation medium) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (unless filled (sync-line-style medium (medium-line-style medium))) (when (flipping-original-cr medium) (setf (flipping-region medium) (transform-region (if (medium-sheet medium) (sheet-native-transformation (medium-sheet medium)) clim:+identity-transformation+) (make-rectangle* x1 y1 x2 y2)))) (with-slots (cr) medium (setf x1 (df x1)) (setf y1 (df y1)) (setf x2 (df x2)) (setf y2 (df y2)) (when (< x2 x1) (rotatef x1 x2)) (when (< y2 y1) (rotatef y1 y2)) (cairo_rectangle cr x1 y1 (- x2 x1) (- y2 y1)) (if filled (cairo_fill cr) (cairo_stroke cr))))) (defmethod medium-draw-rectangles* ((medium cairo-medium) position-seq filled) (with-medium (medium) (sync-sheet medium) (sync-transformation medium) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (unless filled (sync-line-style medium (medium-line-style medium))) (with-slots (cr) medium (loop for i below (length position-seq) by 4 do (let ((x1 (df (elt position-seq (+ i 0)))) (y1 (df (elt position-seq (+ i 1)))) (x2 (df (elt position-seq (+ i 2)))) (y2 (df (elt position-seq (+ i 3))))) (when (< x2 x1) (rotatef x1 x2)) (when (< y2 y1) (rotatef y1 y2)) (cairo_rectangle cr x1 y1 (- x2 x1) (- y2 y1)) (if filled (cairo_fill cr) (cairo_stroke cr))))))) (defmethod medium-draw-ellipse* ((medium cairo-medium) cx cy rx1 ry1 rx2 ry2 start end filled) ;; This one is tricky. Cairo doesn't know ellipses, it only knows ;; circles. But then it is fully capable to draw circles under affine ;; transformations only that the line style is transformed too. So ;; what we do: We setup an [additional] transformation to from our ;; ellipse to a circle and setup line style properly transformed. --- ;; This is not entirely correct in case of shearing or odd scaling ;; transformations. ;; ;; Also: What is done to patterns? ;; ;; Anyhow, let's hack along. ;; ;; Quick test if this is a circle: (with-medium (medium) (cond ((= (+ (expt rx1 2) (expt ry1 2)) (+ (expt rx2 2) (expt ry2 2))) (let ((radius (sqrt (+ (expt rx1 2) (expt ry1 2))))) (sync-sheet medium) (sync-transformation medium) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (sync-line-style medium (medium-line-style medium)) (with-slots (cr) medium (cairo_new_path cr) (cairo_arc cr (df cx) (df cy) (df radius) (df start) (df end)) ;; Incredible cool: Cairo doesn't respect line dashes while ;; drawing arcs. Quite useful feature actually. (if filled (cairo_fill cr) (cairo_stroke cr))))) ;; general case (t (let ((tr (make-3-point-transformation* 0 0 1 0 0 1 cx cy (+ cx rx1) (+ cy ry1) (+ cx rx2) (+ cy ry2)))) (sync-sheet medium) ;; hmm, something is wrong here. (sync-transformation medium tr) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (sync-line-style medium (medium-line-style medium)) (with-slots (cr) medium (cairo_new_path cr) (cairo_arc cr 0d0 0d0 1d0 (df start) (df end)) (cairo_fill cr) (cairo_set_source_rgba cr 0.0d0 0.0d0 1.0d0 1.0d0) (loop for a from 0 below (* 2 pi) by .1 do (cairo_new_path cr) (cairo_rectangle cr (df (sin a)) (df (cos a)) .05d0 .05d0) (cairo_fill cr)))))))) (defmethod invoke-with-pango-layout (fn (medium cairo-medium) &key text-style text) (let ((layout (pango_cairo_create_layout (slot-value medium 'cr)))) (unwind-protect (progn (configure-pango-layout layout :text-style text-style :text text) (funcall fn layout)) (g_object_unref layout)))) (defmethod medium-draw-text* ((medium cairo-medium) text x y start end align-x align-y toward-x toward-y transform-glyphs) (with-medium (medium) (sync-sheet medium) (with-slots (cr) medium (sync-transformation medium) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (setf end (or end (length text))) (unless (eql start end) (with-pango-layout (layout medium :text-style medium :text (subseq text start end)) (let ((y2 (nth-value 1 (pango-layout-line-get-pixel-extents layout 0)))) (cairo_move_to cr (df x) (df (+ y y2)))) (pango_cairo_show_layout cr layout)))))) ;; Stolen from the CLX backend. (defmethod climi::medium-draw-image-design* ((medium cairo-medium) (design climi::rgb-image-design) x y) (destructuring-bind (&optional surface buffer mask) (slot-value design 'climi::medium-data) (unless surface (let* ((image (slot-value design 'climi::image))) (setf (values surface buffer) (image-to-cairosurface image)) (when (climi::image-alpha-p image) (error "~@")) (setf (slot-value design 'climi::medium-data) (list surface buffer mask)))) (when mask (error "~@")) (with-medium (medium) (multiple-value-bind (x y) (transform-position (sheet-device-transformation (medium-sheet medium)) x y) (setf x (float x 0d0)) (setf y (float y 0d0)) (with-slots (cr) medium (cairo_set_source_surface cr surface x y) (cond #+ (or) (mask (xlib:with-gcontext (gcontext :clip-mask mask :clip-x x :clip-y y) (xlib:copy-area pixmap gcontext 0 0 width height da x y))) (t (cairo_paint cr)))))))) (defmethod climi::medium-free-image-design ((medium cairo-medium) (design climi::rgb-image-design)) (destructuring-bind (&optional surface buffer mask) (slot-value design 'climi::medium-data) (when surface #+ (or) ;; This one bites, no idea why. (cairo_destroy surface) (cffi:foreign-free buffer) (setf (slot-value design 'climi::medium-data) nil)))) ;; Was: CLX/compute-rgb-image-mask #+ (or) (defun compute-rgb-image-mask (drawable image) (let* ((width (climi::image-width image)) (height (climi::image-height image)) (bitmap (xlib:create-pixmap :drawable drawable :width width :height height :depth 1)) (gc (xlib:create-gcontext :drawable bitmap :foreground 1 :background 0)) (idata (climi::image-data image)) (xdata (make-array (list height width) :element-type '(unsigned-byte 1))) (im (xlib:create-image :width width :height height :depth 1 :data xdata)) ) (dotimes (y width) (dotimes (x height) (if (> (aref idata x y) #x80000000) (setf (aref xdata x y) 0) (setf (aref xdata x y) 1)))) (unless (or (>= width 2048) (>= height 2048)) ;### CLX breaks here (xlib:put-image bitmap gc im :src-x 0 :src-y 0 :x 0 :y 0 :width width :height height :bitmap-p nil)) (xlib:free-gcontext gc) bitmap)) ;; Was: CLX/image-to-ximage (defun image-to-cairosurface (image) (let* ((width (climi::image-width image)) (height (climi::image-height image)) (idata (climi::image-data image)) (stride (cairo_format_stride_for_width :rgb24 width)) (cairodata (cffi:foreign-alloc :uint8 :count (* stride height)))) (declare (type (simple-array (unsigned-byte 32) (* *)) idata)) (loop :for row-offset :from 0 :by stride :for y :from 0 :below height :do (loop :for offset :from row-offset :by 4 :for x :from 0 :below width :do (let ((px (aref idata y x))) (setf (cffi:mem-ref cairodata :uint32 offset) (dpb (ldb (byte 8 0) px) (byte 8 16) (dpb (ldb (byte 8 8) px) (byte 8 8) (dpb (ldb (byte 8 16) px) (byte 8 0) 0))))))) (values (cairo_image_surface_create_for_data cairodata :rgb24 width height stride) cairodata))) (defmethod medium-finish-output ((medium cairo-medium)) (with-medium (medium) (when (cr medium) (cairo_surface_flush (cairo_get_target (cr medium))))) (medium-force-output medium)) (defmethod medium-force-output ((medium cairo-medium)) (remhash medium (dirty-mediums (port medium))) (with-medium (medium) (when (cr medium) (cairo_surface_flush (cairo_get_target (cr medium))) (invalidate-mirror (medium-mirror medium) (medium-sheet medium))))) (defmethod medium-beep ((medium cairo-medium)) ;; fixme: visual beep? ) ;;;; ------------------------------------------------------------------------ ;;;; General Designs ;;;; (defun make-cairo-surface (compatible-medium width height &optional (format :CAIRO_CONTENT_COLOR_ALPHA)) (let* ((s (cairo_surface_create_similar (cairo_get_target (cr compatible-medium)) format width height)) (c (cairo_create s))) (set-antialias c) (make-instance 'cairo-medium :cr c :surface s))) (defmacro with-pattern ((m1 mp) &body body) (let ((p (gensym "P."))) `(let ((,p (cairo_pattern_create_for_surface (slot-value ,mp 'surface)))) (unwind-protect (progn (cairo_set_source (slot-value ,m1 'cr) ,p) (locally ,@body)) (cairo_pattern_destroy ,p))))) ;;;; draw design (defmethod draw-design ((medium cairo-medium) (pattern clim-internals::indexed-pattern) &key &allow-other-keys) (with-medium (medium) (with-slots ((designs climi::designs) (array climi::array)) pattern (loop for y below (array-dimension array 0) do (loop for x below (array-dimension array 1) do (draw-rectangle* medium x y (+ x 1) (+ y 1) :ink (elt designs (aref array y x)))))))) (defmethod draw-design ((medium cairo-medium) (pattern clim-internals::stencil) &key &allow-other-keys) (with-medium (medium) (with-slots ((array climi::array)) pattern (loop for y below (array-dimension array 0) do (loop for x below (array-dimension array 1) do (draw-rectangle* medium x y (+ x 1) (+ y 1) :ink (make-opacity (aref array y x)))))))) (defmethod draw-design ((medium cairo-medium) (design clim-internals::transformed-design) &key &allow-other-keys) (with-medium (medium) (with-slots ((design climi::design) (transformation climi::transformation)) design (with-drawing-options (medium :transformation transformation) (draw-design medium design))))) (defmethod draw-design ((medium cairo-medium) (design clim-internals::rectangular-tile) &key &allow-other-keys) (with-medium (medium) (with-slots ((design climi::design) (width climi::width) (height climi::height)) design ;; ### (loop for x below 600 by width do (loop for y below 600 by height do ;; ### (draw-design medium (transform-region (make-translation-transformation x y) design))))))) (defmethod draw-design ((medium cairo-medium) (design clim:opacity) &key &allow-other-keys) (with-medium (medium) (draw-design medium (compose-in (clim:medium-foreground medium) design)))) (defmethod draw-design ((medium cairo-medium) (design climi::uniform-compositum) &key &allow-other-keys) (with-medium (medium) (draw-rectangle* medium 0 0 600 600 :ink design))) (defmethod draw-design ((medium cairo-medium) (design clim:color) &key &allow-other-keys) (with-medium (medium) (draw-rectangle* medium 0 0 600 600 :ink design))) (defun destroy-surface-medium (medium) (destroy-medium medium) (when (surface medium) (cairo_surface_destroy (surface medium)))) (defmethod destroy-medium ((medium cairo-medium)) (when (cr medium) (cairo_destroy (cr medium)) (setf (cr medium) nil) (dispose-flipping-pixmap medium))) (defmethod draw-design ((medium cairo-medium) (design clim-internals::in-compositum) &key &allow-other-keys) (with-medium (medium) (with-slots ((ink climi::ink) (mask climi::mask)) design (let ((mink (make-cairo-surface medium 600 600)) (mmask (make-cairo-surface medium 600 600 :a8))) (draw-design mink ink) (draw-design mmask mask) (with-pattern (mink mmask) (cairo_set_operator (slot-value mink 'cr) :in-reverse) (cairo_rectangle (slot-value mink 'cr) 0d0 0d0 600d0 600d0) (cairo_fill (slot-value mink 'cr))) (with-pattern (medium mink) (sync-transformation medium) ;### (cairo_rectangle (slot-value medium 'cr) 0d0 0d0 600d0 600d0) (cairo_fill (slot-value medium 'cr))) ;; (destroy-surface-medium mink) (destroy-surface-medium mmask))))) (defmethod draw-design ((medium cairo-medium) (design clim-internals::out-compositum) &key &allow-other-keys) (with-medium (medium) (with-slots ((ink climi::ink) (mask climi::mask)) design (let ((mink (make-cairo-surface medium 600 600)) (mmask (make-cairo-surface medium 600 600 :a8))) (draw-design mink ink) (draw-design mmask mask) (with-pattern (mink mmask) (cairo_set_operator (slot-value mink 'cr) :out-reverse) (cairo_rectangle (slot-value mink 'cr) 0d0 0d0 600d0 600d0) (cairo_fill (slot-value mink 'cr))) (with-pattern (medium mink) (sync-transformation medium) ;### (cairo_rectangle (slot-value medium 'cr) 0d0 0d0 600d0 600d0) (cairo_fill (slot-value medium 'cr))) ;; (destroy-surface-medium mink) (destroy-surface-medium mmask))))) (defmethod draw-design ((medium cairo-medium) (design clim-internals::over-compositum) &key &allow-other-keys) (with-medium (medium) (with-slots ((foreground climi::foreground) (background climi::background)) design (draw-design medium background) (draw-design medium foreground)))) ;;;; Bezier support (defun %draw-bezier-area (medium area) (with-slots (cr) medium (let ((segments (climi::segments area))) (let ((p0 (slot-value (car segments) 'climi::p0))) (cairo_move_to cr (df (point-x p0)) (df (point-y p0)))) (dolist (segment segments) (with-slots (climi::p1 climi::p2 climi::p3) segment (cairo_curve_to cr (df (point-x climi::p1)) (df (point-y climi::p1)) (df (point-x climi::p2)) (df (point-y climi::p2)) (df (point-x climi::p3)) (df (point-y climi::p3))))) (cairo_fill cr)))) (defmethod climi::medium-draw-bezier-design* ((medium cairo-medium) (design climi::bezier-area)) (with-medium (medium) (sync-sheet medium) (sync-transformation medium) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (sync-line-style medium (medium-line-style medium)) (%draw-bezier-area medium design))) (defmethod climi::medium-draw-bezier-design* ((medium cairo-medium) (design climi::bezier-union)) (with-medium (medium) (sync-sheet medium) (sync-transformation medium) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (sync-line-style medium (medium-line-style medium)) (let ((tr (climi::transformation design))) (dolist (area (climi::areas design)) (%draw-bezier-area medium (transform-region tr area)))))) (defmethod climi::medium-draw-bezier-design* ((medium cairo-medium) (design climi::bezier-difference)) (with-medium (medium) (sync-sheet medium) (sync-transformation medium) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (sync-line-style medium (medium-line-style medium)) (dolist (area (climi::positive-areas design)) (%draw-bezier-area medium area))) (with-drawing-options (medium :ink +background-ink+) (with-medium (medium) (sync-sheet medium) (sync-transformation medium) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (sync-line-style medium (medium-line-style medium)) (dolist (area (climi::negative-areas design)) (%draw-bezier-area medium area))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/gtkairo/BUGS0000640000175000017500000001120410561555366020642 0ustar pdmpdm(FIXED) 1. [flipping ink is implemented now, but see 11.] In the address book example example, the input cursor when typing and erasing characters is not getting removed properly, leaving a trace. (FIXED) 2. [see clim-fix.lisp] Also, the presentation highlighting rectangle leaves traces if antialiasing is enabled. (FIXED) 3. The text cursor does not show the correct horizontal position in climacs. (FIXED) 4. Menus appear but do not really work. Worth fixing, even though we would rather want native menus in the long term. (FIXED) 5a. [but see 8.] Colored buttons (clim-fig) are missing. 5b. the slider needs tick marks (FIXED) 5c. Inheriting from the standard gadget panes is bogus anyway, we should build them from scratch. (FIXED) 5d. Default gadget values aren't being used. (FIXED) 6. [Address book didn't work on windows.] (FIXED) 6b. On windows, something draws gray ink over the buttons in demodemo after expose events. This should not happen, since the gtkbuttons are in a gtkfixed with its own window. Thorough double buffering of all output seems to be a viable workaround though. 6c. On windows, all we get is a sans serif font. No serif and notably no monospace font, breaking climacs like bug 3 did. (WONTFIX) 7a. [fixed for draw-rectangle, good enough for now] flipping ink takes time proportional to the with the size of the window, not with the size of the shape being drawn (FIXED) 7b. (problem appears to be gone with double buffering) flipping ink pixmap caching is broken on windows 7c. text drawing is noticably slower than with CLX 8. The frontend specifies background colors (*3d-normal-color*) where the gtk theme should take precedence. (FIXED) 9. Sometimes repaint seems to draw again without clearing the window first. For example, the header in demodemo gets darker with every repaint, until the originally antialiased text looks really crappy. (Now that mouse movement doesn't trigger repaints anymore this is harder to reproduce, but sometimes it can still be triggered.) 10. Somewhere global mouse coordinates aren't turned into local coordinates correctly. (Watch the Drag&Drop test not work unless the window is in the upper left corner of the screen.) (FIXED) 11. The new flipping ink implementation is buggy, it produces garbage output in some cases. (FIXED) 12. In the address book, there are often wide grey borders instead of the narrow black ones. (WONTFIX) 13. McCLIM seems to think that things like button panes have a maximum size equal to their preferred size. I don't agree and return the default gtk size as space-requirement :width and :height without giving a maximum or minimum size at all. Naturally, the existing demos look a little, erm, different with that. (FIXED?) 14. Climacs doesn't draw itself until the window is resized. (FIXED) 15. The text cursor does not show the correct vertical position in climacs. (FIXED?) 16. Scroll panes are now native widgets, but don't really behave. The scroll test works a little, many other examples don't. See comment in update-scrollbar-adjustment. 17. There's a commented-out method on TRANSFORM-REGION for DESIGN in design.lisp. See comment there. clim-fix tried to reinstate it, but that doesn't work for gsharp when drawing ellipses. Find out what this is all about. (WONTFIX) 18. [see 7a, good enough for now] Flipping ink optimization: As suggested by Gilbert, make the temporary pixmap just large enough for the clipping region and the currently visible part of a (scrolled) sheet. Right now we're copying the entire window around, which seems excessive. (FIXED) 19. Key press events for modifier keys don't have the corresponding modifier bit set; key release events do. This is opposite to what CLIM-CLX does. (NOTABUG) 20. Very nasty duplicate keyboard events when typing in the listener. 21. Copy&paste needs to be implemented. 22. medium-draw-ellipse* needs a rewrite. 23. Beirc problem: When connecting to a server, the first receiver pane is created, and suddenly the windows gets unusably large, hiding the interactor. Replacing the :min-height 800 in receivers.lisp with :min-height 400 :max-height 400 fixes that, but CLX doesn't have the same problem. 24. Weird problem in the text size test with the drei gadget in the label pane: Resizing ends up resizing the one-line drei gadget, and doesn't even do it in one step. Instead, it enlarges itself in a smooth animation, taking several seconds to stabilize. cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/gtkairo/gtk-ffi.lisp0000640000175000017500000002576610705412616022407 0ustar pdmpdm;;; -*- Mode: Lisp; -*- ;;; (c) 2006 David Lichteblau (david@lichteblau.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-gtkairo) (cffi:defctype utf8-string (:string :encoding :utf-8)) #-(or win32 mswindows windows darwin) (eval-when (:compile-toplevel :load-toplevel :execute) (cffi:load-foreign-library "libcairo.so") (cffi:load-foreign-library "libgthread-2.0.so") (cffi:load-foreign-library "libgtk-x11-2.0.so")) #+darwin (eval-when (:compile-toplevel :load-toplevel :execute) (let ((cffi:*foreign-library-directories* (cons "/opt/local/lib/" cffi:*foreign-library-directories*))) (cffi:load-foreign-library "libcairo.dylib") (cffi:load-foreign-library "libgthread-2.0.dylib") (cffi:load-foreign-library "libgtk-x11-2.0.dylib"))) #+(or win32 mswindows windows) (eval-when (:compile-toplevel :load-toplevel :execute) (cffi:load-foreign-library "libcairo-2.dll") (cffi:load-foreign-library "libglib-2.0-0.dll") (cffi:load-foreign-library "libgthread-2.0-0.dll") (cffi:load-foreign-library "libgobject-2.0-0.dll") (cffi:load-foreign-library "libgdk-win32-2.0-0.dll") (cffi:load-foreign-library "libgtk-win32-2.0-0.dll") (cffi:load-foreign-library "libpangocairo-1.0-0.dll") (cffi:load-foreign-library "libpango-1.0-0.dll")) (defmacro defcfun (name rtype &rest argtypes) (if (and (eq rtype 'cairo_status_t) (not (or (equal name "cairo_status") (equal name "cairo_font_face_status")))) `(def-cairo-fun ,name ,rtype ,@argtypes) `(cffi:defcfun (,name ,(intern (string-upcase name) :clim-gtkairo)) ,rtype ,@argtypes))) (defmacro defcenum (name &rest values) `(progn (cffi:defcenum ,name ,@values) ,@(loop for pair in values for key = (if (listp pair) (car pair) pair) collect `(defconstant ,(intern (symbol-name key) :clim-gtkairo) (cffi:foreign-enum-value ',name ,key))))) ;;; Here's a hack to wait on GTK's Xlib Display's socket file descriptor ;;; without blocking in native code: ;;; (SBCL doesn't really need this, but other Lisps might.) #-(or win32 windows mswindows) (cffi:defcvar "gdk_display" :pointer) #-(or win32 windows mswindows) (cffi:defcstruct xdisplay (ext_data :pointer) (private1 :pointer) (fd :int) ;; ... and many other more, but we only care about the file descriptor ) #-(or win32 windows mswindows) (defun gdk-xlib-fd () (cffi:foreign-slot-value *gdk-display* 'xdisplay 'fd)) ;;; let's litter the code with locking (cffi:defcvar "g_threads_got_initialized" :int) (defvar *have-lock* nil) (defmacro with-gtk ((&optional) &body body) `(invoke-with-gtk (lambda () ,@body))) #+sbcl (defvar *normal-modes* (sb-int:get-floating-point-modes)) ;; FIXME: Unless I disable traps, I get SIGPFE while in Cairo. Unless I ;; reset all options afterwards, I get lisp errors like f-p-i-o for, say, ;; (ATAN -13 13/2) in McCLIM. Isn't SBCL responsible for calling C code ;; with the with the modes C code expects? Or does cairo change them? #+sbcl (defmacro with-cairo-floats ((&optional) &body body) `(unwind-protect (progn (sb-int:set-floating-point-modes :traps nil) ,@body) (apply #'sb-int:set-floating-point-modes *normal-modes*))) #+(or scl cmu) (defmacro with-cairo-floats ((&optional) &body body) `(ext:with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero :invalid) ,@body)) #-(or scl cmu sbcl) (defmacro with-cairo-floats ((&optional) &body body) `(progn ,@body)) (defmacro slot (o c s) `(cffi:foreign-slot-value ,o ,c ,s)) ;; Note: There's no need for locking in single threaded mode for most ;; functions, except that the main loop functions try to release the ;; lock temporarily, so those need to be called with locking. Let's do ;; locking unconditionally for now. ;; ;; Note #2: Although every medium function should grab this lock, if ;; there was a good way to grab it around the entire redisplay ;; procedure, individual functions wouldn't have to actually do ;; anything. Probably need to find some :around method for this. ;; Note #3: we could use gdk_threads_set_lock_functions here and redirect ;; gdk locking to a Lisp lock if we wanted. We'd need separate ;; functions to lock and unlock a recursive lock for that, which the ;; portability files currently don't provide. (defun invoke-with-gtk (fn) (#-cmu progn #+cmu mp:without-scheduling (with-cairo-floats () (unless *have-lock* (gdk_threads_enter)) (unwind-protect (let ((*have-lock* t)) (funcall fn)) (unless *have-lock* ;; fixme: gdk documentation recommends flushing before releasing ;; the lock. But doing so makes everything s.l.o.w. ;;; (gdk_flush) (gdk_threads_leave)))))) ;;; GROVELME ;; must be a separate structure definition in order for padding on AMD64 ;; to work properly. (cffi:defcstruct gtkobject (gtype :unsigned-long) ;GTypeInstance (ref_count :unsigned-int) ;GObject (qdata :pointer) ; -"- (flags :uint32) ;GtkObject ) (cffi:defcstruct gtkwidget (header gtkobject) (private_flags :uint16) (state :uint8) (saved_state :uint8) (name :pointer) (style :pointer) (requisition-width :int) ;GtkRequisition (requisition-height :int) ; -"- (allocation-x :int) ;GtkAllocation (allocation-y :int) ; -"- (allocation-width :int) ; -"- (allocation-height :int) ; -"- (gdkwindow :pointer) (parent :pointer)) (cffi:defcstruct gtkrequisition (width :int) (height :int)) (defun gtkwidget-header (widget) (cffi:foreign-slot-value widget 'gtkwidget 'header)) (defun gtkwidget-flags (widget) (cffi:foreign-slot-value (gtkwidget-header widget) 'gtkobject 'flags)) (defun (setf gtkwidget-flags) (newval widget) (setf (cffi:foreign-slot-value (gtkwidget-header widget) 'gtkobject 'flags) newval)) (cffi:defcstruct gdkeventexpose (type :int) (gdkwindow :pointer) (send_event :int8) (x :int) ;area (y :int) ; -"- (width :int) ; -"- (height :int) ; -"- (region :pointer) (count :int)) (cffi:defcstruct gdkeventmotion (type :int) (gdkwindow :pointer) (send_event :int8) (time :uint32) (x :double) (y :double) (axes :pointer) (state :uint) (is_hint :int16) (device :pointer) (x_root :double) (y_root :double)) (cffi:defcstruct gdkeventbutton (type :int) (gdkwindow :pointer) (send_event :int8) (time :uint32) (x :double) (y :double) (axes :pointer) (state :uint) (button :uint) (device :pointer) (x_root :double) (y_root :double)) (cffi:defcstruct gdkeventkey (type :int) (gdkwindow :pointer) (send_event :int8) (time :uint32) (state :uint) (keyval :uint) (length :int) (string utf8-string)) (cffi:defcstruct gdkeventcrossing (type :int) (gdkwindow :pointer) (send_event :int8) (subwindow :pointer) (time :uint32) (x :double) (y :double) (x_root :double) (y_root :double) (gdkcrossingmode :int) (gdknotifytype :int) (focusp :int) (state :uint)) (cffi:defcstruct gdkeventconfigure (type :int) (gdkwindow :pointer) (send_event :int8) (x :int) (y :int) (width :int) (height :int)) (cffi:defcstruct gdkpoint (x :int) (y :int)) (cffi:defcstruct gdkrectangle (x :int) (y :int) (width :int) (height :int)) (cffi:defcstruct gdkallocation (x :int) (y :int) (width :int) (height :int)) (cffi:defcstruct gdkcolor (pixel :uint32) (r :uint16) (g :uint16) (b :uint16)) (cffi:defcstruct gdkgeometry (min_width :int) (min_height :int) (max_width :int) (max_height :int) (base_width :int) (base_height :int) (width_inc :int) (height_inc :int) (min_aspect :double) (max_aspect :double) (win_gravity :int)) (cffi:defcstruct gtktreeiter (stamp :int) (user_data :pointer) (user_data2 :pointer) (user_data3 :pointer)) (cffi:defcstruct gvalue (type :ulong) (data0 :uint64) (data1 :uint64)) (defconstant GTK_WINDOW_TOPLEVEL 0) (defconstant GTK_WINDOW_POPUP 1) (defun g-signal-connect (object event callback &optional data) (g_signal_connect_data object event callback (or data (cffi:null-pointer)) (cffi:null-pointer) 0)) (defcfun "gtk_tree_path_new_from_indices" :pointer (index :int) &rest) #-(or win32 windows mswindows) (defcfun "XGetErrorText" :int (dpy :pointer) ;Display * (code :int) ;int (buffer :string) ;char * (nbytes :int) ;int ) #-(or win32 windows mswindows) (defcfun "gdk_x11_drawable_get_xid" :unsigned-long (drawable :pointer) ;GdkDrawable * ) (defconstant GDK_CURRENT_TIME 0) ;; fixme: GtkWidgetFlags is an enum, why is it not in the object file? (defconstant GTK_TOPLEVEL (ash 1 4)) (defconstant GTK_NO_WINDOW (ash 1 5)) (defconstant GTK_REALIZED (ash 1 6)) (defconstant GTK_MAPPED (ash 1 7)) (defconstant GTK_VISIBLE (ash 1 8)) (defconstant GTK_SENSITIVE (ash 1 9)) (defconstant GTK_PARENT_SENSITIVE (ash 1 10)) (defconstant GTK_CAN_FOCUS (ash 1 11)) (defconstant GTK_HAS_FOCUS (ash 1 12)) (defconstant GTK_CAN_DEFAULT (ash 1 13)) (defconstant GTK_HAS_DEFAULT (ash 1 14)) (defconstant GTK_HAS_GRAB (ash 1 15)) (defconstant GTK_RC_STYLE (ash 1 16)) (defconstant GTK_COMPOSITE_CHILD (ash 1 17)) (defconstant GTK_NO_REPARENT (ash 1 18)) (defconstant GTK_APP_PAINTABLE (ash 1 19)) (defconstant GTK_RECEIVES_DEFAULT (ash 1 20)) (defconstant GTK_DOUBLE_BUFFERED (ash 1 21)) (defconstant GTK_NO_SHOW_ALL (ash 1 22)) (defconstant PANGO_SCALE 1024) (cffi:defcstruct PangoRectangle (x :int) (y :int) (width :int) (height :int)) ;; magic symbols for FFI code generation (defvar *dummy* '(GdkFunction gtkselectionmode GtkScrollType GdkEventMask GdkEventType GtkWidgetFlags GdkModifierType GdkCrossingMode GtkWindowType GdkGrabStatus GdkWindowHints GtkStateType GdkDragAction GConnectFlags GdkDragProtocol GtkPolicyType gdkpoint gdklinestyle gdk_x11_drawable_get_xid pangostyle pangoweight PangoRectangle PangoFontMetrics cairo_format_t cairo_operator_t cairo_fill_rule_t cairo_line_cap_t cairo_line_join_t cairo_font_slant_t cairo_font_weight_t cairo_status_t cairo_filter_t cairo_extend_t)) (defun test (&optional (port :gtkairo)) (setf climi::*server-path-search-order* (list port)) (clim:run-frame-top-level (clim:make-application-frame 'clim-demo::address-book))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/gtkairo/pixmap.lisp0000640000175000017500000001062210561555366022351 0ustar pdmpdm;;; -*- Mode: Lisp; -*- ;;; (c) 2006 David Lichteblau (david@lichteblau.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-gtkairo) (defclass gtkairo-pixmap (climi::mirrored-pixmap) ()) (defun medium-gdkdrawable (medium) (mirror-drawable (medium-mirror medium))) (defun ensure-pixmap-medium (pixmap-sheet) (or (climi::pixmap-medium pixmap-sheet) (setf (climi::pixmap-medium pixmap-sheet) (make-medium (port pixmap-sheet) pixmap-sheet)))) (defmethod pixmap-depth ((pixmap-sheet gtkairo-pixmap)) (gdk_drawable_get_depth (medium-gdkdrawable (ensure-pixmap-medium pixmap-sheet)))) (defmethod %medium-copy-area :around (from-medium from-x from-y width height to-medium to-x to-y) (with-gtk () (call-next-method))) (defmethod %medium-copy-area :before ((from-medium cairo-medium) from-x from-y width height to-medium to-x to-y) (sync-sheet from-medium) (cairo_surface_flush (cairo_get_target (cr from-medium)))) (defmethod %medium-copy-area :before (from-medium from-x from-y width height (to-medium cairo-medium) to-x to-y) (sync-sheet to-medium) (cairo_surface_flush (cairo_get_target (cr to-medium)))) (defmethod %medium-copy-area (from-medium from-x from-y width height to-medium to-x to-y) (let ((from-drawable (medium-gdkdrawable from-medium)) (to-drawable (medium-gdkdrawable to-medium))) (let ((gc (gdk_gc_new to-drawable)) (region (medium-clipping-region to-medium))) (unless (eq region +nowhere+) (setf region (region-intersection region (make-rectangle* to-x to-y (+ to-x width) (+ to-y height)))) (loop for (x y w h) in (clipping-region->rect-seq region) do (gdk_draw_drawable to-drawable gc from-drawable (truncate (+ from-x x (- to-x))) (truncate (+ from-y y (- to-y))) (truncate x) (truncate y) (truncate w) (truncate h)))) (gdk_gc_unref gc)))) (defmethod %medium-copy-area :after (from-medium from-x from-y width height (to-medium cairo-medium) to-x to-y) (cairo_surface_mark_dirty (cairo_get_target (cr to-medium)))) ;;; Wer hat sich denn diese Transformiererei ausgedacht? (defmethod medium-copy-area ((from-medium gtkairo-medium) from-x from-y width height (to-medium gtkairo-medium) to-x to-y) (climi::with-transformed-position ((sheet-native-transformation (medium-sheet from-medium)) from-x from-y) (climi::with-transformed-position ((sheet-native-transformation (medium-sheet to-medium)) to-x to-y) (multiple-value-bind (width height) (transform-distance (medium-transformation from-medium) width height) (%medium-copy-area from-medium from-x from-y width height to-medium to-x to-y))))) (defmethod medium-copy-area ((from-medium gtkairo-medium) from-x from-y width height (to-medium gtkairo-pixmap) to-x to-y) (climi::with-transformed-position ((sheet-native-transformation (medium-sheet from-medium)) from-x from-y) (%medium-copy-area from-medium from-x from-y width height (ensure-pixmap-medium to-medium) to-x to-y))) (defmethod medium-copy-area ((from-medium gtkairo-pixmap) from-x from-y width height (to-medium gtkairo-medium) to-x to-y) (climi::with-transformed-position ((sheet-native-transformation (medium-sheet to-medium)) to-x to-y) (%medium-copy-area (ensure-pixmap-medium from-medium) from-x from-y width height to-medium to-x to-y))) (defmethod medium-copy-area ((from-medium gtkairo-pixmap) from-x from-y width height (to-medium gtkairo-pixmap) to-x to-y) (%medium-copy-area (ensure-pixmap-medium from-medium) from-x from-y width height (ensure-pixmap-medium to-medium) to-x to-y)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/gtkairo/event.lisp0000640000175000017500000004020410561555366022173 0ustar pdmpdm;;; -*- Mode: Lisp; -*- ;;; (c) 2006 David Lichteblau (david@lichteblau.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-gtkairo) ;;; Locking rule for this file: The entire event loop grabs the GTK ;;; lock, individual callees don't. (defvar *keys* (make-hash-table)) (defmacro define-key (name &rest clauses) `(setf (gethash ,name *keys*) ',clauses)) (defun connect-signal (widget name sym) (g-signal-connect widget name (cffi:get-callback sym))) (defun connect-signals (widget) (gtk_widget_add_events widget (logior GDK_POINTER_MOTION_MASK GDK_BUTTON_PRESS_MASK GDK_BUTTON_RELEASE_MASK GDK_KEY_PRESS_MASK GDK_KEY_RELEASE_MASK GDK_ENTER_NOTIFY_MASK GDK_LEAVE_NOTIFY_MASK #+nil GDK_STRUCTURE_MASK)) (setf (gtkwidget-flags widget) (logior (gtkwidget-flags widget) GTK_CAN_FOCUS)) (connect-signal widget "expose-event" 'expose-handler) (connect-signal widget "motion-notify-event" 'motion-notify-handler) (connect-signal widget "button-press-event" 'button-handler) (connect-signal widget "button-release-event" 'button-handler) (connect-signal widget "key-press-event" 'key-handler) (connect-signal widget "key-release-event" 'key-handler) (connect-signal widget "enter-notify-event" 'enter-handler) (connect-signal widget "leave-notify-event" 'leave-handler) (connect-signal widget "configure-event" 'configure-handler) ;; override gtkwidget's focus handlers, which trigger an expose event, ;; causing unnecessary redraws for mouse movement (connect-signal widget "focus-in-event" 'noop-handler) (connect-signal widget "focus-out-event" 'noop-handler)) (defun connect-window-signals (widget) (gtk_widget_add_events widget (logior GDK_STRUCTURE_MASK GDK_SUBSTRUCTURE_MASK)) (connect-signal widget "configure-event" 'configure-handler) (connect-signal widget "delete-event" 'delete-handler) (connect-signal widget "destroy-event" 'destroy-handler)) (defvar *port*) (defun enqueue (event &optional (port *port*)) ;;; (tr event) ;;; (tr (event-sheet event)) (push event (cdr (events-tail port))) (pop (events-tail port)) event) (defun tr (&rest x) (when x (format *trace-output* "~&~A~&" x) (finish-output *trace-output*)) x) (defun dequeue (port) (with-gtk () ;let's simply use the gtk lock here (let ((c (cdr (events-head port)))) (when c (pop (events-head port)) (car c))))) (defun dribble-x-errors () #-(or win32 windows mswindows) (let ((code (gdk_error_trap_pop))) (unless (zerop code) (warn "Ignoring X error ~D: ~A" code (cffi:with-foreign-pointer-as-string (buf 64) (XGetErrorText *gdk-display* code buf 63)))) (gdk_error_trap_push))) ;; thread-safe entry function (defun gtk-main-iteration (port &optional block) (with-gtk () (let ((*port* port)) (if block (gtk_main_iteration_do 1) (while (plusp (gtk_events_pending)) (gtk_main_iteration_do 0)))) (dribble-x-errors))) (defmethod get-next-event ((port gtkairo-port) &key wait-function (timeout nil)) (declare (ignore wait-function)) #-clim-mp (port-force-output port) (gtk-main-iteration port) (cond ((dequeue port)) (t #+clim-gtkairo::do-not-block-in-ffi (sb-sys:wait-until-fd-usable (gdk-xlib-fd) :input 0.1) #+cmu (mp:process-yield) (gtk-main-iteration port #-clim-gtkairo::do-not-block-in-ffi t) (dequeue port)))) (defmacro define-signal (name+options (widget event &rest args) &body body) (destructuring-bind (name &key (return-type :void)) (if (listp name+options) name+options (list name+options)) (let ((impl (intern (concatenate 'string (symbol-name name) "-IMPL"))) (args (if (symbolp event) `((,event :pointer) ,@args) (cons event args)))) ;; jump through a trampoline so that C-M-x works without having to ;; restart: `(progn (defun ,impl (,widget ,@(mapcar #'car args)) ,@body) (cffi:defcallback ,name ,return-type ((widget :pointer) ,@args (data :pointer)) data (,impl widget ,@(mapcar #'car args))))))) (define-signal noop-handler (widget event)) (define-signal expose-handler (widget event) (let* ((sheet (widget->sheet widget *port*)) (mirror (climi::port-lookup-mirror *port* sheet))) (unless ;; fixme: this shouldn't happen (typep mirror 'drawable-mirror) (if (buffering-pixmap-dirty-p mirror) (cffi:with-foreign-slots ((x y width height) event gdkeventexpose) (if (mirror-buffering-pixmap mirror) (setf (buffering-pixmap-dirty-p mirror) nil) (gdk_window_clear_area (gtkwidget-gdkwindow widget) x y width height)) (enqueue (make-instance 'window-repaint-event :timestamp (get-internal-real-time) :sheet (widget->sheet widget *port*) :region (make-rectangle* x y (+ x width) (+ y height))))) (cffi:with-foreign-slots ((x y width height) event gdkeventexpose) (let* ((from (mirror-buffering-pixmap mirror)) (to (gtkwidget-gdkwindow (mirror-widget mirror))) (gc (gdk_gc_new to))) (gdk_draw_drawable to gc from x y x y width height) (gdk_gc_unref gc))))))) (defun gdkmodifiertype->modifier-state (state) (logior (if (logtest GDK_SHIFT_MASK state) +shift-key+ 0) (if (logtest GDK_CONTROL_MASK state) +control-key+ 0) (if (logtest GDK_MOD1_MASK state) +meta-key+ 0) ;; (if (logtest GDK_MOD2_MASK state) +super-key+ 0) ;; (if (logtest GDK_MOD3_MASK state) +hyper-key+ 0) ;;; (if (logtest GDK_MOD4_MASK state) ??? 0) ;;; (if (logtest GDK_MOD5_MASK state) ??? 0) ;;; (if (logtest GDK_LOCK_MASK state) ??? 0) )) (defun gdkmodifiertype->one-button (state) (cond ((logtest GDK_BUTTON1_MASK state) +pointer-left-button+) ((logtest GDK_BUTTON2_MASK state) +pointer-middle-button+) ((logtest GDK_BUTTON3_MASK state) +pointer-right-button+) ((logtest GDK_BUTTON4_MASK state) +pointer-wheel-up+) ((logtest GDK_BUTTON5_MASK state) +pointer-wheel-down+) (t nil))) (defun gdkmodifiertype->all-buttons (state) (logior (if (logtest GDK_BUTTON1_MASK state) +pointer-left-button+ 0) (if (logtest GDK_BUTTON2_MASK state) +pointer-middle-button+ 0) (if (logtest GDK_BUTTON3_MASK state) +pointer-right-button+ 0) (if (logtest GDK_BUTTON4_MASK state) +pointer-wheel-up+ 0) (if (logtest GDK_BUTTON5_MASK state) +pointer-wheel-down+ 0))) (define-signal motion-notify-handler (widget event) (gtk_widget_grab_focus widget) (enqueue (cffi:with-foreign-slots ((state x y x_root y_root time) event gdkeventmotion) (make-instance 'pointer-motion-event :timestamp time :pointer 0 :button (gdkmodifiertype->one-button state) :x (truncate x) :y (truncate y) :graft-x (truncate x_root) :graft-y (truncate y_root) :sheet (widget->sheet widget *port*) :modifier-state (gdkmodifiertype->modifier-state state))))) (defun state-without-buttons (state) (logand state (1- GDK_BUTTON1_MASK))) ;; aus CLIM-CLX geklaut: (defconstant +clim-modifiers+ '(((:meta-left :meta-right) #.+meta-key+) ((:hyper-left :hyper-right) #.+hyper-key+) ((:super-left :super-right) #.+super-key+) ((:shift-left :shift-right) #.+shift-key+) ((:control-left :control-right) #.+control-key+))) (defun modify-modifiers (type keysym-keyword modifiers) (let ((keysym-modifier (loop for (keysyms modifier) in +clim-modifiers+ if (member keysym-keyword keysyms) return modifier))) (cond ((and keysym-modifier (eql type GDK_KEY_PRESS)) (logior modifiers keysym-modifier)) ((and keysym-modifier (eql type GDK_KEY_RELEASE)) (logandc2 modifiers keysym-modifier)) (t modifiers)))) (define-signal key-handler (widget event) (let ((sheet (widget->sheet widget *port*))) (multiple-value-bind (root-x root-y) (%gdk-display-get-pointer) (multiple-value-bind (x y) (mirror-pointer-position (sheet-direct-mirror sheet)) (cffi:with-foreign-slots ((type time state keyval string length) event gdkeventkey) (let ((state (state-without-buttons state)) (modifier-state (gdkmodifiertype->modifier-state state))) (let ((clauses (gethash keyval *keys*)) sym char) (loop for (st sy ch) in clauses when (or (eql st t) (find state st)) do (setf sym sy) (setf char ch) (return)) (unless char (setf modifier-state (modify-modifiers type sym modifier-state))) (unless (eq sym 'throw-away) (enqueue (make-instance (if (eql type GDK_KEY_PRESS) 'key-press-event 'key-release-event) :key-name sym :key-character char :x x :y y :graft-x root-x :graft-y root-y :sheet sheet :modifier-state modifier-state :timestamp time)))))))))) (defvar *last-seen-button* 3) (defgeneric handle-event-p (sheet event)) (defmethod handle-event-p (sheet event) t) (define-signal (button-handler :return-type :int) (widget event) (cffi:with-foreign-slots ((type time button state x y x_root y_root) event gdkeventbutton) (when (eql type GDK_BUTTON_PRESS) ;; Hack alert: Menus don't work without this. (gdk_pointer_ungrab GDK_CURRENT_TIME)) (setf *last-seen-button* button) (let* ((sheet (widget->sheet widget *port*)) (event (make-instance (if (eql type GDK_BUTTON_PRESS) 'pointer-button-press-event 'pointer-button-release-event) :pointer 0 :button (ecase button (1 +pointer-left-button+) (2 +pointer-middle-button+) (3 +pointer-right-button+) (4 +pointer-wheel-up+) (5 +pointer-wheel-down+)) :x (truncate x) :y (truncate y) :graft-x (truncate x_root) :graft-y (truncate y_root) :sheet sheet :modifier-state (gdkmodifiertype->modifier-state state) :timestamp time))) (cond ((handle-event-p sheet event) (enqueue event) 1) (t 0))))) (define-signal (tab-button-handler :return-type :int) (widget event) (cffi:with-foreign-slots ((type time button state x y x_root y_root) event gdkeventbutton) (when (eql type GDK_BUTTON_PRESS) ;; Hack alert: Menus don't work without this. (gdk_pointer_ungrab GDK_CURRENT_TIME)) (setf *last-seen-button* button) (let ((page (widget->sheet widget *port*))) (enqueue (make-instance (if (eql type GDK_BUTTON_PRESS) 'tab-press-event 'tab-release-event) :button (ecase button (1 +pointer-left-button+) (2 +pointer-middle-button+) (3 +pointer-right-button+) (4 +pointer-wheel-up+) (5 +pointer-wheel-down+)) :page page :sheet (clim-tab-layout:tab-page-tab-layout page))))) 1) (define-signal enter-handler (widget event) (cffi:with-foreign-slots ((time state x y x_root y_root) event gdkeventcrossing) ;; The frontend sets p-p-s for us, but apparently that sometimes ;; happens too late, leaving NIL in the slot. Test case is the Drag and ;; Drop demo. (Even weirder: Starting it from demodemo for a second time ;; makes the problem go away, only the first invocation has this problem.) (setf (climi::port-pointer-sheet *port*) (widget->sheet widget *port*)) (enqueue (make-instance 'pointer-enter-event :pointer 0 :button (gdkmodifiertype->all-buttons state) :x x :y y :graft-x x_root :graft-y y_root :sheet (widget->sheet widget *port*) :modifier-state (gdkmodifiertype->modifier-state state) :timestamp time)))) (define-signal leave-handler (widget event) (cffi:with-foreign-slots ((time state x y x_root y_root gdkcrossingmode) event gdkeventcrossing) (enqueue (make-instance (if (eql gdkcrossingmode GDK_CROSSING_UNGRAB) 'climi::pointer-ungrab-event 'pointer-exit-event) :pointer 0 :button (gdkmodifiertype->all-buttons state) :x x :y y :graft-x x_root :graft-y y_root :sheet (widget->sheet widget *port*) :modifier-state (gdkmodifiertype->modifier-state state) :timestamp time)))) (define-signal configure-handler (widget event) (cffi:with-foreign-slots ((x y width height) event gdkeventconfigure) (let ((sheet (widget->sheet widget *port*))) (when sheet ;FIXME (enqueue (if (eq (sheet-parent sheet) (graft sheet)) (cffi:with-foreign-object (&x :int) (cffi:with-foreign-object (&y :int) ;; FIXME: Does this actually change anything about decoration ;; handling? (gdk_window_get_root_origin (gtkwidget-gdkwindow widget) &x &y) (make-instance 'window-configuration-event :sheet sheet :x (cffi:mem-aref &x :int) :y (cffi:mem-aref &y :int) :width width :height height))) (make-instance 'window-configuration-event :sheet sheet :x x :y y :width width :height height))))))) (define-signal delete-handler (widget event) (enqueue (make-instance 'clim:window-manager-delete-event :sheet (widget->sheet widget *port*)))) (define-signal destroy-handler (widget event) (enqueue (make-instance 'climi::window-destroy-event :sheet (widget->sheet widget *port*)))) ;; native widget handlers: (define-signal magic-clicked-handler (widget event) (declare (ignore event)) (when (boundp '*port*) ;hack alert (enqueue (make-instance 'magic-gadget-event :sheet (widget->sheet widget *port*))))) (define-signal menu-clicked-handler (widget event) (declare (ignore event)) (let ((parent (cffi:foreign-slot-value widget 'gtkwidget 'parent))) (enqueue (make-instance 'menu-clicked-event :sheet (widget->sheet parent *port*) :item (widget->sheet widget *port*))))) (define-signal context-menu-clicked-handler (widget event) (declare (ignore event)) (let ((dummy-item (widget->sheet widget *port*))) (enqueue (make-instance 'context-menu-clicked-event :sheet (dummy-menu-item-sheet-parent dummy-item) :value (dummy-menu-item-sheet-value dummy-item) :itemspec (dummy-menu-item-sheet-itemspec dummy-item))))) (define-signal popup-deactivated-handler (widget (menu :pointer)) menu (enqueue (make-instance 'context-menu-cancelled-event :sheet (widget->sheet widget *port*)))) #-sbcl (define-signal (scrollbar-change-value-handler :return-type :int) (widget (scroll gtkscrolltype) (value :double)) (enqueue (make-instance 'scrollbar-change-value-event :scroll-type scroll :value value :sheet (widget->sheet widget *port*))) 1) #+sbcl ;; :double in callbacks doesn't work: (define-signal (scrollbar-change-value-handler :return-type :int) (widget (scroll gtkscrolltype) (lo :unsigned-int) (hi :int)) (enqueue (make-instance 'scrollbar-change-value-event :scroll-type scroll :value (sb-kernel:make-double-float hi lo) :sheet (widget->sheet widget *port*))) 1) (defvar *later-table* (make-hash-table)) (defvar *later-counter* 0) (defun invoke-later (fun) (with-gtk () (let ((i (incf *later-counter*))) (setf (gethash i *later-table*) fun) (g_idle_add (cffi:get-callback 'idle-function) (cffi:make-pointer i))))) (cffi:defcallback idle-function :int ((data :long)) ;hack (let ((fun (gethash data *later-table*))) (remhash data *later-table*) (funcall fun)) 0) (cffi:defcallback view-selection-callback :int ((selection :pointer) (model :pointer) (path :pointer) (isselected :int) (data :pointer)) selection model path isselected (when (boundp '*port*) ;kludge (let ((sheet (widget->sheet data *port*))) (enqueue (make-instance 'list-selection-event :sheet sheet)))) 1) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/CLX/0000755000175000017500000000000011347763424017152 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/CLX/image.lisp0000640000175000017500000003103010561555366021117 0ustar pdmpdm;; (c) copyright 2002 by ;;; Joachim Pouderoux (pixel@pixeledena.com) ;;; (c) copyright 2001 by ;;; Robert Strandh (strandh@labri.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (defpackage :image ; (:use #:clim-lisp) (:use :clim-clx :common-lisp) (:export #:write-pnm #:read-image-file #:image #:image-color #:image-gadget #:image-height #:image-pixel #:image-pixels #:image-width #:rgb-image #:gray-level-image #:256-gray-level-image #:make-256-gray-level-image #:gray-image-min-level #:gray-image-min-level #:truecolor-image #:make-truecolor-image #:make-3x256-color-image #:color-image-min-level #:color-image-max-level #:binary-image #:make-binary-image #:red-component #:green-component #:blue-component #:colormap-image #:spectral-image)) (in-package :image) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; image (defclass image () ()) (defgeneric image-width (image)) (defgeneric image-height (image)) (defgeneric image-pixels (image)) (defgeneric image-pixel (image x y)) (defgeneric (setf image-pixel) (x y pixel image)) (defgeneric image-color (image x y)) (defgeneric (setf image-color) (x y pixel color image)) (defgeneric write-pnm (image filename output-format)) (defmethod image-width ((image image)) (cadr (array-dimensions (image-pixels image)))) (defmethod image-height ((image image)) (car (array-dimensions (image-pixels image)))) (defmethod image-pixel ((image image) x y) (aref (image-pixels image) y x)) (defmethod (setf image-pixel) (x y pixel image) (setf (aref (image-pixels image) y x) pixel)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; spectral image (defclass spectral-image (image) ()) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; rgb image (defclass rgb-image (image) ()) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; truecolor image (defclass truecolor-image (rgb-image) ((pixels :initarg :pixels :type (simple-array (unsigned-byte 24) (* *)) :reader image-pixels) (max-level :initarg :max-level :type xlib:card8 :reader image-max-level))) (defun make-truecolor-image (pixels max-value) (make-instance 'truecolor-image :pixels pixels :max-level max-value)) (defmethod color-image-max-level ((image truecolor-image)) (image-max-level image)) (defmethod color-image-min-level ((image truecolor-image)) 0) (defun make-3x256-color-image (pixels) (make-instance 'truecolor-image :pixels pixels :max-level 255)) (defmacro red-component (pixel) `(the (unsigned-byte 8) (logand (ash ,pixel -16) 255))) (defmacro green-component (pixel) `(the (unsigned-byte 8) (logand (ash ,pixel -8) 255))) (defmacro blue-component (pixel) `(the (unsigned-byte 8) (logand ,pixel 255))) (defmethod write-pnm ((image truecolor-image) filename output-format) (with-open-file (stream filename :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)) (if (eq output-format :ascii) (write-ppm-p3 stream (image-pixels image)) (write-ppm-p6 stream (image-pixels image))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; colormap image (defclass colormap-image (rgb-image) ()) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; gray-level image (defclass gray-level-image (colormap-image) ()) (defgeneric gray-image-max-level (gray-level-image)) (defgeneric gray-image-min-level (gray-level-image)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; 256 gray-level image (defclass 256-gray-level-image (gray-level-image) ((pixels :initarg :pixels :type (simple-array (unsigned-byte 8) (* *)) :reader image-pixels))) (defun make-256-gray-level-image (pixels) (make-instance '256-gray-level-image :pixels pixels)) (defmethod gray-image-max-level ((image 256-gray-level-image)) 255) (defmethod gray-image-min-level ((image 256-gray-level-image)) 0) (defmethod write-pnm ((image 256-gray-level-image) filename output-format) (with-open-file (stream filename :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)) (if (eq output-format :ascii) (write-pgm-p2 stream (image-pixels image)) (write-pgm-p5 stream (image-pixels image))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; binary image (defclass binary-image (gray-level-image) ((pixels :initarg :pixels :type (simple-array bit (* *)) :reader image-pixels))) (defun make-binary-image (pixels) (make-instance 'binary-image :pixels pixels)) (defmethod write-pnm ((image binary-image) filename output-format) (with-open-file (stream filename :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)) (if (eq output-format :ascii) (write-pbm-p1 stream (image-pixels image)) (write-pbm-p4 stream (image-pixels image))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; PNM Image writers (defmacro with-write-pnm-loop ((magic-number max-value) &body body) `(let ((height (car (array-dimensions picture))) (width (cadr (array-dimensions picture)))) (map nil (lambda (x) (write-byte (char-code x) stream)) (format nil "P~A~%~A~%~A~%~@[~A~%~]" ,magic-number width height ,max-value)) (loop for r from 0 below height do (loop for c from 0 below width do ,@body)) nil)) (defun write-pbm-p1 (stream picture) (with-write-pnm-loop (1 nil) (map nil (lambda (x) (write-byte (char-code x) stream)) (format nil "~A~%" (aref picture r c))))) (defun write-pbm-p4 (stream picture) ; bad! (with-write-pnm-loop (4 nil) (write-byte (aref picture r c) stream))) (defun write-pgm-p2 (stream picture) (with-write-pnm-loop (2 255) (map nil (lambda (x) (write-byte (char-code x) stream)) (format nil "~A~%" (aref picture r c))))) (defun write-pgm-p5 (stream picture) (with-write-pnm-loop (5 255) (write-byte (aref picture r c) stream))) (defun write-ppm-p3 (stream picture) (with-write-pnm-loop (3 255) (let ((rgb (aref picture r c))) (map nil (lambda (x) (write-byte (char-code x) stream)) (format nil "~A ~A ~A~%" (red-component rgb) (green-component rgb) (blue-component rgb)))))) (defun write-ppm-p6 (stream picture) (with-write-pnm-loop (6 255) (let ((rgb (aref picture r c))) (write-byte (red-component rgb) stream) (write-byte (green-component rgb) stream) (write-byte (blue-component rgb) stream)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; PNM Image readers (defun skip-line (stream) (loop while (/= (read-byte stream) #.(char-code #\newline)))) (defmacro skip-whitespace-and-comments () `(loop while (member byte '#.(mapcar #'char-code '(#\Space #\Tab #\Newline #\#))) do (if (= byte #.(char-code #\#)) (loop while (/= byte #.(char-code #\Newline)) do (setf byte (read-byte stream))) (setf byte (read-byte stream))))) (defmacro read-number (var) `(progn (assert (<= 48 byte 57)) (setf ,var (- byte 48)) (loop while (<= 48 (setf byte (read-byte stream)) 57) do (setf ,var (+ (* ,var 10) (- byte 48)))))) (defmacro with-pnm-header (read-max-value &body body) `(let ((byte (read-byte stream)) (width 0) (height 0) (max-value 0)) (declare (type fixnum width height max-value)) (skip-whitespace-and-comments) (read-number width) (skip-whitespace-and-comments) (read-number height) (when ,read-max-value (skip-whitespace-and-comments) (read-number max-value)) ,@body)) (defmacro with-pnm-ascii-reader (read-max-value element-type &body body) (let ((result (gensym))) `(with-pnm-header ,read-max-value (loop with size of-type fixnum = (* width height) with ,result = (make-array `(,height ,width) :element-type ',element-type) with vec = (make-array `(,size) :element-type ',element-type :displaced-to ,result) for offset of-type fixnum from 0 below size do ,@body finally (return ,result))))) (defun read-pbm-p1 (stream) (declare (optimize (speed 3))) (with-pnm-ascii-reader nil bit (let ((color 0)) (skip-whitespace-and-comments) (read-number color) (setf (aref vec offset) color)))) (defun read-pgm-p2 (stream) (declare (optimize (speed 3))) (with-pnm-ascii-reader nil (unsigned-byte 8) (let ((color 0)) (skip-whitespace-and-comments) (read-number color) (setf (aref vec offset) color)))) (defun read-ppm-p3 (stream) (declare (optimize (speed 3))) (with-pnm-ascii-reader nil (unsigned-byte 24) (let ((r 0) (g 0) (b 0)) (skip-whitespace-and-comments) (read-number r) (skip-whitespace-and-comments) (read-number g) (skip-whitespace-and-comments) (read-number b) (setf (aref vec offset) (the (unsigned-byte 24) (+ (ash (the (unsigned-byte 8) r) 16) (ash (the (unsigned-byte 8) g) 8) (the (unsigned-byte 8) b))))))) (defun read-pbm-p4 (stream) (with-pnm-header nil (loop with result = (make-array `(,height ,width) :element-type 'bit) with bytes-per-row = (ceiling width 8) for r from 0 below height do (loop for cr from 0 below bytes-per-row do (loop with byte = (read-byte stream) for pos from 7 downto 0 for c from (* cr 8) below (min (* 8 (1+ cr)) width) do (setf (aref result r c) (ldb (byte 1 pos) byte)))) finally (return result)))) (defun read-pgm-p5 (stream) (with-pnm-header t (loop with size of-type fixnum = (* width height) with result = (make-array `(,height ,width) :element-type '(unsigned-byte 8)) with vec = (make-array `(,size) :element-type '(unsigned-byte 8) :displaced-to result) with offset of-type fixnum = 0 while (< offset size) do (setf offset (read-sequence vec stream :start offset)) finally (return result)))) (defun read-ppm-p6 (stream) (declare (optimize (speed 3))) (with-pnm-header t (loop with size of-type fixnum = (* width height) with cache-size of-type fixnum = (the fixnum (min size 21000)) with aux = (make-array (* 3 cache-size) :element-type '(unsigned-byte 8)) for start of-type fixnum from 0 by cache-size below size for end of-type fixnum = (min (+ start cache-size) size) with result = (make-array `(,height ,width) :element-type `(unsigned-byte 24)) with vec = (make-array size :element-type `(unsigned-byte 24) :displaced-to result) do (loop with offset = 0 while (< offset (* 3 (- end start))) do (setf offset (read-sequence aux stream :start offset))) (loop for i of-type fixnum from start below end for j of-type fixnum from 0 by 3 do (setf (aref vec i) (the (unsigned-byte 24) (+ (ash (the (unsigned-byte 8) (aref aux j)) 16) (ash (the (unsigned-byte 8) (aref aux (1+ j))) 8) (the (unsigned-byte 8) (aref aux (+ 2 j))))))) finally (return result)))) (defun read-pnm-file (filename) (with-open-file (stream filename :direction :input :element-type '(unsigned-byte 8)) (let ((byte1 (read-byte stream))) (cond ((= byte1 (char-code #\P)) ;; probably a PNM file (let ((byte2 (read-byte stream))) (case byte2 ((#.(char-code #\1)) (read-pbm-p1 stream)) ((#.(char-code #\4)) (read-pbm-p4 stream)) ((#.(char-code #\2)) (read-pgm-p2 stream)) ((#.(char-code #\5)) (read-pgm-p5 stream)) ((#.(char-code #\3)) (read-ppm-p3 stream)) ; ASCII ((#.(char-code #\6)) (read-ppm-p6 stream)) ; Binary (t (error "unknown file format ~A ~A" byte1 byte2))))) (t (error "unknown file format ~A" byte1)))))) (defun read-image-file (filename &key (format :pnm)) (declare (ignore format)) (read-pnm-file filename)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/CLX/graft.lisp0000644000175000017500000000314107636702773021153 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-CLX -*- ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-clx) ;;; CLX-GRAFT class (defclass clx-graft (graft) () ) (defmethod graft-width ((graft clx-graft) &key (units :device)) (let ((screen (clx-port-screen (port graft)))) (ecase units (:device (xlib:screen-width screen)) (:inches (/ (xlib:screen-width-in-millimeters screen) 25.4s0)) (:millimeters (xlib:screen-width-in-millimeters screen)) (:screen-sized 1)))) (defmethod graft-height ((graft clx-graft) &key (units :device)) (let ((screen (clx-port-screen (port graft)))) (ecase units (:device (xlib:screen-height screen)) (:inches (/ (xlib:screen-height-in-millimeters screen) 25.4s0)) (:millimeters (xlib:screen-height-in-millimeters screen)) (:screen-sized 1)))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/CLX/port.lisp0000644000175000017500000017260111345155772021035 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-CLX; -*- ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com) ;;; (c) copyright 2000,2001 by ;;; Iban Hatchondo (hatchond@emi.u-bordeaux.fr) ;;; Julien Boninfante (boninfan@emi.u-bordeaux.fr) ;;; Robert Strandh (strandh@labri.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-clx) (declaim (inline round-coordinate)) (defun round-coordinate (x) "Function used for rounding coordinates." ;; We use "mercantile rounding", instead of the CL round to nearest ;; even number, when in doubt. ;; ;; Reason: As the CLIM drawing model is specified, you quite often ;; want to operate with coordinates, which are multiples of 1/2. ;; Using CL:ROUND gives you "random" results. Using "mercantile ;; rounding" gives you consistent results. ;; ;; Note that CLIM defines pixel coordinates to be at the corners, ;; while in X11 they are at the centers. We don't do much about the ;; discrepancy, but rounding up at half pixel boundaries seems to ;; work well. (floor (+ x .5))) ;;; CLX-PORT class (defclass clx-pointer (standard-pointer) ((cursor :accessor pointer-cursor :initform :upper-left))) #| Perhaps this belongs elsewhere We have a couple of problems, one is character-sets. Unfortunately no-one seems to define what a character-set is, really. So, I define a character-set as being the same as a language, since a language is far more useful. This is important, since a given language may include many characters from what might be traditionally considered disparate character-sets. Also it is important, since we cannot simply map a character to a glyph in a language independent fashion, since the style of the character may have some language component. In our rendering/translation mechanism we switch fonts when a font fails to supply the glyph that we want. So, to facilitate this we need a given fontset with a set of disjoint ranges mapped to particular font/encoding pairs. For the time being, an alist should do here. We assume that we're given disjoint ranges for now, which is optimistic. Currently building a fontset will be a tricksy business, think about how to generalise this for the future. |# ; this is to inform the text renderer which fontset it should be using. ; it is a complement to the graphics-context stuff, effectively. ; the #'translate uses/needs this to switch fonts (defclass fontset () ( ; of the form ((start . stop) font translator) (name :type simple-string :initform "fontset" :initarg :name :reader fontset-name) (default-font :initform nil :reader fontset-default-font) (ranges :type list :initform nil :initarg :ranges) (ascent :type integer :initform 0 :initarg :ascent :reader fontset-ascent) (descent :type integer :initform 0 :initarg :ascent :reader fontset-descent) (height :type integer :initform 0 :initarg :ascent :reader fontset-height) (width :type integer :initform 0 :initarg :ascent :reader fontset-width))) (defvar *fontset* nil) (defmethod print-object ((object fontset) stream) (format stream "#" (fontset-name object))) (defmacro make-fontset (name &body entries) (let ((fontset (gensym))) `(let ((,fontset (make-instance 'fontset :name ,name))) ,@(mapcar (lambda (entry) (destructuring-bind (start finish font translator) entry `(set-fontset-range ,fontset ,font ,translator ,start ,finish))) entries) ,fontset))) (defmethod set-fontset-range ((fontset fontset) font translator start finish) ; should check ordering invariants, disjointity, etc (with-slots (ranges ascent descent height default-font) fontset (unless default-font (setf default-font font)) (push (list (cons start finish) font translator) ranges) (setf ascent (max (xlib:font-ascent font) ascent)) (setf descent (max (xlib:font-descent font) descent)) (setf height (+ ascent descent)))) (defun fontset-point-width (point &optional (fontset *fontset*)) (let ((entry (fontset-point point fontset))) (if entry (destructuring-bind ((range-start . range-stop) font translator) entry (declare (ignore range-start range-stop)) (xlib:char-width font (funcall translator point))) 0))) (defun fontset-point (point &optional (fontset *fontset*)) (%fontset-point fontset point)) (defmethod %fontset-point ((fontset fontset) point) (with-slots (ranges) fontset (assoc point ranges :test (lambda (point range) (<= (car range) point (cdr range)))))) (defclass clx-port (clim-xcommon:keysym-port-mixin basic-port) ((display :initform nil :accessor clx-port-display) (screen :initform nil :accessor clx-port-screen) (window :initform nil :accessor clx-port-window) (color-table :initform (make-hash-table :test #'eq)) (cursor-table :initform (make-hash-table :test #'eq) :accessor clx-port-cursor-table) (design-cache :initform (make-hash-table :test #'eq)) (pointer :reader port-pointer) (pointer-grab-sheet :accessor pointer-grab-sheet :initform nil) (selection-owner :initform nil :accessor selection-owner) (selection-timestamp :initform nil :accessor selection-timestamp) (font-families :accessor font-families))) (defun automagic-clx-server-path () (let ((name (get-environment-variable "DISPLAY"))) (assert name (name) "Environment variable DISPLAY is not set") (let* (; this code courtesy telent-clx. (slash-i (or (position #\/ name) -1)) (colon-i (position #\: name :start (1+ slash-i))) (decnet-colon-p (eql (elt name (1+ colon-i)) #\:)) (host (subseq name (1+ slash-i) colon-i)) (dot-i (and colon-i (position #\. name :start colon-i))) (display (and colon-i (parse-integer name :start (if decnet-colon-p (+ colon-i 2) (1+ colon-i)) :end dot-i))) (screen (and dot-i (parse-integer name :start (1+ dot-i)))) (protocol (cond ((or (string= host "") (string-equal host "unix")) :local) (decnet-colon-p :decnet) ((> slash-i -1) (intern (string-upcase (subseq name 0 slash-i)) :keyword)) (t :internet)))) (list :clx :host host :display-id (or display 0) :screen-id (or screen 0) :protocol protocol)))) (defun helpfully-automagic-clx-server-path () (restart-case (automagic-clx-server-path) (use-localhost () :report "Use local unix display" (parse-clx-server-path '(:clx :host "" :protocol :unix))))) (defun parse-clx-server-path (path) (pop path) (if path (list :clx :host (getf path :host "localhost") :display-id (getf path :display-id 0) :screen-id (getf path :screen-id 0) :protocol (getf path :protocol :internet)) (helpfully-automagic-clx-server-path))) (setf (get :x11 :port-type) 'clx-port) (setf (get :x11 :server-path-parser) 'parse-clx-server-path) (setf (get :clx :port-type) 'clx-port) (setf (get :clx :server-path-parser) 'parse-clx-server-path) (defmethod initialize-instance :after ((port clx-port) &rest args) (declare (ignore args)) (push (make-instance 'clx-frame-manager :port port) (slot-value port 'frame-managers)) (setf (slot-value port 'pointer) (make-instance 'clx-pointer :port port)) (initialize-clx port)) (defmethod print-object ((object clx-port) stream) (print-unreadable-object (object stream :identity t :type t) (when (slot-boundp object 'display) (let ((display (slot-value object 'display))) (when display (format stream "~S ~S ~S ~S" :host (xlib:display-host display) :display-id (xlib:display-display display))))))) (defun clx-error-handler (display error-name &rest args &key major &allow-other-keys) (unless (and (eql major 42) ; 42 is SetInputFocus, we ignore match-errors from that (eq error-name 'xlib:match-error)) (format *error-output* "Received CLX ~A in process ~W~%" error-name (clim-sys:process-name (clim-sys:current-process))) (apply #'xlib:default-error-handler display error-name args))) (defvar *clx-cursor-mapping* '(;; These are taken from the Franz CLIM User's Guide (:busy 150) (:button 60) (:default 68) (:horizontal-scroll 108) (:horizontal-thumb 108) (:lower-left 12) (:lower-right 14) (:move 52) (:position 130) (:prompt 152) (:scroll-down 106) (:scroll-left 110) (:scroll-right 112) (:scroll-up 114) (:upper-left 134) (:upper-right 136) (:vertical-scroll 116) (:vertical-thumb 116) ;; The following are not in the Franz docs, but might be useful. (:i-beam 152) (:vertical-pointer 22) (:pencil 86) (:rotate 50) (:choose 60))) (defun make-cursor-table (port) (declare (optimize (safety 3) (debug 3) (speed 0) (space 0))) (let ((font (xlib:open-font (clx-port-display port) "cursor"))) (loop for (symbol code) in *clx-cursor-mapping* do (setf (gethash symbol (clx-port-cursor-table port)) (xlib:create-glyph-cursor :foreground (xlib:make-color :red 0.0 :green 0.0 :blue 0.0) :background (xlib:make-color :red 1.0 :green 1.0 :blue 1.0) :source-font font :source-char code :mask-font font :mask-char (1+ code)))) (xlib:close-font font))) (defmethod initialize-clx ((port clx-port)) (let ((options (cdr (port-server-path port)))) (setf (clx-port-display port) (xlib:open-display (getf options :host) :display (getf options :display-id) :protocol (getf options :protocol))) (progn (setf (xlib:display-error-handler (clx-port-display port)) #'clx-error-handler) #+nil ;; Uncomment this when debugging CLX backend if asynchronous errors become troublesome.. (setf (xlib:display-after-function (clx-port-display port)) #'xlib:display-finish-output)) (setf (clx-port-screen port) (nth (getf options :screen-id) (xlib:display-roots (clx-port-display port)))) (setf (clx-port-window port) (xlib:screen-root (clx-port-screen port))) (make-cursor-table port) (make-graft port) (when clim-sys:*multiprocessing-p* (setf (port-event-process port) (clim-sys:make-process (lambda () (loop (with-simple-restart (restart-event-loop "Restart CLIM's event loop.") (loop (process-next-event port)) ))) :name (format nil "~S's event process." port))) #+nil(format *trace-output* "~&Started CLX event loop process ~A~%" (port-event-process port))) )) #+nil (defmethod (setf sheet-mirror-transformation) :after (new-value (sheet mirrored-sheet-mixin)) ) (defmethod port-set-mirror-region ((port clx-port) mirror mirror-region) (setf (xlib:drawable-width mirror) (floor (bounding-rectangle-max-x mirror-region)) (xlib:drawable-height mirror) (floor (bounding-rectangle-max-y mirror-region)))) (defmethod port-set-mirror-transformation ((port clx-port) mirror mirror-transformation) (setf (xlib:drawable-x mirror) (floor (nth-value 0 (transform-position mirror-transformation 0 0))) (xlib:drawable-y mirror) (floor (nth-value 1 (transform-position mirror-transformation 0 0))))) (defun invent-sheet-mirror-transformation-and-region (sheet) ;; -> tr region (let* ((r (sheet-region sheet)) (r* (transform-region (sheet-native-transformation (sheet-parent sheet)) (transform-region (sheet-transformation sheet) r))) #+nil (r* (bounding-rectangle (region-intersection r* (make-rectangle* 0 0 (port-mirror-width (port sheet) (sheet-parent sheet)) (port-mirror-height (port sheet) (sheet-parent sheet)))))) (mirror-transformation (if (region-equal r* +nowhere+) (make-translation-transformation 0 0) (make-translation-transformation (bounding-rectangle-min-x r*) (bounding-rectangle-min-y r*)))) (mirror-region (untransform-region mirror-transformation r*))) (values mirror-transformation mirror-region))) (defun realize-mirror-aux (port sheet &key (width 100) (height 100) (x 0) (y 0) (border-width 0) (border 0) (override-redirect :off) (map t) (backing-store :not-useful) (save-under :off) (event-mask `(:exposure :key-press :key-release :button-press :button-release :enter-window :leave-window :structure-notify :pointer-motion :button-motion))) ;; I am declaring BORDER-WIDTH ignore to get a cleaner build, but I ;; don't really understand why the use of it is commented out in favor ;; of the constant 0. -- RS 2007-07-22 (declare (ignore border-width)) (when (null (port-lookup-mirror port sheet)) (update-mirror-geometry sheet) (let* ((desired-color (typecase sheet (sheet-with-medium-mixin (medium-background sheet)) (basic-pane ; CHECKME [is this sensible?] seems to be (let ((background (pane-background sheet))) (if (typep background 'color) background +white+))) (t +white+))) (color (multiple-value-bind (r g b) (color-rgb desired-color) (xlib:make-color :red r :green g :blue b))) (pixel (xlib:alloc-color (xlib:screen-default-colormap (clx-port-screen port)) color)) (window (xlib:create-window :parent (sheet-mirror (sheet-parent sheet)) :width (if (%sheet-mirror-region sheet) (round-coordinate (bounding-rectangle-width (%sheet-mirror-region sheet))) width) :height (if (%sheet-mirror-region sheet) (round-coordinate (bounding-rectangle-height (%sheet-mirror-region sheet))) height) :x (if (%sheet-mirror-transformation sheet) (round-coordinate (nth-value 0 (transform-position (%sheet-mirror-transformation sheet) 0 0))) x) :y (if (%sheet-mirror-transformation sheet) (round-coordinate (nth-value 1 (transform-position (%sheet-mirror-transformation sheet) 0 0))) y) :border-width 0 ;;border-width :border border :override-redirect override-redirect :backing-store backing-store :save-under save-under :gravity :north-west ;; Evil Hack -- but helps enormously (Has anybody ;; a good idea how to sneak the concept of ;; bit-gravity into CLIM)? --GB :bit-gravity (if (typep sheet 'climi::extended-output-stream) :north-west :forget) :background pixel :event-mask (apply #'xlib:make-event-mask event-mask)))) (port-register-mirror (port sheet) sheet window) (when map (xlib:map-window window) ))) (port-lookup-mirror port sheet)) (defmethod realize-mirror ((port clx-port) (sheet mirrored-sheet-mixin)) (realize-mirror-aux port sheet :border-width 0 :map (sheet-enabled-p sheet))) (defmethod realize-mirror ((port clx-port) (sheet border-pane)) ;;(rotatef (medium-background (sheet-medium sheet)) (medium-foreground (sheet-medium sheet))) (realize-mirror-aux port sheet :border-width 0 ; (border-pane-width sheet) :event-mask '(:exposure :structure-notify) :map (sheet-enabled-p sheet))) (defmethod realize-mirror ((port clx-port) (sheet top-level-sheet-pane)) (let ((q (compose-space sheet))) #+nil ; SHEET and its descendants are grafted, but unmirrored :-\ -- APD (allocate-space sheet (space-requirement-width q) (space-requirement-height q)) (let ((frame (pane-frame sheet)) (window (realize-mirror-aux port sheet :map nil :width (round-coordinate (space-requirement-width q)) :height (round-coordinate (space-requirement-height q)) :event-mask '(:key-press :key-release)))) (setf (xlib:wm-hints window) (xlib:make-wm-hints :input :on)) (setf (xlib:wm-name window) (frame-pretty-name frame)) (setf (xlib:wm-icon-name window) (frame-pretty-name frame)) (xlib:set-wm-class window (string-downcase (frame-name frame)) (string-capitalize (string-downcase (frame-name frame)))) (setf (xlib:wm-protocols window) `(:wm_delete_window)) (xlib:change-property window :WM_CLIENT_LEADER (list (xlib:window-id window)) :WINDOW 32)))) (defmethod realize-mirror ((port clx-port) (sheet unmanaged-top-level-sheet-pane)) (realize-mirror-aux port sheet :override-redirect :on :save-under :on :map nil :event-mask '(:structure-notify))) (defmethod realize-mirror ((port clx-port) (sheet menu-button-pane)) (realize-mirror-aux port sheet :event-mask '(:exposure :key-press :key-release :button-press :button-release :enter-window :leave-window :structure-notify ;:pointer-motion :button-motion :owner-grab-button) :map (sheet-enabled-p sheet))) (defmethod realize-mirror ((port clx-port) (sheet clim-stream-pane)) (realize-mirror-aux port sheet :event-mask '(:exposure :key-press :key-release :button-press :button-release :enter-window :leave-window :structure-notify :pointer-motion :pointer-motion-hint :button-motion :owner-grab-button) :map (sheet-enabled-p sheet))) (defmethod destroy-mirror ((port clx-port) (sheet mirrored-sheet-mixin)) (when (port-lookup-mirror port sheet) (xlib:destroy-window (port-lookup-mirror port sheet)) (port-unregister-mirror port sheet (sheet-mirror sheet)))) (defmethod raise-mirror ((port clx-port) (sheet basic-sheet)) (let ((mirror (sheet-mirror sheet))) (when (and mirror (typep mirror 'xlib:window)) (xlib:circulate-window-up mirror)))) (defmethod bury-mirror ((port clx-port) (sheet basic-sheet)) (let ((mirror (sheet-mirror sheet))) (when (and mirror (typep mirror 'xlib:window)) (xlib:circulate-window-down mirror)))) (defmethod mirror-transformation ((port clx-port) mirror) (make-translation-transformation (xlib:drawable-x mirror) (xlib:drawable-y mirror))) (defmethod port-set-sheet-region ((port clx-port) (graft graft) region) (declare (ignore region)) nil) (defmethod port-set-sheet-transformation ((port clx-port) (graft graft) transformation) (declare (ignore transformation)) nil) #+nil (defmethod port-set-sheet-transformation ((port clx-port) (pane application-pane) transformation) (declare (ignore transformation)) nil) #+nil (defmethod port-set-sheet-transformation ((port clx-port) (pane interactor-pane) transformation) (declare (ignore transformation)) nil) (defmethod port-set-sheet-transformation ((port clx-port) (sheet mirrored-sheet-mixin) transformation) (declare (ignore transformation)) ;; why? (break) ;obsolete now (let ((mirror (sheet-direct-mirror sheet))) (multiple-value-bind (tr rg) (invent-sheet-mirror-transformation-and-region sheet) (multiple-value-bind (x y) (transform-position tr 0 0) (multiple-value-bind (x1 y1 x2 y2) (if (eql rg +nowhere+) (values 0 0 0 0) (bounding-rectangle* rg)) (declare (ignore x1 y1)) ;XXX assumed to be 0 (setf (xlib:drawable-x mirror) (round x) (xlib:drawable-y mirror) (round y)) (setf (xlib:drawable-width mirror) (clamp 1 (round x2) #xFFFF) (xlib:drawable-height mirror) (clamp 1 (round y2) #xFFFF)) ;;(xlib:clear-area mirror :exposures-p t) (invalidate-cached-transformations sheet) ))))) (defmethod port-set-sheet-region ((port clx-port) (sheet mirrored-sheet-mixin) region) (declare (ignore region)) ;; why? (let ((mirror (sheet-direct-mirror sheet))) (multiple-value-bind (tr rg) (invent-sheet-mirror-transformation-and-region sheet) (declare (ignore tr)) (multiple-value-bind (x1 y1 x2 y2) (if (eql rg +nowhere+) (values 0 0 0 0) (bounding-rectangle* rg)) (declare (ignore x1 y1)) ;XXX assumed to be 0 (setf x2 (round x2)) (setf y2 (round y2)) (cond ((or (<= x2 0) (<= y2 0)) ;; XXX ;; now X does not allow for a zero width/height window, ;; we should unmap instead ... ;; Nevertheless we simply clamp )) (setf (xlib:drawable-width mirror) (clamp x2 1 #xFFFF) (xlib:drawable-height mirror) (clamp y2 1 #xFFFF)))))) (defmethod port-enable-sheet ((port clx-port) (mirror mirrored-sheet-mixin)) (xlib:map-window (sheet-direct-mirror mirror)) ) (defmethod port-disable-sheet ((port clx-port) (mirror mirrored-sheet-mixin)) (xlib:unmap-window (sheet-direct-mirror mirror)) ) (defmethod destroy-port :before ((port clx-port)) (handler-case (xlib:close-display (clx-port-display port)) (stream-error () (xlib:close-display (clx-port-display port) :abort t)))) (defmethod port-motion-hints ((port clx-port) (sheet mirrored-sheet-mixin)) (let ((event-mask (xlib:window-event-mask (sheet-direct-mirror sheet)))) (if (zerop (logand event-mask #.(xlib:make-event-mask :pointer-motion-hint))) nil t))) (defmethod (setf port-motion-hints) (val (port clx-port) (sheet mirrored-sheet-mixin)) (let* ((mirror (sheet-direct-mirror sheet)) (event-mask (xlib:window-event-mask mirror))) (setf (xlib:window-event-mask mirror) (if val (logior event-mask #.(xlib:make-event-mask :pointer-motion-hint)) (logandc2 event-mask #.(xlib:make-event-mask :pointer-motion-hint))))) val) ; think about rewriting this macro to be nicer (defmacro peek-event ((display &rest keys) &body body) (let ((escape (gensym))) `(block ,escape (xlib:process-event ,display :timeout 0 :peek-p t :handler #'(lambda (&key ,@keys &allow-other-keys) (return-from ,escape (progn ,@body))))))) (defun decode-x-button-code (code) (let ((button-mapping #.(vector +pointer-left-button+ +pointer-middle-button+ +pointer-right-button+ +pointer-wheel-up+ +pointer-wheel-down+ +pointer-wheel-left+ +pointer-wheel-right+)) (code (1- code))) (when (and (>= code 0) (< code (length button-mapping))) (aref button-mapping code)))) ;; From "Inter-Client Communication Conventions Manual", Version 2.0.xf86.1, ;; section 4.1.5: ;; ;; | Advice to Implementors ;; | ;; | Clients cannot distinguish between the case where a top-level ;; | window is resized and moved from the case where the window is ;; | resized but not moved, since a real ConfigureNotify event will be ;; | received in both cases. Clients that are concerned with keeping ;; | track of the absolute position of a top-level window should keep ;; | a piece of state indicating whether they are certain of its ;; | position. Upon receipt of a real ConfigureNotify event on the ;; | top-level window, the client should note that the position is ;; | unknown. Upon receipt of a synthetic ConfigureNotify event, the ;; | client should note the position as known, using the position in ;; | this event. If the client receives a KeyPress, KeyRelease, ;; | ButtonPress, ButtonRelease, MotionNotify, EnterNotify, or ;; | LeaveNotify event on the window (or on any descendant), the ;; | client can deduce the top-level window's position from the ;; | difference between the (event-x, event-y) and (root-x, root-y) ;; | coordinates in these events. Only when the position is unknown ;; | does the client need to use the TranslateCoordinates request to ;; | find the position of a top-level window. ;; | ;; The moral is that we need to distinguish between synthetic and ;; genuine configure-notify events. We expect that synthetic configure ;; notify events come from the window manager and state the correct ;; size and position, while genuine configure events only state the ;; correct size. ;; NOTE: Although it might be tempting to compress (consolidate) ;; events here, this is the wrong place. In our current architecture ;; the process calling this function (the port's event handler ;; process) just reads the events from the X server, and does it ;; with almost no lack behind the reality. While the application ;; frame's event top level loop does the actual processing of events ;; and thus may produce lack. So the events have to be compressed in ;; the frame's event queue. ;; ;; So event compression is implemented in EVENT-QUEUE-APPEND. ;; ;; This changes for possible _real_ immediate repainting sheets, ;; here a possible solution for the port's event handler loop can be ;; to read all available events off into a temponary queue (and ;; event compression for immediate events is done there) and then ;; dispatch all events from there as usual. ;; ;;--GB ;; XXX :button code -> :button (decode-x-button-code code) ;; ;; Only button and keypress events get a :code keyword argument! For mouse ;; button events, one should use decode-x-button-code; otherwise one needs to ;; look at the state argument to get the current button state. The CLIM spec ;; says that pointer motion events are a subclass of pointer-event, which is ;; reasonable, but unfortunately they use the same button slot, whose value ;; should only be a single button. Yet pointer-button-state can return the ;; logical or of the button values... aaargh. For now I'll canonicalize the ;; value going into the button slot and think about adding a ;; pointer-event-buttons slot to pointer events. -- moore ;; (defvar *clx-port*) (defun event-handler (&key display window event-key code state mode time type width height x y root-x root-y data override-redirect-p send-event-p hint-p target property requestor selection request first-keycode count &allow-other-keys) (declare (ignore display request first-keycode count)) (let ((sheet (and window (port-lookup-sheet *clx-port* window)))) (when sheet (case event-key ((:key-press :key-release) (multiple-value-bind (keyname modifier-state keysym-keyword) (x-event-to-key-name-and-modifiers *clx-port* event-key code state) (make-instance (if (eq event-key :key-press) 'key-press-event 'key-release-event) :key-name keysym-keyword :key-character (and (characterp keyname) keyname) :x x :y y :graft-x root-x :graft-y root-y :sheet (or (frame-properties (pane-frame sheet) 'focus) sheet) :modifier-state modifier-state :timestamp time))) ((:button-press :button-release) (let ((modifier-state (clim-xcommon:x-event-state-modifiers *clx-port* state))) (make-instance (if (eq event-key :button-press) 'pointer-button-press-event 'pointer-button-release-event) :pointer 0 :button (decode-x-button-code code) :x x :y y :graft-x root-x :graft-y root-y :sheet sheet :modifier-state modifier-state :timestamp time))) (:enter-notify (make-instance 'pointer-enter-event :pointer 0 :button code :x x :y y :graft-x root-x :graft-y root-y :sheet sheet :modifier-state (clim-xcommon:x-event-state-modifiers *clx-port* state) :timestamp time)) (:leave-notify (make-instance (if (eq mode :ungrab) 'pointer-ungrab-event 'pointer-exit-event) :pointer 0 :button code :x x :y y :graft-x root-x :graft-y root-y :sheet sheet :modifier-state (clim-xcommon:x-event-state-modifiers *clx-port* state) :timestamp time)) ;; (:configure-notify (cond ((and (eq (sheet-parent sheet) (graft sheet)) (graft sheet) (not override-redirect-p) (not send-event-p)) ;; this is genuine event for a top-level sheet (with ;; override-redirect off) ;; ;; Since the root window is not our real parent, but ;; there the window managers decoration in between, ;; only the size is correct, so we need to deduce the ;; position from our idea of it. ;; I believe the code below is totally wrong, because ;; sheet-native-transformation will not be up to date. ;; Instead, query the new coordinates from the X server, ;; and later the event handler will set the correct ;; native-transformation using those. --Hefner ; (multiple-value-bind (x y) (transform-position ; (compose-transformations ; (sheet-transformation sheet) ; (sheet-native-transformation (graft sheet))) ; 0 0) ;; Easier to let X compute the position relative to the root window for us. (multiple-value-bind (x y) (xlib:translate-coordinates window 0 0 (clx-port-window *clx-port*)) (make-instance 'window-configuration-event :sheet sheet :x x :y y :width width :height height))) (t ;; nothing special here (make-instance 'window-configuration-event :sheet sheet :x x :y y :width width :height height)))) (:destroy-notify (make-instance 'window-destroy-event :sheet sheet)) (:motion-notify (let ((modifier-state (clim-xcommon:x-event-state-modifiers *clx-port* state))) (if hint-p (multiple-value-bind (x y same-screen-p child mask root-x root-y) (xlib:query-pointer window) (declare (ignore mask)) ;; If not same-screen-p or the child is different ;; from the original event, assume we're way out of date ;; and don't return an event. (when (and same-screen-p (not child)) (make-instance 'pointer-motion-hint-event :pointer 0 :button code :x x :y y :graft-x root-x :graft-y root-y :sheet sheet :modifier-state modifier-state :timestamp time))) (progn (make-instance 'pointer-motion-event :pointer 0 :button code :x x :y y :graft-x root-x :graft-y root-y :sheet sheet :modifier-state modifier-state :timestamp time))))) ;; ((:exposure :display :graphics-exposure) ;; Notes: ;; . Do not compare count with 0 here, last rectangle in an ;; :exposure event sequence does not cover the whole region. ;; ;; . Do not transform the event region here, since ;; WINDOW-EVENT-REGION does it already. And rightfully so. ;; (think about changing a sheet's native transformation). ;;--GB ;; ;; Mike says: ;; One of the lisps is bogusly sending a :display event instead of an ;; :exposure event. I don't remember if it's CMUCL or SBCL. So the ;; :display event should be left in. ;; (make-instance 'window-repaint-event :timestamp time :sheet sheet :region (make-rectangle* x y (+ x width) (+ y height)))) ;; (:selection-notify (make-instance 'clx-selection-notify-event :sheet sheet :selection selection :target target :property property)) (:selection-clear (make-instance 'selection-clear-event :sheet sheet :selection selection)) (:selection-request (make-instance 'clx-selection-request-event :sheet sheet :selection selection :requestor requestor :target target :property property :timestamp time)) (:client-message (port-client-message sheet time type data)) (t (unless (xlib:event-listen (clx-port-display *clx-port*)) (xlib:display-force-output (clx-port-display *clx-port*))) nil))))) ;; Handling of X client messages (defmethod port-client-message (sheet time (type (eql :wm_protocols)) data) (port-wm-protocols-message sheet time (xlib:atom-name (slot-value *clx-port* 'display) (aref data 0)) data)) (defmethod port-client-message (sheet time (type t) data) (warn "Unprocessed client message: ~:_type = ~S;~:_ data = ~S;~_ sheet = ~S." type data sheet)) ;;; this client message is only necessary if we advertise that we ;;; participate in the :WM_TAKE_FOCUS protocol; otherwise, the window ;;; manager is responsible for all setting of input focus for us. If ;;; we want to do something more complicated with server input focus, ;;; then this method should be adjusted appropriately and the ;;; top-level-sheet REALIZE-MIRROR method should be adjusted to add ;;; :WM_TAKE_FOCUS to XLIB:WM-PROTOCOLS. CSR, 2009-02-18 (defmethod port-wm-protocols-message (sheet time (message (eql :wm_take_focus)) data) (let ((timestamp (elt data 1)) (mirror (sheet-mirror sheet))) (when mirror (xlib:set-input-focus (clx-port-display *clx-port*) mirror :parent timestamp)) nil)) (defmethod port-wm-protocols-message (sheet time (message (eql :wm_delete_window)) data) (declare (ignore data)) (make-instance 'window-manager-delete-event :sheet sheet :timestamp time)) (defmethod port-wm-protocols-message (sheet time (message t) data) (warn "Unprocessed WM Protocols message: ~:_message = ~S;~:_ data = ~S;~_ sheet = ~S." message data sheet)) (defmethod get-next-event ((port clx-port) &key wait-function (timeout nil)) (declare (ignore wait-function)) (let* ((*clx-port* port) (display (clx-port-display port))) (unless (xlib:event-listen display) (xlib:display-force-output (clx-port-display port))) ; temporary solution (or (xlib:process-event (clx-port-display port) :timeout timeout :handler #'event-handler :discard-p t) :timeout))) ;; [Mike] Timeout and wait-functions are both implementation ;; specific and hence best done in the backends. (defmethod make-graft ((port clx-port) &key (orientation :default) (units :device)) (let ((graft (make-instance 'clx-graft :port port :mirror (clx-port-window port) :orientation orientation :units units))) (setf (sheet-region graft) (make-bounding-rectangle 0 0 (xlib:screen-width (clx-port-screen port)) (xlib:screen-height (clx-port-screen port)))) (push graft (port-grafts port)) graft)) (defmethod make-medium ((port clx-port) sheet) (make-instance 'clx-medium ;; :port port ;; :graft (find-graft :port port) :sheet sheet)) (defconstant *clx-text-families* '(:fix "adobe-courier" :serif "adobe-times" :sans-serif "adobe-helvetica")) (defconstant *clx-text-faces* '(:roman "medium-r" :bold "bold-r" :italic "medium-i" :bold-italic "bold-i" :italic-bold "bold-i")) (defparameter *clx-text-sizes* '(:normal 14 :tiny 8 :very-small 10 :small 12 :large 18 :very-large 20 :huge 24)) (defparameter *clx-text-family+face-map* '(:fix #-nil ("adobe-courier" (:roman "medium-r" :bold "bold-r" :italic "medium-o" :bold-italic "bold-o" :italic-bold "bold-o")) #+nil ("*-lucidatypewriter" (:roman "medium-r" :bold "bold-r" :italic "medium-r" :bold-italic "bold-r" :italic-bold "bold-r")) :sans-serif ("adobe-helvetica" (:roman "medium-r" :bold "bold-r" :italic "medium-o" :bold-italic "bold-o" :italic-bold "bold-o")) :serif ("adobe-times" (:roman "medium-r" :bold "bold-r" :italic "medium-i" :bold-italic "bold-i" :italic-bold "bold-i")) )) (defun open-font (display font-name) (let ((fonts (xlib:list-font-names display font-name :max-fonts 1))) (if fonts (xlib:open-font display (first fonts)) (xlib:open-font display "fixed")))) (defmethod text-style-mapping ((port clx-port) text-style &optional character-set) (declare (ignore character-set)) (let ((table (port-text-style-mappings port))) (or (car (gethash text-style table)) (multiple-value-bind (family face size) (text-style-components text-style) (destructuring-bind (family-name face-table) (if (stringp family) (list family *clx-text-faces*) (or (getf *clx-text-family+face-map* family) (getf *clx-text-family+face-map* :fix))) (let* ((face-name (if (stringp face) face (or (getf face-table (if (listp face) (intern (format nil "~A-~A" (symbol-name (first face)) (symbol-name (second face))) :keyword) face)) (getf *clx-text-faces* :roman)))) (size-number (if (numberp size) (round size) (or (getf *clx-text-sizes* size) (getf *clx-text-sizes* :normal))))) (flet ((try (encoding) (let* ((fn (format nil "-~A-~A-*-*-~D-*-*-*-*-*-~A" family-name face-name size-number encoding)) (font (open-font (clx-port-display port) fn))) (and font (cons fn font))))) (let ((fn-font (or (and (> char-code-limit #x100) (try "iso10646-1")) (try "iso8859-1") (try "*-*")))) (setf (gethash text-style table) fn-font) (car fn-font))))))))) (defmethod (setf text-style-mapping) (font-name (port clx-port) (text-style text-style) &optional character-set) (declare (ignore character-set)) (setf (gethash text-style (port-text-style-mappings port)) (cons font-name (open-font (clx-port-display port) font-name))) font-name) (defun text-style-to-X-font (port text-style) (let ((text-style (parse-text-style text-style))) (text-style-mapping port text-style) (cdr (gethash text-style (port-text-style-mappings port))))) (defmethod port-character-width ((port clx-port) text-style char) (let* ((font (text-style-to-X-font port text-style)) (width (xlib:char-width font (char-code char)))) width)) (defmethod port-string-width ((port clx-port) text-style string &key (start 0) end) (xlib:text-width (text-style-to-X-font port text-style) string :start start :end end)) (defmethod X-pixel ((port clx-port) color) (let ((table (slot-value port 'color-table))) (or (gethash color table) (setf (gethash color table) (multiple-value-bind (r g b) (color-rgb color) (xlib:alloc-color (xlib:screen-default-colormap (clx-port-screen port)) (xlib:make-color :red r :green g :blue b))))))) (defmethod port-mirror-width ((port clx-port) sheet) (let ((mirror (port-lookup-mirror port sheet))) (xlib:drawable-width mirror))) (defmethod port-mirror-height ((port clx-port) sheet) (let ((mirror (port-lookup-mirror port sheet))) (xlib:drawable-height mirror))) (defmethod graft ((port clx-port)) (first (port-grafts port))) ;;; Pixmap (defmethod realize-mirror ((port clx-port) (pixmap pixmap)) (when (null (port-lookup-mirror port pixmap)) (let* ((window (sheet-direct-mirror (pixmap-sheet pixmap))) (pix (xlib:create-pixmap :width (round (pixmap-width pixmap)) :height (round (pixmap-height pixmap)) :depth (xlib:drawable-depth window) :drawable window))) (port-register-mirror port pixmap pix)) (values))) (defmethod destroy-mirror ((port clx-port) (pixmap pixmap)) (when (port-lookup-mirror port pixmap) (xlib:free-pixmap (port-lookup-mirror port pixmap)) (port-unregister-mirror port pixmap (port-lookup-mirror port pixmap)))) (defmethod port-allocate-pixmap ((port clx-port) sheet width height) (let ((pixmap (make-instance 'mirrored-pixmap :sheet sheet :width width :height height :port port))) (when (sheet-grafted-p sheet) (realize-mirror port pixmap)) pixmap)) (defmethod port-deallocate-pixmap ((port clx-port) pixmap) (when (port-lookup-mirror port pixmap) (destroy-mirror port pixmap))) ;; Top-level-sheet ;; this is evil. (defmethod allocate-space :after ((pane top-level-sheet-pane) width height) (when (sheet-direct-mirror pane) (with-slots (space-requirement) pane '(setf (xlib:wm-normal-hints (sheet-direct-mirror pane)) (xlib:make-wm-size-hints :width (round width) :height (round height) :max-width (min 65535 (round (space-requirement-max-width space-requirement))) :max-height (min 65535 (round (space-requirement-max-height space-requirement))) :min-width (round (space-requirement-min-width space-requirement)) :min-height (round (space-requirement-min-height space-requirement))))))) (defmethod pointer-position ((pointer clx-pointer)) (let* ((port (port pointer)) (sheet (port-pointer-sheet port))) (when sheet (multiple-value-bind (x y same-screen-p) (xlib:query-pointer (sheet-direct-mirror sheet)) (when same-screen-p (untransform-position (sheet-native-transformation sheet) x y)))))) ;;; pointer button bits in the state mask ;;; Happily, The McCLIM pointer constants correspond directly to the X ;;; constants. (defconstant +right-button-mask+ #x100) (defconstant +middle-button-mask+ #x200) (defconstant +left-button-mask+ #x400) (defconstant +wheel-up-mask+ #x800) (defconstant +wheel-down-mask+ #x1000) (defmethod pointer-button-state ((pointer clx-pointer)) (multiple-value-bind (x y same-screen-p child mask) (xlib:query-pointer (clx-port-window (port pointer))) (declare (ignore x y same-screen-p child)) (ldb (byte 5 8) mask))) ;;; In button events we don't want to see more than one button, according to ;;; the spec, so pick a canonical ordering. :P The mask is that state mask ;;; from an X event. (defun button-from-state (mask) (cond ((logtest +right-button-mask+ mask) +pointer-right-button+) ((logtest +middle-button-mask+ mask) +pointer-middle-button+) ((logtest +left-button-mask+ mask) +pointer-left-button+) ((logtest +wheel-up-mask+ mask) +pointer-wheel-up+) ((logtest +wheel-down-mask+ mask) +pointer-wheel-down+) (t 0))) #+nil (defmethod pointer-modifier-state ((pointer clx-pointer)) (multiple-value-bind (x y same-screen-p child mask) (xlib:query-pointer (clx-port-window (port pointer))) (declare (ignore x y same-screen-p child)) (clim-xcommon:x-event-state-modifiers (port pointer) mask))) (defmethod port-modifier-state ((port clx-port)) (multiple-value-bind (x y same-screen-p child mask) (xlib:query-pointer (clx-port-window port)) (declare (ignore x y same-screen-p child)) (clim-xcommon:x-event-state-modifiers port mask))) ;;; XXX Should we rely on port-pointer-sheet being correct? -- moore (defmethod synthesize-pointer-motion-event ((pointer clx-pointer)) (let* ((port (port pointer)) (sheet (port-pointer-sheet port))) (when sheet (let ((mirror (sheet-direct-mirror sheet))) (when mirror (multiple-value-bind (x y same-screen-p child mask root-x root-y) (xlib:query-pointer mirror) (declare (ignore child)) (when same-screen-p (make-instance 'pointer-motion-event :pointer 0 :button (button-from-state mask) :x x :y y :graft-x root-x :graft-y root-y :sheet sheet :modifier-state (clim-xcommon:x-event-state-modifiers port mask) ;; The event initialization code will give us a ;; reasonable timestamp. :timestamp 0)))))))) (defmethod port-frame-keyboard-input-focus ((port clx-port) frame) (frame-properties frame 'focus)) (defmethod (setf port-frame-keyboard-input-focus) (focus (port clx-port) frame) (setf (frame-properties frame 'focus) focus)) (defmethod port-force-output ((port clx-port)) (xlib:display-force-output (clx-port-display port))) ;; FIXME: What happens when CLIM code calls tracking-pointer recursively? ;; I expect the xlib:grab-pointer call will fail, and so the call to ;; xlib:ungrab-pointer will ungrab prematurely. ;;; XXX Locks around pointer-grab-sheet!!! (defmethod port-grab-pointer ((port clx-port) pointer sheet) ;; FIXME: Use timestamps? (let ((grab-result (xlib:grab-pointer (sheet-mirror sheet) '(:button-press :button-release :leave-window :enter-window :pointer-motion :pointer-motion-hint) ;; Probably we want to set :cursor here.. :owner-p t))) (if (eq grab-result :success) (setf (pointer-grab-sheet port) sheet) nil))) (defmethod port-ungrab-pointer ((port clx-port) pointer sheet) (declare (ignore pointer)) (when (eq (pointer-grab-sheet port) sheet) (xlib:ungrab-pointer (clx-port-display port)) (setf (pointer-grab-sheet port) nil))) (defmethod distribute-event :around ((port clx-port) event) (let ((grab-sheet (pointer-grab-sheet port))) (if grab-sheet (queue-event grab-sheet event) (call-next-method)))) (defmethod set-sheet-pointer-cursor ((port clx-port) sheet cursor) (let ((cursor (gethash cursor (clx-port-cursor-table port)))) (when cursor (setf (xlib:window-cursor (sheet-mirror sheet)) cursor)))) ;;; Modifier cache support (defmethod clim-xcommon:modifier-mapping ((port clx-port)) (let* ((display (clx-port-display port)) (x-modifiers (multiple-value-list (xlib:modifier-mapping display))) (modifier-map (make-array (length x-modifiers) :initial-element nil))) (loop for keycodes in x-modifiers for i from 0 do (setf (aref modifier-map i) (mapcan (lambda (keycode) (modifier-keycode->keysyms display keycode)) keycodes))) modifier-map)) ;;;; Backend component of text selection support ;;; Event classes (defclass clx-selection-notify-event (selection-notify-event) ((target :initarg :target :reader selection-event-target) (property :initarg :property :reader selection-event-property))) (defclass clx-selection-request-event (selection-request-event) ((target :initarg :target :reader selection-event-target) (property :initarg :property :reader selection-event-property))) ;;; Conversions ;; we at least want to support: ;;; :TEXT, :STRING ;;; ;;; :UTF8_STRING ;;; As seen from xterm [make that the preferred encoding] ;;; ;;; :COMPOUND_TEXT ;;; Perhaps relatively easy to produce, hard to grok. ;;; ;;; :TARGETS ;;; Clients want legitimately to find out what we support. ;;; ;;; :TIMESTAMP ;;; Clients want to know when we took ownership of the selection. ;;; Utilities (defun utf8-string-encode (code-points) (let ((res (make-array (length code-points) :adjustable t :fill-pointer 0))) (map 'nil (lambda (code-point) (cond ((< code-point (expt 2 7)) (vector-push-extend code-point res)) ((< code-point (expt 2 11)) (vector-push-extend (logior #b11000000 (ldb (byte 5 6) code-point)) res) (vector-push-extend (logior #b10000000 (ldb (byte 6 0) code-point)) res)) ((< code-point (expt 2 16)) (vector-push-extend (logior #b11100000 (ldb (byte 4 12) code-point)) res) (vector-push-extend (logior #b10000000 (ldb (byte 6 6) code-point)) res) (vector-push-extend (logior #b10000000 (ldb (byte 6 0) code-point)) res)) ((< code-point (1- (expt 2 21))) (vector-push-extend (logior #b11110000 (ldb (byte 3 18) code-point)) res) (vector-push-extend (logior #b10000000 (ldb (byte 6 12) code-point)) res) (vector-push-extend (logior #b10000000 (ldb (byte 6 6) code-point)) res) (vector-push-extend (logior #b10000000 (ldb (byte 6 0) code-point)) res)) ((< code-point (1- (expt 2 26))) (vector-push-extend (logior #b11110000 (ldb (byte 2 24) code-point)) res) (vector-push-extend (logior #b10000000 (ldb (byte 6 18) code-point)) res) (vector-push-extend (logior #b10000000 (ldb (byte 6 12) code-point)) res) (vector-push-extend (logior #b10000000 (ldb (byte 6 6) code-point)) res) (vector-push-extend (logior #b10000000 (ldb (byte 6 0) code-point)) res)) ((< code-point (1- (expt 2 31))) (vector-push-extend (logior #b11110000 (ldb (byte 1 30) code-point)) res) (vector-push-extend (logior #b10000000 (ldb (byte 6 24) code-point)) res) (vector-push-extend (logior #b10000000 (ldb (byte 6 18) code-point)) res) (vector-push-extend (logior #b10000000 (ldb (byte 6 12) code-point)) res) (vector-push-extend (logior #b10000000 (ldb (byte 6 6) code-point)) res) (vector-push-extend (logior #b10000000 (ldb (byte 6 0) code-point)) res)) (t (error "Bad code point: ~D." code-point)))) code-points) res)) ;;; Protocol functions (defmethod bind-selection ((port clx-port) window &optional time) (xlib:set-selection-owner (xlib:window-display (sheet-direct-mirror window)) :primary (sheet-direct-mirror window) time) (eq (xlib:selection-owner (xlib:window-display (sheet-direct-mirror window)) :primary) (sheet-direct-mirror window))) (defmethod release-selection ((port clx-port) &optional time) (xlib:set-selection-owner (clx-port-display port) :primary nil time) (setf (selection-owner port) nil) (setf (selection-timestamp port) nil)) (defmethod request-selection ((port clx-port) requestor time) (xlib:convert-selection :primary :STRING requestor :bounce time)) (defmethod get-selection-from-event ((port clx-port) (event clx-selection-notify-event)) ; (describe event *trace-output*) (if (null (selection-event-property event)) (progn (format *trace-output* "~&;; Oops, selection-notify property is null. Trying the cut buffer instead..~%") (xlib:cut-buffer (clx-port-display port))) (map 'string #'code-char (xlib:get-property (sheet-direct-mirror (event-sheet event)) (selection-event-property event) ;; :type :text :delete-p t :result-type 'vector)))) ;; Incredibly crappy broken unportable Latin 1 encoder which should be ;; replaced by various implementation-specific versions. (flet ((latin1-code-p (x) (not (or (< x 9) (< 10 x 32) (< #x7f x #xa0) (> x 255))))) (defun string-encode (string) (delete-if-not #'latin1-code-p (map 'vector #'char-code string))) (defun exactly-encodable-as-string-p (string) (every #'latin1-code-p (map 'vector #'char-code string)))) ;;; TODO: INCR property? ;;; ;;; FIXME: per ICCCM we MUST support :MULTIPLE (defmethod send-selection ((port clx-port) (event clx-selection-request-event) string) (let ((requestor (selection-event-requestor event)) (property (selection-event-property event)) (target (selection-event-target event)) (time (event-timestamp event))) (when (null property) (format *trace-output* "~&* Requestor property is null! *~%")) #+nil ; debugging output (progn (describe event *trace-output*) (force-output *trace-output*)) (flet ((send-event (&key target (property property)) ;; debugging output, but the KDE Klipper client turns out ;; to poll other clients for selection, which means it ;; would be bad to print at every request. #+nil (format *trace-output* "~&;; clim-clx::send-selection - Requested target ~A, sent ~A to property ~A. time ~S~%" (selection-event-target event) target property time) (xlib:send-event requestor :selection-notify nil :window requestor :event-window requestor :selection (climi::selection-event-selection event) :target target :property property :time time))) (case target ((:UTF8_STRING) (xlib:change-property requestor property (utf8-string-encode (map 'vector #'char-code string)) :UTF8_STRING 8) (send-event :target :UTF8_STRING)) ((:STRING :COMPOUND_TEXT) (xlib:change-property requestor property (string-encode string) target 8) (send-event :target target)) ((:TEXT) (cond ((exactly-encodable-as-string-p string) (xlib:change-property requestor property (string-encode string) :STRING 8) (send-event :target :STRING)) (t (xlib:change-property requestor property (utf8-string-encode (map 'vector #'char-code string)) :UTF8_STRING 8) (send-event :target :UTF8_STRING)))) ((:TARGETS) (let* ((display (clx-port-display port)) (targets (mapcar (lambda (x) (xlib:intern-atom display x)) '(:TARGETS :STRING :TEXT :UTF8_STRING :COMPOUND_TEXT :TIMESTAMP)))) (xlib:change-property requestor property targets target 32)) (send-event :target :TARGETS)) ((:TIMESTAMP) (when (null (selection-timestamp port)) (format *trace-output* "~&;; selection-timestamp is null!~%")) (xlib:change-property requestor property (list (selection-timestamp port)) target 32) (send-event :target :TIMESTAMP)) (t (format *trace-output* "~&;; Warning, unhandled type \"~A\". ~ Sending property NIL to target.~%" target) (send-event :target target :property nil)))) (xlib:display-force-output (xlib:window-display requestor)))) ;;; XXX CLX in ACL doesn't use local sockets, so here's a fix. This is gross ;;; and should obviously be included in Franz' clx and portable clx, but I ;;; believe that enough users will find that their X servers don't listen for ;;; TCP connections that it is worthwhile to include this code here ;;; temporarily. #+allegro (defun xlib::open-x-stream (host display protocol) (declare (ignore protocol)) ;; Derive from host (let ((stream (if (or (string= host "") (string= host "unix")) (socket:make-socket :address-family :file :remote-filename (format nil "/tmp/.X11-unix/X~D" display) :format :binary) (socket:make-socket :remote-host (string host) :remote-port (+ xlib::*x-tcp-port* display) :format :binary)))) (if (streamp stream) stream (error "Cannot connect to server: ~A:~D" host display)))) ;;;; Font listing implementation: (defclass clx-font-family (clim-extensions:font-family) ((all-faces :initform nil :accessor all-faces :reader clim-extensions:font-family-all-faces))) (defclass clx-font-face (clim-extensions:font-face) ((all-sizes :initform nil :accessor all-sizes :reader clim-extensions:font-face-all-sizes))) (defun split-font-name (name) (loop repeat 12 for next = (position #\- name :start 0) :then (position #\- name :start (1+ next)) and prev = nil then next while next when prev collect (subseq name (1+ prev) next))) (defun reload-font-table (port) (let ((table (make-hash-table :test 'equal))) (dolist (font (xlib:list-font-names (clx-port-display port) "*")) (destructuring-bind (&optional foundry family weight slant setwidth style pixelsize &rest ignore ;pointsize xresolution yresolution ;spacing averagewidth registry encoding ) (split-font-name font) (declare (ignore setwidth style ignore)) (when family (let* ((family-name (format nil "~A ~A" foundry family)) (family-instance (or (gethash family-name table) (setf (gethash family-name table) (make-instance 'clx-font-family :port port :name family-name)))) (face-name (format nil "~A ~A" weight slant)) (face-instance (find face-name (all-faces family-instance) :key #'clim-extensions:font-face-name :test #'equal))) (unless face-instance (setf face-instance (make-instance 'clx-font-face :family family-instance :name face-name)) (push face-instance (all-faces family-instance))) (pushnew (parse-integer ;; FIXME: Python thinks pixelsize is NIL, resulting ;; in a full WARNING. Let's COERCE to make it work. (coerce pixelsize 'string)) (all-sizes face-instance)))))) (setf (font-families port) (sort (loop for family being each hash-value in table do (setf (all-faces family) (sort (all-faces family) #'string< :key #'clim-extensions:font-face-name)) (dolist (face (all-faces family)) (setf (all-sizes face) (sort (all-sizes face) #'<))) collect family) #'string< :key #'clim-extensions:font-family-name)))) (defmethod clim-extensions:port-all-font-families ((port clx-port) &key invalidate-cache) (when (or (not (slot-boundp port 'font-families)) invalidate-cache) (reload-font-table port)) (font-families port)) (defmethod clim-extensions:font-face-scalable-p ((face clx-font-face)) nil) (defun make-unfriendly-name (str) (substitute #\- #\space str)) (defmethod clim-extensions:font-face-text-style ((face clx-font-face) &optional size) (make-text-style (make-unfriendly-name (clim-extensions:font-family-name (clim-extensions:font-face-family face))) (make-unfriendly-name (clim-extensions:font-face-name face)) size)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/CLX/package.lisp0000640000175000017500000000412410705412614021420 0ustar pdmpdm;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- (in-package :common-lisp-user) (defpackage :clim-xcommon (:use :clim :clim-lisp) (:export #:keysym-port-mixin #:lookup-keysym #:modifier-mapping #:reverse-lookup-keysym #:x-event-state-modifiers #:x-keysym-to-clim-modifiers)) (defpackage :clim-clx (:use :clim :clim-lisp :clim-backend) (:import-from :climi #:+alt-key+ ;; #:port-text-style-mappings #:port-lookup-mirror #:port-register-mirror #:port-event-process #:port-grafts #:update-mirror-geometry #:%sheet-mirror-region #:%sheet-mirror-transformation ;; #:clamp #:get-environment-variable #:pixmap-sheet #:port-lookup-sheet #:port-unregister-mirror #:port-pointer-sheet #:map-repeated-sequence #:pixmap-mirror #:do-sequence #:with-double-buffering #:with-transformed-position #:with-transformed-positions #:with-medium-options ;; #:border-pane #:pixmap #:top-level-sheet-pane #:unmanaged-top-level-sheet-pane #:menu-frame ;; #:frame-managers ;used as slot #:top-level-sheet ;used as slot #:medium-device-region #:draw-image #:height ;this seems bogus #:width ;dito #:coordinate= #:get-transformation ;; #:invoke-with-special-choices #:medium-miter-limit ;; classes: #:mirrored-pixmap #:window-destroy-event #:pointer-ungrab-event #:pointer-motion-hint-event #:device-font-text-style ;; ) ) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/CLX/clim-extensions.lisp0000640000175000017500000005007610705412614023155 0ustar pdmpdm;; (c) copyright 2002 by ;;; Joachim Pouderoux (pixel@pixeledena.com) ;;; (c) copyright 2001 by ;;; Robert Strandh (strandh@labri.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (eval-when (:compile-toplevel :load-toplevel) ; I don't think that this should be necessarily here, ; but while it is, it needs to ensure that the use-package'ing ; happens before the rest of the file is read. (in-package :clim-clx) (use-package :IMAGE) (use-package :clim-extensions)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; image drawing (defun draw-image (sheet image &rest args &key clipping-region transformation) (declare (ignorable clipping-region transformation args)) (with-medium-options (sheet args) (medium-draw-image* medium image))) (clim-internals::def-graphic-op draw-image (image)) (defun compute-pixel-value-truecolor-image-24 (pixel colormap) (declare (ignore colormap) (type (unsigned-byte 24) pixel)) pixel) (defun compute-pixel-value-truecolor-image (pixel colormap) (declare (type xlib::colormap colormap) (type (unsigned-byte 24) pixel)) (let* ((visual-info (xlib::colormap-visual-info colormap)) (red-mask (xlib:visual-info-red-mask visual-info)) (red-mask-gap (- (integer-length red-mask) 8)) (green-mask (xlib:visual-info-green-mask visual-info)) (green-mask-gap (- (integer-length green-mask) 8)) (blue-mask (xlib:visual-info-blue-mask visual-info)) (blue-mask-gap (- (integer-length blue-mask) 8))) (declare (type fixnum red-mask red-mask-gap green-mask green-mask-gap blue-mask blue-mask-gap)) (+ (logand red-mask (ash (red-component pixel) red-mask-gap)) (logand green-mask (ash (green-component pixel) green-mask-gap)) (logand blue-mask (ash (blue-component pixel) blue-mask-gap))))) (defun compute-pixel-value-256-gray-level-image-24 (pixel colormap) (declare (ignore colormap) (type (unsigned-byte 8) pixel)) (+ (ash pixel 16) (ash pixel 8) pixel)) (defun compute-pixel-value-256-gray-level-image (pixel colormap) (declare (type xlib::colormap colormap) (type (unsigned-byte 8) pixel)) (let* ((visual-info (xlib::colormap-visual-info colormap)) (red-mask (xlib:visual-info-red-mask visual-info)) (red-mask-gap (- (integer-length red-mask) 8)) (green-mask (xlib:visual-info-green-mask visual-info)) (green-mask-gap (- (integer-length green-mask) 8)) (blue-mask (xlib:visual-info-blue-mask visual-info)) (blue-mask-gap (- (integer-length blue-mask) 8))) (declare (type fixnum red-mask red-mask-gap green-mask green-mask-gap blue-mask blue-mask-gap)) (+ (logand red-mask (ash pixel red-mask-gap)) (logand green-mask (ash pixel green-mask-gap)) (logand blue-mask (ash pixel blue-mask-gap))))) ; We only handle case where screen type (i.e. visual-class) is :truecolor (defun choose-computing-pixel (image depth) (declare (type image image) (type (unsigned-byte 16) depth)) (if (= depth 24) (symbol-function (intern (format nil "COMPUTE-PIXEL-VALUE-~a-~a" (type-of image) depth) :clim-clx)) (symbol-function (intern (format nil "COMPUTE-PIXEL-VALUE-~a" (type-of image)) :clim-clx)))) (defmacro medium-draw-translation-image (medium image transformation clipping-region) `(multiple-value-bind (mxx mxy myx myy tx ty) (get-transformation ,transformation) (declare (ignore mxx mxy myx myy) (type coordinate tx ty)) (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* ,clipping-region) (declare (type coordinate x1 y1 x2 y2)) (medium-draw-linear-image ,medium ,image (make-bounding-rectangle (- x1 tx) (- y1 ty) (- x2 tx) (- y2 ty)) :print-x (round tx) :print-y (round ty))))) (defun medium-draw-linear-image (medium image clipping-region &key (print-x 0) (print-y 0)) (declare (optimize (speed 3))) (let* ((r-image-width (1- (image-width image))) (r-image-height (1- (image-height image)))) (declare (type fixnum r-image-width r-image-height)) (with-bounding-rectangle* (x-min y-min x-max y-max) clipping-region (declare (type coordinate x-min y-min x-max y-max)) (when (or (<= 0 x-min r-image-width) (<= x-min 0 x-max)) (with-CLX-graphics (medium) (let* ((colormap (xlib:screen-default-colormap (clx-port-screen port))) (depth (xlib:drawable-depth mirror)) ;;pdm: see below (pixmap-format (find depth (xlib:display-pixmap-formats (clx-port-display port)) :key #'xlib:pixmap-format-depth)) (bits-per-pixel (and pixmap-format (xlib:pixmap-format-bits-per-pixel pixmap-format))) (computing-pixel-function (choose-computing-pixel image depth)) (pixels (image-pixels image)) (x-min* (round (max x-min 0))) (y-min* (round (max y-min 0))) (x-max* (round (min x-max r-image-width))) (y-max* (round (min y-max r-image-height))) (width (1+ (max 0 (- x-max* x-min*)))) (height (1+ (max 0 (- y-max* y-min*)))) (start-x (+ print-x x-min*)) (start-y (+ print-y y-min*)) ;;pdm: the bits-per-pixel value needn't be the same as the ;; depth. If they don't match, XLIB signals an error. So we ;; have to get the right bits-per-pixel value corresponding to ;; the given depth from XLIB and use it here. (data (make-array `(,height ,width) :element-type `(unsigned-byte ,bits-per-pixel))) (server-image (xlib:create-image :data data :depth depth :bits-per-pixel bits-per-pixel))) (declare (type xlib::colormap colormap) (type (unsigned-byte 16) depth) (type fixnum width height start-x start-y x-min* y-min* x-max* y-max*) (type xlib::image server-image)) ;;pdm: If this is not called here, the clipping is wrong. I don't ;; know what I'm doing here, it just works... (setf (xlib:gcontext-clip-mask gc :unsorted) (list start-x start-y width height)) (loop for i of-type fixnum from y-min* to y-max* do (loop for j of-type fixnum from x-min* to x-max* do (setf (aref data (- i y-min*) (- j x-min*)) (funcall computing-pixel-function (aref pixels i j) colormap)))) (xlib:put-image mirror gc server-image :width width :height height :x start-x :y start-y) (xlib::display-force-output (clx-port-display (port medium))))))))) (defmethod medium-draw-image* ((medium clx-medium) (image rgb-image)) (declare (optimize (speed 3))) (let ((transformation (medium-transformation medium)) (clipping-region (medium-clipping-region medium))) (declare ;; This was kind of wrong, never assume some particular class! --GB ;; (type standard-transformation transformation) (type region clipping-region)) (cond ; casual cases : identity or translation transformations ((transformation-equal transformation +identity-transformation+) (medium-draw-linear-image medium image clipping-region)) ((translation-transformation-p transformation) (medium-draw-translation-image medium image transformation clipping-region)) ; other cases (t (let* ((image-width (image-width image)) (image-height (image-height image)) (intersection (region-intersection clipping-region (transform-region transformation (make-bounding-rectangle 0 0 image-width image-height))))) (declare (type fixnum image-width image-height) (type region intersection)) (unless (region-equal intersection +nowhere+) (with-CLX-graphics (medium) (with-bounding-rectangle* (x-min y-min x-max y-max) intersection (declare (type coordinate x-min y-min x-max y-max)) (let* ((colormap (xlib:screen-default-colormap (clx-port-screen port))) (depth (xlib:drawable-depth mirror)) ;;pdm: The same bits-per-pixel vs. depth issue as above. (pixmap-format (find depth (xlib:display-pixmap-formats (clx-port-display port)) :key #'xlib:pixmap-format-depth)) (bits-per-pixel (and pixmap-format (xlib:pixmap-format-bits-per-pixel pixmap-format))) (computing-pixel-function (choose-computing-pixel image depth)) (background-pixel (X-pixel (port medium) (medium-background medium))) (inverse-transformation (invert-transformation transformation)) (image-region (make-bounding-rectangle 0 0 (1- image-width) (1- image-height))) (pixels (image-pixels image)) (flat-pixels (make-array (* image-width image-height) :element-type `(unsigned-byte ,depth) :displaced-to pixels)) (data-width (1+ (ceiling (- x-max x-min)))) (data (make-array `(1 ,data-width) :element-type `(unsigned-byte ,bits-per-pixel))) (flat-data (make-array data-width :element-type `(unsigned-byte ,bits-per-pixel) :displaced-to data)) (r-image-width (1- image-width)) (r-image-height (1- image-height)) (server-image (xlib:create-image :data data :depth depth :bits-per-pixel bits-per-pixel))) (declare (type xlib::colormap colormap) (type (unsigned-byte 16) depth) ;; (type standard-transformation inverse-transformation) (type standard-rectangle image-region) (type fixnum data-width) (type xlib::image server-image)) ; optimisation on server (let ((x-min* (floor x-min)) (y-min* (floor y-min)) ;why +1 ? (x-max* (floor x-max)) ;idem (y-max* (floor y-max))) (setf (xlib:gcontext-clip-mask gc) (list x-min* y-min* x-max* y-max*)) (xlib:clear-area mirror :x x-min* :y y-min* :width (- x-max* x-min*) :height (- y-max* y-min*) :exposures-p nil)) (loop for i of-type coordinate from y-min to y-max do (multiple-value-bind (tx1 ty1) (transform-position inverse-transformation x-min i) (declare (type coordinate tx1 ty1)) (multiple-value-bind (tx2 ty2) (transform-position inverse-transformation x-max i) (declare (type coordinate tx2 ty2)) (let ((pos 0)) (declare (type fixnum pos)) ;;pdm: region-contains-position-p that used to ;; be called below makes the whole drawing about ;; three times slower. So we have to perform an ;; expanded check to speed the things that are ;; enough slow already. (flet ((image-contains-position-p (x y) (and (<= 0 x) (< x image-width) (<= 0 y) (< y image-height)))) (cond ((coordinate= tx1 tx2) ; horizontal case (when (<= 0 tx1 r-image-width) (let ((dy (abs (round (- ty2 ty1)))) (incy (if (< ty1 ty2) 1 -1)) (x (floor tx1)) (y (floor ty1))) (declare (type fixnum dy incy x y)) (loop for j of-type fixnum from 0 to dy do (setf (aref flat-data pos) (if (image-contains-position-p x y) (funcall computing-pixel-function (aref pixels y x) colormap) background-pixel)) (incf pos) (incf y incy))))) ((coordinate= ty1 ty2) ; vertical case (when (<= 0 ty1 r-image-height) (let* ((dx (abs (ceiling (- x-max x-min)))) (incx (/ (- tx2 tx1) dx)) (x (floor tx1)) (y (floor ty1))) (declare (type fixnum dx x y)) (loop for j of-type fixnum from 0 to dx do (setf (aref flat-data pos) (if (image-contains-position-p x y) (funcall computing-pixel-function (aref pixels y x) colormap) background-pixel)) (incf pos) (setf x (floor (incf tx1 incx))))))) (t ; other case (let ((line (region-intersection (make-line* tx1 ty1 tx2 ty2) image-region))) (declare (type region line)) (unless (region-equal line +nowhere+) (multiple-value-bind (x1 y1) (line-start-point* line) (multiple-value-bind (x2 y2) (line-end-point* line) (declare (type coordinate x1 y1 x2 y2)) (incf pos (round (abs (- y1 ty1)))) (fill flat-data background-pixel :start 0 :end pos) ; Bresenham (let* ((dx (round (- x2 x1))) (dy (round (- y2 y1))) (x1* (round x1)) (x2* (round x2)) (stepx (if (< dx 0) -1 1)) (stepy (if (< dy 0) (- image-width) image-width)) (y1* (* image-width (round y1))) (y2* (* image-width (round y2)))) (declare (type fixnum dx dy stepx stepy x1* y1* x2* y2*)) (setf dx (ash (if (< dx 0) (- dx) dx) -1) dy (ash (if (< dy 0) (- dy) dy) -1)) (setf (aref flat-data pos) (aref flat-pixels (+ x1* y1*))) (incf pos) (if (> dx dy) (let ((fraction (- dy (ash dx 1)))) (declare (type fixnum fraction)) (loop while (/= x1* x2*) do (when (>= fraction 0) (incf y1* stepy) (decf fraction dx)) (incf x1* stepx) (incf fraction dy) (setf (aref flat-data pos) (aref flat-pixels (+ x1* y1*))) (incf pos))) (let ((fraction (- dx (ash dy 1)))) (declare (type fixnum fraction)) (loop while (/= y1* y2*) do (when (>= fraction 0) (incf x1* stepx) (decf fraction dy)) (incf y1* stepy) (incf fraction dx) (setf (aref flat-data pos) (aref flat-pixels (+ x1* y1*))) (incf pos)))))))))))) (xlib:put-image mirror gc server-image :width pos :height 1 :x (floor x-min) :y (floor i)))))))) (xlib::display-force-output (clx-port-display (port medium)))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; image pane (defclass image-gadget (basic-gadget) ()) (defclass image-pane (image-gadget) ((image :type image :initform nil :initarg :image :reader image))) (defmethod realize-mirror ((port clx-port) (pane image-pane)) (realize-mirror-aux port pane :backing-store :always)) ;; [Julien] As drawing-image mostly doesn't work, except drawaing everything (sigh !..) ;; the region provided by graphical server is ignored, and the entire pane ;; region is redrawn. Bugs must be fixed before doing the right thing. ;;pdm: No, don't ignore the region, otherwise the pane becomes completely ;; unusable, spending all the time redrawing, redrawing, redrawing, ... ;; There's no reason to ignore the region, everything works fine with it ;; AFAIK. (defmethod handle-repaint ((pane image-pane) region) (with-slots (image) pane (when image (draw-image pane image :clipping-region region)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; image as label #|| (defmethod compose-space-aux ((pane labelled-gadget) (label image)) (let ((width (image-width label)) (height (image-height label))) (make-space-requirement :width width :height height :min-width width :min-height height :max-width width :max-height height))) (defmethod draw-label ((pane labelled-gadget) (label image) x y) (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region pane) (declare (ignore x1 x2) (type coordinate x2 y2)) (let* ((image-width (image-width label)) (image-height (image-height label)) (tx (- x (ecase (gadget-label-align-x pane) (:left 0) (:center (round image-width 2)) (:right image-width)))) (ty (ecase (gadget-label-align-y pane) (:top y1) (:center (- (round (- y2 y1) 2) (round image-height 2))) (:baseline y) (:bottom (- y2 image-height))))) (draw-image pane label :clipping-region (sheet-region pane) :transformation (make-translation-transformation tx ty))))) ||# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; retrieve image (defun zimage-to-rgb (zimage) (unless (eql (xlib:image-depth zimage) 24) (error "sorry, only true color images supported in zimage-to-rgb")) (let* ((data (xlib:image-z-pixarray zimage)) (w (xlib:image-width zimage)) (h (xlib:image-height zimage)) (rbyte (mask->byte (xlib:image-red-mask zimage))) (gbyte (mask->byte (xlib:image-green-mask zimage))) (bbyte (mask->byte (xlib:image-blue-mask zimage))) (result (make-array (list h w) :element-type '(unsigned-byte 32)))) (dotimes (y h) (dotimes (x w) (setf (aref result y x) (let ((pixel (aref data y x))) (dpb (the (unsigned-byte 8) (ldb rbyte pixel)) (byte 8 0) (dpb (the (unsigned-byte 8) (ldb gbyte pixel)) (byte 8 8) (dpb (the (unsigned-byte 8) (ldb bbyte pixel)) (byte 8 16) 0))))))) result)) (defmethod climi::sheet-rgb-data ((port clx-port) sheet &key x y width height) (let ((window (port-lookup-mirror port sheet))) (values (zimage-to-rgb (xlib:get-image window :format :z-pixmap :x (or x 0) :y (or y 0) :width (or width (xlib:drawable-width window)) :height (or height (xlib:drawable-height window)))) nil))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/CLX/frame-manager.lisp0000644000175000017500000001401411345155772022544 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-CLX -*- ;;; (c) copyright 1998,1999,2000,2001 by Michael McDonald (mikemac@mikemac.com) ;;; (c) copyright 2004 by Gilbert Baumann ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-clx) ;;; CLX-FRAME-MANAGER class (defclass clx-frame-manager (frame-manager) () ) ;; Abstract pane lookup logic (defun find-first-defined-class (types) (first (remove-if #'null (mapcar (lambda (class-name) (find-class class-name nil)) types)))) (defun find-symbol-from-spec (package-spec name-components) (flet ((coerce-name-element (name-elt) (typecase name-elt (symbol (symbol-name name-elt)) (sequence (coerce name-elt 'string)) (t (princ-to-string name-elt))))) (find-symbol (apply #'concatenate 'string (mapcar #'coerce-name-element name-components)) package-spec))) (defun find-symbols (name-specs) (remove-if #'null (mapcar #'(lambda (x) (find-symbol-from-spec (first x) (rest x))) name-specs))) (defun generate-standard-pane-specs (type) (let ((mapping (get type 'climi::concrete-pane-class-name))) `((,(symbol-package mapping) ,mapping) (:climi ,mapping) (:climi ,type #:-pane) (:climi ,type)))) (defun generate-clx-pane-specs (type) (append `((:clim-clx #:clx- ,type #:-pane) (:clim-clx #:clx- ,type) (:climi #:clx- ,type #:-pane) (:climi #:clx- ,type)) (generate-standard-pane-specs type))) (defun find-concrete-pane-class (type) (if (or (eql (symbol-package type) (find-package '#:clim)) (eql (symbol-package type) (find-package '#:climi)) (eql (symbol-package type) (find-package '#:keyword)) (get type 'climi::concrete-pane-class-name)) (find-first-defined-class (find-symbols (generate-clx-pane-specs type))) type)) ;;; This is an example of how make-pane-1 might create specialized ;;; instances of the generic pane types based upon the type of the ;;; frame-manager. However, in the CLX case, we don't expect there to ;;; be any CLX specific panes. CLX uses the default generic panes ;;; instead. (defmethod make-pane-1 ((fm clx-frame-manager) (frame application-frame) type &rest args) (apply #'make-instance (find-concrete-pane-class type) :frame frame :manager fm :port (port frame) args)) (defmethod adopt-frame :before ((fm clx-frame-manager) (frame menu-frame)) ;; Temporary kludge. (when (eq (slot-value frame 'climi::top) nil) (multiple-value-bind (x y) (xlib:query-pointer (clx-port-window (port fm))) (incf x 10) (setf (slot-value frame 'climi::left) x (slot-value frame 'climi::top) y)))) (defmethod adopt-frame :after ((fm clx-frame-manager) (frame menu-frame)) (when (sheet-enabled-p (slot-value frame 'top-level-sheet)) (xlib:map-window (sheet-direct-mirror (slot-value frame 'top-level-sheet))))) (defmethod adopt-frame :after ((fm clx-frame-manager) (frame application-frame)) (let ((sheet (slot-value frame 'top-level-sheet))) (let* ((top-level-sheet (frame-top-level-sheet frame)) (mirror (sheet-direct-mirror top-level-sheet))) (multiple-value-bind (w h x y) (climi::frame-geometry* frame) (declare (ignore w h)) (when (and x y) (setf (xlib:drawable-x mirror) x (xlib:drawable-y mirror) y)) (tell-window-manager-about-space-requirements top-level-sheet)) ;; :structure-notify events were not yet turned on, turn them ;; on now, so that we get informed about the windows position ;; (and possibly size), when the window gets maped. (setf (xlib:window-event-mask mirror) (logior (xlib:window-event-mask mirror) (xlib:make-event-mask :structure-notify))) ;; Care for calling-frame, be careful not to trip on missing bits (let* ((calling-frame (frame-calling-frame frame)) (tls (and calling-frame (frame-top-level-sheet calling-frame))) (calling-mirror (and tls (sheet-mirror tls)))) (when calling-mirror (setf (xlib:transient-for mirror) calling-mirror))) ;; (when (sheet-enabled-p sheet) (xlib:map-window mirror) )))) (defmethod tell-window-manager-about-space-requirements ((pane top-level-sheet-pane)) (multiple-value-bind (w h x y) (climi::frame-geometry* (pane-frame pane)) (declare (ignore w h)) (let ((q (compose-space pane))) (let ((mirror (sheet-direct-mirror pane))) (setf (xlib:wm-normal-hints mirror) (xlib:make-wm-size-hints :user-specified-position-p (and x y) :x x :y y :width (round (space-requirement-width q)) :height (round (space-requirement-height q)) :max-width (min 65535 (round (space-requirement-max-width q))) :max-height (min 65535 (round (space-requirement-max-height q))) :min-width (round (space-requirement-min-width q)) :min-height (round (space-requirement-min-height q)))) ) ))) (defmethod tell-window-manager-about-space-requirements ((pane t)) ;; hmm nil) (defmethod note-space-requirements-changed :after ((graft clx-graft) pane) (tell-window-manager-about-space-requirements pane)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/CLX/system.lisp0000644000175000017500000000230107776711603021366 0ustar pdmpdm;;; -*- Mode: Lisp; Package: User -*- ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :common-lisp-user) #+:excl(require :clx) #+:excl(require :loop) (clim-defsystem (:clim-clx :depends-on (:clim #+(and sbcl asdf) :clx)) "Backends/CLX/package" "Backends/CLX/keysyms-common" "Backends/CLX/keysyms" "Backends/CLX/keysymdef" "Backends/CLX/port" "Backends/CLX/medium" "Backends/CLX/graft" "Backends/CLX/frame-manager" "Backends/CLX/image" "Backends/CLX/clim-extensions" ) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/CLX/keysymdef.lisp0000600000175000017500000017520410423413302022021 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-XCOMMON; -*- (in-package :clim-xcommon) ;;/*********************************************************** ;;Copyright 1987, 1994, 1998 The Open Group ;; ;;All Rights Reserved. ;; ;;The above copyright notice and this permission notice shall be included ;;in all copies or substantial portions of the Software. ;; ;;THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS ;;OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. ;;IN NO EVENT SHALL THE OPEN GROUP BE LIABLE FOR ANY CLAIM, DAMAGES OR ;;OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ;;ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR ;;OTHER DEALINGS IN THE SOFTWARE. ;; ;;Except as contained in this notice, the name of The Open Group shall ;;not be used in advertising or otherwise to promote the sale, use or ;;other dealings in this Software without prior written authorization ;;from The Open Group. ;; ;; ;;Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts ;; ;; All Rights Reserved ;; ;;Permission to use, copy, modify, and distribute this software and its ;;documentation for any purpose and without fee is hereby granted, ;;provided that the above copyright notice appear in all copies and that ;;both that copyright notice and this permission notice appear in ;;supporting documentation, and that the name of Digital not be ;;used in advertising or publicity pertaining to distribution of the ;;software without specific, written prior permission. ;; ;;DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ;;ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL ;;DIGITAL BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ;;ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, ;;WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ;;ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS ;;SOFTWARE. ;; ;;******************************************************************/ (define-keysym :VOID-SYMBOL #xffffff) ;;/* ;; * TTY Functions, cleverly chosen to map to ascii, for convenience of ;; * programming, but could have been arbitrary (at the cost of lookup ;; * tables in client code. ;; */ (define-keysym :BACKSPACE #xff08) (define-keysym :TAB #xff09) (define-keysym :LINEFEED #xff0a) (define-keysym :CLEAR #xff0b) (define-keysym :RETURN #xff0d) (define-keysym :PAUSE #xff13) (define-keysym :SCROLL-LOCK #xff14) (define-keysym :SYS-REQ #xff15) (define-keysym :ESCAPE #xff1b) (define-keysym :DELETE #xffff) (define-keysym :MULTI-KEY #xff20) (define-keysym :CODEINPUT #xff37) (define-keysym :SINGLE-CANDIDATE #xff3c) (define-keysym :MULTIPLE-CANDIDATE #xff3d) (define-keysym :PREVIOUS-CANDIDATE #xff3e) (define-keysym :KANJI #xff21) (define-keysym :MUHENKAN #xff22) (define-keysym :HENKAN-MODE #xff23) (define-keysym :HENKAN #xff23) (define-keysym :ROMAJI #xff24) (define-keysym :HIRAGANA #xff25) (define-keysym :KATAKANA #xff26) (define-keysym :HIRAGANA-KATAKANA #xff27) (define-keysym :ZENKAKU #xff28) (define-keysym :HANKAKU #xff29) (define-keysym :ZENKAKU-HANKAKU #xff2a) (define-keysym :TOUROKU #xff2b) (define-keysym :MASSYO #xff2c) (define-keysym :KANA-LOCK #xff2d) (define-keysym :KANA-SHIFT #xff2e) (define-keysym :EISU-SHIFT #xff2f) (define-keysym :EISU-TOGGLE #xff30) (define-keysym :KANJI-BANGOU #xff37) (define-keysym :ZEN-KOHO #xff3d) (define-keysym :MAE-KOHO #xff3e) (define-keysym :HOME #xff50) (define-keysym :LEFT #xff51) (define-keysym :UP #xff52) (define-keysym :RIGHT #xff53) (define-keysym :DOWN #xff54) (define-keysym :PRIOR #xff55) (define-keysym :PAGE-UP #xff55) (define-keysym :NEXT #xff56) (define-keysym :PAGE-DOWN #xff56) (define-keysym :END #xff57) (define-keysym :BEGIN #xff58) (define-keysym :SELECT #xff60) (define-keysym :PRINT #xff61) (define-keysym :EXECUTE #xff62) (define-keysym :INSERT #xff63) (define-keysym :UNDO #xff65) (define-keysym :REDO #xff66) (define-keysym :MENU #xff67) (define-keysym :FIND #xff68) (define-keysym :CANCEL #xff69) (define-keysym :HELP #xff6a) (define-keysym :BREAK #xff6b) (define-keysym :MODE-SWITCH #xff7e) (define-keysym :SCRIPT-SWITCH #xff7e) (define-keysym :NUM-LOCK #xff7f) (define-keysym :KP-SPACE #xff80) (define-keysym :KP-TAB #xff89) (define-keysym :KP-ENTER #xff8d) (define-keysym :KP-F1 #xff91) (define-keysym :KP-F2 #xff92) (define-keysym :KP-F3 #xff93) (define-keysym :KP-F4 #xff94) (define-keysym :KP-HOME #xff95) (define-keysym :KP-LEFT #xff96) (define-keysym :KP-UP #xff97) (define-keysym :KP-RIGHT #xff98) (define-keysym :KP-DOWN #xff99) (define-keysym :KP-PRIOR #xff9a) (define-keysym :KP-PAGE-UP #xff9a) (define-keysym :KP-NEXT #xff9b) (define-keysym :KP-PAGE-DOWN #xff9b) (define-keysym :KP-END #xff9c) (define-keysym :KP-BEGIN #xff9d) (define-keysym :KP-INSERT #xff9e) (define-keysym :KP-DELETE #xff9f) (define-keysym :KP-EQUAL #xffbd) (define-keysym :KP-MULTIPLY #xffaa) (define-keysym :KP-ADD #xffab) (define-keysym :KP-SEPARATOR #xffac) (define-keysym :KP-SUBTRACT #xffad) (define-keysym :KP-DECIMAL #xffae) (define-keysym :KP-DIVIDE #xffaf) (define-keysym :KP-0 #xffb0) (define-keysym :KP-1 #xffb1) (define-keysym :KP-2 #xffb2) (define-keysym :KP-3 #xffb3) (define-keysym :KP-4 #xffb4) (define-keysym :KP-5 #xffb5) (define-keysym :KP-6 #xffb6) (define-keysym :KP-7 #xffb7) (define-keysym :KP-8 #xffb8) (define-keysym :KP-9 #xffb9) ;;/* ;; * Auxilliary Functions; note the duplicate definitions for left and right ;; * function keys; Sun keyboards and a few other manufactures have such ;; * function key groups on the left and/or right sides of the keyboard. ;; * We've not found a keyboard with more than 35 function keys total. ;; */ (define-keysym :F1 #xffbe) (define-keysym :F2 #xffbf) (define-keysym :F3 #xffc0) (define-keysym :F4 #xffc1) (define-keysym :F5 #xffc2) (define-keysym :F6 #xffc3) (define-keysym :F7 #xffc4) (define-keysym :F8 #xffc5) (define-keysym :F9 #xffc6) (define-keysym :F10 #xffc7) (define-keysym :F11 #xffc8) (define-keysym :L1 #xffc8) (define-keysym :F12 #xffc9) (define-keysym :L2 #xffc9) (define-keysym :F13 #xffca) (define-keysym :L3 #xffca) (define-keysym :F14 #xffcb) (define-keysym :L4 #xffcb) (define-keysym :F15 #xffcc) (define-keysym :L5 #xffcc) (define-keysym :F16 #xffcd) (define-keysym :L6 #xffcd) (define-keysym :F17 #xffce) (define-keysym :L7 #xffce) (define-keysym :F18 #xffcf) (define-keysym :L8 #xffcf) (define-keysym :F19 #xffd0) (define-keysym :L9 #xffd0) (define-keysym :F20 #xffd1) (define-keysym :L10 #xffd1) (define-keysym :F21 #xffd2) (define-keysym :R1 #xffd2) (define-keysym :F22 #xffd3) (define-keysym :R2 #xffd3) (define-keysym :F23 #xffd4) (define-keysym :R3 #xffd4) (define-keysym :F24 #xffd5) (define-keysym :R4 #xffd5) (define-keysym :F25 #xffd6) (define-keysym :R5 #xffd6) (define-keysym :F26 #xffd7) (define-keysym :R6 #xffd7) (define-keysym :F27 #xffd8) (define-keysym :R7 #xffd8) (define-keysym :F28 #xffd9) (define-keysym :R8 #xffd9) (define-keysym :F29 #xffda) (define-keysym :R9 #xffda) (define-keysym :F30 #xffdb) (define-keysym :R10 #xffdb) (define-keysym :F31 #xffdc) (define-keysym :R11 #xffdc) (define-keysym :F32 #xffdd) (define-keysym :R12 #xffdd) (define-keysym :F33 #xffde) (define-keysym :R13 #xffde) (define-keysym :F34 #xffdf) (define-keysym :R14 #xffdf) (define-keysym :F35 #xffe0) (define-keysym :R15 #xffe0) (define-keysym :SHIFT-LEFT #xffe1) (define-keysym :SHIFT-RIGHT #xffe2) (define-keysym :CONTROL-LEFT #xffe3) (define-keysym :CONTROL-RIGHT #xffe4) (define-keysym :CAPS-LOCK #xffe5) (define-keysym :SHIFT-LOCK #xffe6) (define-keysym :META-LEFT #xffe7) (define-keysym :META-RIGHT #xffe8) (define-keysym :ALT-LEFT #xffe9) (define-keysym :ALT-RIGHT #xffea) (define-keysym :SUPER-LEFT #xffeb) (define-keysym :SUPER-RIGHT #xffec) (define-keysym :HYPER-LEFT #xffed) (define-keysym :HYPER-RIGHT #xffee) ;;/* ;; * ISO 9995 Function and Modifier Keys ;; * Byte 3 = 0xFE ;; */ (define-keysym :ISO-LOCK #xfe01) (define-keysym :ISO-LEVEL2-LATCH #xfe02) (define-keysym :ISO-LEVEL3-SHIFT #xfe03) (define-keysym :ISO-LEVEL3-LATCH #xfe04) (define-keysym :ISO-LEVEL3-LOCK #xfe05) (define-keysym :ISO-GROUP-SHIFT #xff7e) (define-keysym :ISO-GROUP-LATCH #xfe06) (define-keysym :ISO-GROUP-LOCK #xfe07) (define-keysym :ISO-NEXT-GROUP #xfe08) (define-keysym :ISO-NEXT-GROUP-LOCK #xfe09) (define-keysym :ISO-PREV-GROUP #xfe0a) (define-keysym :ISO-PREV-GROUP-LOCK #xfe0b) (define-keysym :ISO-FIRST-GROUP #xfe0c) (define-keysym :ISO-FIRST-GROUP-LOCK #xfe0d) (define-keysym :ISO-LAST-GROUP #xfe0e) (define-keysym :ISO-LAST-GROUP-LOCK #xfe0f) (define-keysym :ISO-LEFT-TAB #xfe20) (define-keysym :ISO-MOVE-LINE-UP #xfe21) (define-keysym :ISO-MOVE-LINE-DOWN #xfe22) (define-keysym :ISO-PARTIAL-LINE-UP #xfe23) (define-keysym :ISO-PARTIAL-LINE-DOWN #xfe24) (define-keysym :ISO-PARTIAL-SPACE-LEFT #xfe25) (define-keysym :ISO-PARTIAL-SPACE-RIGHT #xfe26) (define-keysym :ISO-SET-MARGIN-LEFT #xfe27) (define-keysym :ISO-SET-MARGIN-RIGHT #xfe28) (define-keysym :ISO-RELEASE-MARGIN-LEFT #xfe29) (define-keysym :ISO-RELEASE-MARGIN-RIGHT #xfe2a) (define-keysym :ISO-RELEASE-BOTH-MARGINS #xfe2b) (define-keysym :ISO-FAST-CURSOR-LEFT #xfe2c) (define-keysym :ISO-FAST-CURSOR-RIGHT #xfe2d) (define-keysym :ISO-FAST-CURSOR-UP #xfe2e) (define-keysym :ISO-FAST-CURSOR-DOWN #xfe2f) (define-keysym :ISO-CONTINUOUS-UNDERLINE #xfe30) (define-keysym :ISO-DISCONTINUOUS-UNDERLINE #xfe31) (define-keysym :ISO-EMPHASIZE #xfe32) (define-keysym :ISO-CENTER-OBJECT #xfe33) (define-keysym :ISO-ENTER #xfe34) (define-keysym :DEAD-GRAVE #xfe50) (define-keysym :DEAD-ACUTE #xfe51) (define-keysym :DEAD-CIRCUMFLEX #xfe52) (define-keysym :DEAD-TILDE #xfe53) (define-keysym :DEAD-MACRON #xfe54) (define-keysym :DEAD-BREVE #xfe55) (define-keysym :DEAD-ABOVEDOT #xfe56) (define-keysym :DEAD-DIAERESIS #xfe57) (define-keysym :DEAD-ABOVE-RING #xfe58) (define-keysym :DEAD-DOUBLEACUTE #xfe59) (define-keysym :DEAD-CARON #xfe5a) (define-keysym :DEAD-CEDILLA #xfe5b) (define-keysym :DEAD-OGONEK #xfe5c) (define-keysym :DEAD-IOTA #xfe5d) (define-keysym :DEAD-VOICED-SOUND #xfe5e) (define-keysym :DEAD-SEMIVOICED-SOUND #xfe5f) (define-keysym :DEAD-BELOWDOT #xfe60) (define-keysym :FIRST-VIRTUAL-SCREEN #xfed0) (define-keysym :PREV-VIRTUAL-SCREEN #xfed1) (define-keysym :NEXT-VIRTUAL-SCREEN #xfed2) (define-keysym :LAST-VIRTUAL-SCREEN #xfed4) (define-keysym :TERMINATE-SERVER #xfed5) (define-keysym :ACCESS-X-ENABLE #xfe70) (define-keysym :ACCESS-X-FEEDBACK-ENABLE #xfe71) (define-keysym :REPEAT-KEYS-ENABLE #xfe72) (define-keysym :SLOW-KEYS-ENABLE #xfe73) (define-keysym :BOUNCE-KEYS-ENABLE #xfe74) (define-keysym :STICKY-KEYS-ENABLE #xfe75) (define-keysym :MOUSE-KEYS-ENABLE #xfe76) (define-keysym :MOUSE-KEYS-ACCEL-ENABLE #xfe77) (define-keysym :OVERLAY1-ENABLE #xfe78) (define-keysym :OVERLAY2-ENABLE #xfe79) (define-keysym :AUDIBLE-BELL-ENABLE #xfe7a) (define-keysym :POINTER-LEFT #xfee0) (define-keysym :POINTER-RIGHT #xfee1) (define-keysym :POINTER-UP #xfee2) (define-keysym :POINTER-DOWN #xfee3) (define-keysym :POINTER-UP-LEFT #xfee4) (define-keysym :POINTER-UP-RIGHT #xfee5) (define-keysym :POINTER-DOWN-LEFT #xfee6) (define-keysym :POINTER-DOWN-RIGHT #xfee7) (define-keysym :POINTER-BUTTON-DFLT #xfee8) (define-keysym :POINTER-BUTTON1 #xfee9) (define-keysym :POINTER-BUTTON2 #xfeea) (define-keysym :POINTER-BUTTON3 #xfeeb) (define-keysym :POINTER-BUTTON4 #xfeec) (define-keysym :POINTER-BUTTON5 #xfeed) (define-keysym :POINTER-DBL-CLICK-DFLT #xfeee) (define-keysym :POINTER-DBL-CLICK1 #xfeef) (define-keysym :POINTER-DBL-CLICK2 #xfef0) (define-keysym :POINTER-DBL-CLICK3 #xfef1) (define-keysym :POINTER-DBL-CLICK4 #xfef2) (define-keysym :POINTER-DBL-CLICK5 #xfef3) (define-keysym :POINTER-DRAG-DFLT #xfef4) (define-keysym :POINTER-DRAG1 #xfef5) (define-keysym :POINTER-DRAG2 #xfef6) (define-keysym :POINTER-DRAG3 #xfef7) (define-keysym :POINTER-DRAG4 #xfef8) (define-keysym :POINTER-DRAG5 #xfefd) (define-keysym :POINTER-ENABLE-KEYS #xfef9) (define-keysym :POINTER-ACCELERATE #xfefa) (define-keysym :POINTER-DFLT-BTN-NEXT #xfefb) (define-keysym :POINTER-DFLT-BTN-PREV #xfefc) ;;/* ;; * 3270 Terminal Keys ;; * Byte 3 = 0xFD ;; */ (define-keysym :3270-DUPLICATE #xfd01) (define-keysym :3270-FIELD-MARK #xfd02) (define-keysym :3270-RIGHT2 #xfd03) (define-keysym :3270-LEFT2 #xfd04) (define-keysym :3270-BACK-TAB #xfd05) (define-keysym :3270-ERASE-EOF #xfd06) (define-keysym :3270-ERASE-INPUT #xfd07) (define-keysym :3270-RESET #xfd08) (define-keysym :3270-QUIT #xfd09) (define-keysym :3270-PA1 #xfd0a) (define-keysym :3270-PA2 #xfd0b) (define-keysym :3270-PA3 #xfd0c) (define-keysym :3270-TEST #xfd0d) (define-keysym :3270-ATTN #xfd0e) (define-keysym :3270-CURSOR-BLINK #xfd0f) (define-keysym :3270-ALT-CURSOR #xfd10) (define-keysym :3270-KEY-CLICK #xfd11) (define-keysym :3270-JUMP #xfd12) (define-keysym :3270-IDENT #xfd13) (define-keysym :3270-RULE #xfd14) (define-keysym :3270-COPY #xfd15) (define-keysym :3270-PLAY #xfd16) (define-keysym :3270-SETUP #xfd17) (define-keysym :3270-RECORD #xfd18) (define-keysym :3270-CHANGE-SCREEN #xfd19) (define-keysym :3270-DELETE-WORD #xfd1a) (define-keysym :3270-EX-SELECT #xfd1b) (define-keysym :3270-CURSOR-SELECT #xfd1c) (define-keysym :3270-PRINT-SCREEN #xfd1d) (define-keysym :3270-ENTER #xfd1e) ;;/* ;; * Latin 1 ;; * Byte 3 = 0 ;; */ (define-keysym :| | #x20) (define-keysym :|!| #x21) (define-keysym :|"| #x22) (define-keysym :|#| #x23) (define-keysym :$ #x24) (define-keysym :% #x25) (define-keysym :& #x26) (define-keysym :|'| #x27) (define-keysym :|(| #x28) (define-keysym :|)| #x29) (define-keysym :* #x2a) (define-keysym :+ #x2b) (define-keysym :|,| #x2c) (define-keysym :- #x2d) (define-keysym :\. #x2e) (define-keysym :/ #x2f) (define-keysym :|0| #x30) (define-keysym :|1| #x31) (define-keysym :|2| #x32) (define-keysym :|3| #x33) (define-keysym :|4| #x34) (define-keysym :|5| #x35) (define-keysym :|6| #x36) (define-keysym :|7| #x37) (define-keysym :|8| #x38) (define-keysym :|9| #x39) (define-keysym :|:| #x3a) (define-keysym :|;| #x3b) (define-keysym :< #x3c) (define-keysym := #x3d) (define-keysym :> #x3e) (define-keysym :|?| #x3f) (define-keysym :@ #x40) (define-keysym :A #x41) (define-keysym :B #x42) (define-keysym :C #x43) (define-keysym :D #x44) (define-keysym :E #x45) (define-keysym :F #x46) (define-keysym :G #x47) (define-keysym :H #x48) (define-keysym :I #x49) (define-keysym :J #x4a) (define-keysym :K #x4b) (define-keysym :L #x4c) (define-keysym :M #x4d) (define-keysym :N #x4e) (define-keysym :O #x4f) (define-keysym :P #x50) (define-keysym :Q #x51) (define-keysym :R #x52) (define-keysym :S #x53) (define-keysym :T #x54) (define-keysym :U #x55) (define-keysym :V #x56) (define-keysym :W #x57) (define-keysym :X #x58) (define-keysym :Y #x59) (define-keysym :Z #x5a) (define-keysym :|[| #x5b) (define-keysym :\\ #x5c) (define-keysym :|]| #x5d) (define-keysym :^ #x5e) (define-keysym :_ #x5f) (define-keysym :|`| #x60) (define-keysym :|a| #x61) (define-keysym :|b| #x62) (define-keysym :|c| #x63) (define-keysym :|d| #x64) (define-keysym :|e| #x65) (define-keysym :|f| #x66) (define-keysym :|g| #x67) (define-keysym :|h| #x68) (define-keysym :|i| #x69) (define-keysym :|j| #x6a) (define-keysym :|k| #x6b) (define-keysym :|l| #x6c) (define-keysym :|m| #x6d) (define-keysym :|n| #x6e) (define-keysym :|o| #x6f) (define-keysym :|p| #x70) (define-keysym :|q| #x71) (define-keysym :|r| #x72) (define-keysym :|s| #x73) (define-keysym :|t| #x74) (define-keysym :|u| #x75) (define-keysym :|v| #x76) (define-keysym :|w| #x77) (define-keysym :|x| #x78) (define-keysym :|y| #x79) (define-keysym :|z| #x7a) (define-keysym :|{| #x7b) (define-keysym :\| #x7c) (define-keysym :|}| #x7d) (define-keysym :|~| #x7e) (define-keysym :NOBREAKSPACE #xa0) (define-keysym :EXCLAMDOWN #xa1) (define-keysym :CENT #xa2) (define-keysym :STERLING #xa3) (define-keysym :CURRENCY #xa4) (define-keysym :YEN #xa5) (define-keysym :BROKENBAR #xa6) (define-keysym :SECTION #xa7) (define-keysym :-DIAERESIS #xa8) (define-keysym :COPYRIGHT #xa9) (define-keysym :ORDFEMININE #xaa) (define-keysym :GUILLEMOTLEFT #xab) (define-keysym :NOTSIGN #xac) (define-keysym :HYPHEN #xad) (define-keysym :REGISTERED #xae) (define-keysym :-MACRON #xaf) (define-keysym :DEGREE #xb0) (define-keysym :PLUSMINUS #xb1) (define-keysym :TWOSUPERIOR #xb2) (define-keysym :THREESUPERIOR #xb3) (define-keysym :-ACUTE #xb4) (define-keysym :MU #xb5) (define-keysym :PARAGRAPH #xb6) (define-keysym :PERIODCENTERED #xb7) (define-keysym :-CEDILLA #xb8) (define-keysym :ONESUPERIOR #xb9) (define-keysym :MASCULINE #xba) (define-keysym :GUILLEMOTRIGHT #xbb) (define-keysym :ONEQUARTER #xbc) (define-keysym :ONEHALF #xbd) (define-keysym :THREEQUARTERS #xbe) (define-keysym :QUESTIONDOWN #xbf) (define-keysym :A-GRAVE #xc0) (define-keysym :A-ACUTE #xc1) (define-keysym :A-CIRCUMFLEX #xc2) (define-keysym :A-TILDE #xc3) (define-keysym :A-DIAERESIS #xc4) (define-keysym :A-RING #xc5) (define-keysym :AE #xc6) (define-keysym :C-CEDILLA #xc7) (define-keysym :E-GRAVE #xc8) (define-keysym :E-ACUTE #xc9) (define-keysym :E-CIRCUMFLEX #xca) (define-keysym :E-DIAERESIS #xcb) (define-keysym :I-GRAVE #xcc) (define-keysym :I-ACUTE #xcd) (define-keysym :I-CIRCUMFLEX #xce) (define-keysym :I-DIAERESIS #xcf) (define-keysym :ETH #xd0) (define-keysym :N-TILDE #xd1) (define-keysym :O-GRAVE #xd2) (define-keysym :O-ACUTE #xd3) (define-keysym :O-CIRCUMFLEX #xd4) (define-keysym :O-TILDE #xd5) (define-keysym :O-DIAERESIS #xd6) (define-keysym :MULTIPLY #xd7) (define-keysym :OOBLIQUE #xd8) (define-keysym :U-GRAVE #xd9) (define-keysym :U-ACUTE #xda) (define-keysym :U-CIRCUMFLEX #xdb) (define-keysym :U-DIAERESIS #xdc) (define-keysym :Y-ACUTE #xdd) (define-keysym :THORN #xde) (define-keysym :SSHARP #xdf) (define-keysym :|a-GRAVE| #xe0) (define-keysym :|a-ACUTE| #xe1) (define-keysym :|a-CIRCUMFLEX| #xe2) (define-keysym :|a-TILDE| #xe3) (define-keysym :|a-DIAERESIS| #xe4) (define-keysym :|a-RING| #xe5) (define-keysym :|ae| #xe6) (define-keysym :|c-CEDILLA| #xe7) (define-keysym :|e-GRAVE| #xe8) (define-keysym :|e-ACUTE| #xe9) (define-keysym :|e-CIRCUMFLEX| #xea) (define-keysym :|e-DIAERESIS| #xeb) (define-keysym :|i-GRAVE| #xec) (define-keysym :|i-ACUTE| #xed) (define-keysym :|i-CIRCUMFLEX| #xee) (define-keysym :|i-DIAERESIS| #xef) (define-keysym :|eth| #xf0) (define-keysym :|n-TILDE| #xf1) (define-keysym :|o-GRAVE| #xf2) (define-keysym :|o-ACUTE| #xf3) (define-keysym :|o-CIRCUMFLEX| #xf4) (define-keysym :|o-TILDE| #xf5) (define-keysym :|o-DIAERESIS| #xf6) (define-keysym :DIVISION #xf7) (define-keysym :O-SLASH #xf8) (define-keysym :|u-GRAVE| #xf9) (define-keysym :|u-ACUTE| #xfa) (define-keysym :|u-CIRCUMFLEX| #xfb) (define-keysym :|u-DIAERESIS| #xfc) (define-keysym :|y-ACUTE| #xfd) (define-keysym :|thorn| #xfe) (define-keysym :|y-DIAERESIS| #xff) ;;/* ;; * Latin 2 ;; * Byte 3 = 1 ;; */ (define-keysym :A-OGONEK #x1a1) (define-keysym :-BREVE #x1a2) (define-keysym :L-STROKE #x1a3) (define-keysym :L-CARON #x1a5) (define-keysym :S-ACUTE #x1a6) (define-keysym :S-CARON #x1a9) (define-keysym :S-CEDILLA #x1aa) (define-keysym :T-CARON #x1ab) (define-keysym :Z-ACUTE #x1ac) (define-keysym :Z-CARON #x1ae) (define-keysym :Z-ABOVEDOT #x1af) (define-keysym :|a-OGONEK| #x1b1) (define-keysym :-OGONEK #x1b2) (define-keysym :|l-STROKE| #x1b3) (define-keysym :|l-CARON| #x1b5) (define-keysym :|s-ACUTE| #x1b6) (define-keysym :-CARON #x1b7) (define-keysym :|s-CARON| #x1b9) (define-keysym :|s-CEDILLA| #x1ba) (define-keysym :|t-CARON| #x1bb) (define-keysym :|z-ACUTE| #x1bc) (define-keysym :-DOUBLEACUTE #x1bd) (define-keysym :|z-CARON| #x1be) (define-keysym :|z-ABOVEDOT| #x1bf) (define-keysym :R-ACUTE #x1c0) (define-keysym :A-BREVE #x1c3) (define-keysym :L-ACUTE #x1c5) (define-keysym :C-ACUTE #x1c6) (define-keysym :C-CARON #x1c8) (define-keysym :E-OGONEK #x1ca) (define-keysym :E-CARON #x1cc) (define-keysym :D-CARON #x1cf) (define-keysym :D-STROKE #x1d0) (define-keysym :N-ACUTE #x1d1) (define-keysym :N-CARON #x1d2) (define-keysym :O-DOUBLEACUTE #x1d5) (define-keysym :R-CARON #x1d8) (define-keysym :U-RING #x1d9) (define-keysym :U-DOUBLEACUTE #x1db) (define-keysym :T-CEDILLA #x1de) (define-keysym :|r-ACUTE| #x1e0) (define-keysym :|a-BREVE| #x1e3) (define-keysym :|l-ACUTE| #x1e5) (define-keysym :|c-ACUTE| #x1e6) (define-keysym :|c-CARON| #x1e8) (define-keysym :|e-OGONEK| #x1ea) (define-keysym :|e-CARON| #x1ec) (define-keysym :|d-CARON| #x1ef) (define-keysym :|d-STROKE| #x1f0) (define-keysym :|n-ACUTE| #x1f1) (define-keysym :|n-CARON| #x1f2) (define-keysym :|o-DOUBLEACUTE| #x1f5) (define-keysym :|u-DOUBLEACUTE| #x1fb) (define-keysym :|r-CARON| #x1f8) (define-keysym :|u-RING| #x1f9) (define-keysym :|t-CEDILLA| #x1fe) (define-keysym :-ABOVEDOT #x1ff) ;;/* ;; * Latin 3 ;; * Byte 3 = 2 ;; */ (define-keysym :H-STROKE #x2a1) (define-keysym :H-CIRCUMFLEX #x2a6) (define-keysym :I-ABOVEDOT #x2a9) (define-keysym :G-BREVE #x2ab) (define-keysym :J-CIRCUMFLEX #x2ac) (define-keysym :|h-STROKE| #x2b1) (define-keysym :|h-CIRCUMFLEX| #x2b6) (define-keysym :IDOTLESS #x2b9) (define-keysym :|g-BREVE| #x2bb) (define-keysym :|j-CIRCUMFLEX| #x2bc) (define-keysym :C-ABOVEDOT #x2c5) (define-keysym :C-CIRCUMFLEX #x2c6) (define-keysym :G-ABOVEDOT #x2d5) (define-keysym :G-CIRCUMFLEX #x2d8) (define-keysym :U-BREVE #x2dd) (define-keysym :S-CIRCUMFLEX #x2de) (define-keysym :|c-ABOVEDOT| #x2e5) (define-keysym :|c-CIRCUMFLEX| #x2e6) (define-keysym :|g-ABOVEDOT| #x2f5) (define-keysym :|g-CIRCUMFLEX| #x2f8) (define-keysym :|u-BREVE| #x2fd) (define-keysym :|s-CIRCUMFLEX| #x2fe) ;;/* ;; * Latin 4 ;; * Byte 3 = 3 ;; */ (define-keysym :KRA #x3a2) (define-keysym :R-CEDILLA #x3a3) (define-keysym :I-TILDE #x3a5) (define-keysym :L-CEDILLA #x3a6) (define-keysym :E-MACRON #x3aa) (define-keysym :G-CEDILLA #x3ab) (define-keysym :T-SLASH #x3ac) (define-keysym :|r-CEDILLA| #x3b3) (define-keysym :|i-TILDE| #x3b5) (define-keysym :|l-CEDILLA| #x3b6) (define-keysym :|e-MACRON| #x3ba) (define-keysym :|g-CEDILLA| #x3bb) (define-keysym :|t-SLASH| #x3bc) (define-keysym :ENG #x3bd) (define-keysym :|eng| #x3bf) (define-keysym :A-MACRON #x3c0) (define-keysym :I-OGONEK #x3c7) (define-keysym :E-ABOVEDOT #x3cc) (define-keysym :I-MACRON #x3cf) (define-keysym :N-CEDILLA #x3d1) (define-keysym :O-MACRON #x3d2) (define-keysym :K-CEDILLA #x3d3) (define-keysym :U-OGONEK #x3d9) (define-keysym :U-TILDE #x3dd) (define-keysym :U-MACRON #x3de) (define-keysym :|a-MACRON| #x3e0) (define-keysym :|i-OGONEK| #x3e7) (define-keysym :|e-ABOVEDOT| #x3ec) (define-keysym :|i-MACRON| #x3ef) (define-keysym :|n-CEDILLA| #x3f1) (define-keysym :|o-MACRON| #x3f2) (define-keysym :|k-CEDILLA| #x3f3) (define-keysym :|u-OGONEK| #x3f9) (define-keysym :|u-TILDE| #x3fd) (define-keysym :|u-MACRON| #x3fe) ;;/* ;; * Latin-9 (a.k.a. Latin-0) ;; * Byte 3 = 19 ;; */ (define-keysym :OE #x13bc) (define-keysym :|oe| #x13bd) (define-keysym :Y-DIAERESIS #x13be) ;;/* ;; * Katakana ;; * Byte 3 = 4 ;; */ (define-keysym :OVERLINE #x47e) (define-keysym :KANA-FULLSTOP #x4a1) (define-keysym :KANA-OPENINGBRACKET #x4a2) (define-keysym :KANA-CLOSINGBRACKET #x4a3) (define-keysym :KANA-COMMA #x4a4) (define-keysym :KANA-CONJUNCTIVE #x4a5) (define-keysym :KANA-WO #x4a6) (define-keysym :|KANA-a| #x4a7) (define-keysym :|KANA-i| #x4a8) (define-keysym :|KANA-u| #x4a9) (define-keysym :|KANA-e| #x4aa) (define-keysym :|KANA-o| #x4ab) (define-keysym :|KANA-ya| #x4ac) (define-keysym :|KANA-yu| #x4ad) (define-keysym :|KANA-yo| #x4ae) (define-keysym :|KANA-tsu| #x4af) (define-keysym :PROLONGEDSOUND #x4b0) (define-keysym :KANA-A #x4b1) (define-keysym :KANA-I #x4b2) (define-keysym :KANA-U #x4b3) (define-keysym :KANA-E #x4b4) (define-keysym :KANA-O #x4b5) (define-keysym :KANA-KA #x4b6) (define-keysym :KANA-KI #x4b7) (define-keysym :KANA-KU #x4b8) (define-keysym :KANA-KE #x4b9) (define-keysym :KANA-KO #x4ba) (define-keysym :KANA-SA #x4bb) (define-keysym :KANA-SHI #x4bc) (define-keysym :KANA-SU #x4bd) (define-keysym :KANA-SE #x4be) (define-keysym :KANA-SO #x4bf) (define-keysym :KANA-TA #x4c0) (define-keysym :KANA-CHI #x4c1) (define-keysym :KANA-TSU #x4c2) (define-keysym :KANA-TE #x4c3) (define-keysym :KANA-TO #x4c4) (define-keysym :KANA-NA #x4c5) (define-keysym :KANA-NI #x4c6) (define-keysym :KANA-NU #x4c7) (define-keysym :KANA-NE #x4c8) (define-keysym :KANA-NO #x4c9) (define-keysym :KANA-HA #x4ca) (define-keysym :KANA-HI #x4cb) (define-keysym :KANA-FU #x4cc) (define-keysym :KANA-HE #x4cd) (define-keysym :KANA-HO #x4ce) (define-keysym :KANA-MA #x4cf) (define-keysym :KANA-MI #x4d0) (define-keysym :KANA-MU #x4d1) (define-keysym :KANA-ME #x4d2) (define-keysym :KANA-MO #x4d3) (define-keysym :KANA-YA #x4d4) (define-keysym :KANA-YU #x4d5) (define-keysym :KANA-YO #x4d6) (define-keysym :KANA-RA #x4d7) (define-keysym :KANA-RI #x4d8) (define-keysym :KANA-RU #x4d9) (define-keysym :KANA-RE #x4da) (define-keysym :KANA-RO #x4db) (define-keysym :KANA-WA #x4dc) (define-keysym :KANA-N #x4dd) (define-keysym :VOICEDSOUND #x4de) (define-keysym :SEMIVOICEDSOUND #x4df) (define-keysym :KANA-SWITCH #xff7e) ;;/* ;; * Arabic ;; * Byte 3 = 5 ;; */ (define-keysym :ARABIC-COMMA #x5ac) (define-keysym :ARABIC-SEMICOLON #x5bb) (define-keysym :ARABIC-QUESTION-MARK #x5bf) (define-keysym :ARABIC-HAMZA #x5c1) (define-keysym :ARABIC-MADDAONALEF #x5c2) (define-keysym :ARABIC-HAMZAONALEF #x5c3) (define-keysym :ARABIC-HAMZAONWAW #x5c4) (define-keysym :ARABIC-HAMZAUNDERALEF #x5c5) (define-keysym :ARABIC-HAMZAONYEH #x5c6) (define-keysym :ARABIC-ALEF #x5c7) (define-keysym :ARABIC-BEH #x5c8) (define-keysym :ARABIC-TEHMARBUTA #x5c9) (define-keysym :ARABIC-TEH #x5ca) (define-keysym :ARABIC-THEH #x5cb) (define-keysym :ARABIC-JEEM #x5cc) (define-keysym :ARABIC-HAH #x5cd) (define-keysym :ARABIC-KHAH #x5ce) (define-keysym :ARABIC-DAL #x5cf) (define-keysym :ARABIC-THAL #x5d0) (define-keysym :ARABIC-RA #x5d1) (define-keysym :ARABIC-ZAIN #x5d2) (define-keysym :ARABIC-SEEN #x5d3) (define-keysym :ARABIC-SHEEN #x5d4) (define-keysym :ARABIC-SAD #x5d5) (define-keysym :ARABIC-DAD #x5d6) (define-keysym :ARABIC-TAH #x5d7) (define-keysym :ARABIC-ZAH #x5d8) (define-keysym :ARABIC-AIN #x5d9) (define-keysym :ARABIC-GHAIN #x5da) (define-keysym :ARABIC-TATWEEL #x5e0) (define-keysym :ARABIC-FEH #x5e1) (define-keysym :ARABIC-QAF #x5e2) (define-keysym :ARABIC-KAF #x5e3) (define-keysym :ARABIC-LAM #x5e4) (define-keysym :ARABIC-MEEM #x5e5) (define-keysym :ARABIC-NOON #x5e6) (define-keysym :ARABIC-HA #x5e7) (define-keysym :ARABIC-WAW #x5e8) (define-keysym :ARABIC-ALEFMAKSURA #x5e9) (define-keysym :ARABIC-YEH #x5ea) (define-keysym :ARABIC-FATHATAN #x5eb) (define-keysym :ARABIC-DAMMATAN #x5ec) (define-keysym :ARABIC-KASRATAN #x5ed) (define-keysym :ARABIC-FATHA #x5ee) (define-keysym :ARABIC-DAMMA #x5ef) (define-keysym :ARABIC-KASRA #x5f0) (define-keysym :ARABIC-SHADDA #x5f1) (define-keysym :ARABIC-SUKUN #x5f2) (define-keysym :ARABIC-SWITCH #xff7e) ;;/* ;; * Cyrillic ;; * Byte 3 = 6 ;; */ (define-keysym :|SERBIAN-dje| #x6a1) (define-keysym :|MACEDONIA-gje| #x6a2) (define-keysym :|CYRILLIC-io| #x6a3) (define-keysym :|UKRAINIAN-ie| #x6a4) (define-keysym :|MACEDONIA-dse| #x6a5) (define-keysym :|UKRAINIAN-i| #x6a6) (define-keysym :|UKRAINIAN-yi| #x6a7) (define-keysym :|CYRILLIC-je| #x6a8) (define-keysym :|CYRILLIC-lje| #x6a9) (define-keysym :|CYRILLIC-nje| #x6aa) (define-keysym :|SERBIAN-tshe| #x6ab) (define-keysym :|MACEDONIA-kje| #x6ac) (define-keysym :|BYELORUSSIAN-shortu| #x6ae) (define-keysym :|CYRILLIC-dzhe| #x6af) (define-keysym :NUMEROSIGN #x6b0) (define-keysym :SERBIAN-DJE #x6b1) (define-keysym :MACEDONIA-GJE #x6b2) (define-keysym :CYRILLIC-IO #x6b3) (define-keysym :UKRAINIAN-IE #x6b4) (define-keysym :MACEDONIA-DSE #x6b5) (define-keysym :UKRAINIAN-I #x6b6) (define-keysym :UKRAINIAN-YI #x6b7) (define-keysym :CYRILLIC-JE #x6b8) (define-keysym :CYRILLIC-LJE #x6b9) (define-keysym :CYRILLIC-NJE #x6ba) (define-keysym :SERBIAN-TSHE #x6bb) (define-keysym :MACEDONIA-KJE #x6bc) (define-keysym :BYELORUSSIAN-SHORTU #x6be) (define-keysym :CYRILLIC-DZHE #x6bf) (define-keysym :|CYRILLIC-yu| #x6c0) (define-keysym :|CYRILLIC-a| #x6c1) (define-keysym :|CYRILLIC-be| #x6c2) (define-keysym :|CYRILLIC-tse| #x6c3) (define-keysym :|CYRILLIC-de| #x6c4) (define-keysym :|CYRILLIC-ie| #x6c5) (define-keysym :|CYRILLIC-ef| #x6c6) (define-keysym :|CYRILLIC-ghe| #x6c7) (define-keysym :|CYRILLIC-ha| #x6c8) (define-keysym :|CYRILLIC-i| #x6c9) (define-keysym :|CYRILLIC-shorti| #x6ca) (define-keysym :|CYRILLIC-ka| #x6cb) (define-keysym :|CYRILLIC-el| #x6cc) (define-keysym :|CYRILLIC-em| #x6cd) (define-keysym :|CYRILLIC-en| #x6ce) (define-keysym :|CYRILLIC-o| #x6cf) (define-keysym :|CYRILLIC-pe| #x6d0) (define-keysym :|CYRILLIC-ya| #x6d1) (define-keysym :|CYRILLIC-er| #x6d2) (define-keysym :|CYRILLIC-es| #x6d3) (define-keysym :|CYRILLIC-te| #x6d4) (define-keysym :|CYRILLIC-u| #x6d5) (define-keysym :|CYRILLIC-zhe| #x6d6) (define-keysym :|CYRILLIC-ve| #x6d7) (define-keysym :|CYRILLIC-softsign| #x6d8) (define-keysym :|CYRILLIC-yeru| #x6d9) (define-keysym :|CYRILLIC-ze| #x6da) (define-keysym :|CYRILLIC-sha| #x6db) (define-keysym :|CYRILLIC-e| #x6dc) (define-keysym :|CYRILLIC-shcha| #x6dd) (define-keysym :|CYRILLIC-che| #x6de) (define-keysym :|CYRILLIC-hardsign| #x6df) (define-keysym :CYRILLIC-YU #x6e0) (define-keysym :CYRILLIC-A #x6e1) (define-keysym :CYRILLIC-BE #x6e2) (define-keysym :CYRILLIC-TSE #x6e3) (define-keysym :CYRILLIC-DE #x6e4) (define-keysym :CYRILLIC-IE #x6e5) (define-keysym :CYRILLIC-EF #x6e6) (define-keysym :CYRILLIC-GHE #x6e7) (define-keysym :CYRILLIC-HA #x6e8) (define-keysym :CYRILLIC-I #x6e9) (define-keysym :CYRILLIC-SHORTI #x6ea) (define-keysym :CYRILLIC-KA #x6eb) (define-keysym :CYRILLIC-EL #x6ec) (define-keysym :CYRILLIC-EM #x6ed) (define-keysym :CYRILLIC-EN #x6ee) (define-keysym :CYRILLIC-O #x6ef) (define-keysym :CYRILLIC-PE #x6f0) (define-keysym :CYRILLIC-YA #x6f1) (define-keysym :CYRILLIC-ER #x6f2) (define-keysym :CYRILLIC-ES #x6f3) (define-keysym :CYRILLIC-TE #x6f4) (define-keysym :CYRILLIC-U #x6f5) (define-keysym :CYRILLIC-ZHE #x6f6) (define-keysym :CYRILLIC-VE #x6f7) (define-keysym :CYRILLIC-SOFTSIGN #x6f8) (define-keysym :CYRILLIC-YERU #x6f9) (define-keysym :CYRILLIC-ZE #x6fa) (define-keysym :CYRILLIC-SHA #x6fb) (define-keysym :CYRILLIC-E #x6fc) (define-keysym :CYRILLIC-SHCHA #x6fd) (define-keysym :CYRILLIC-CHE #x6fe) (define-keysym :CYRILLIC-HARDSIGN #x6ff) ;;/* ;; * Greek ;; * Byte 3 = 7 ;; */ (define-keysym :GREEK-ALPHA-ACCENT #x7a1) (define-keysym :GREEK-EPSILON-ACCENT #x7a2) (define-keysym :GREEK-ETA-ACCENT #x7a3) (define-keysym :GREEK-IOTA-ACCENT #x7a4) (define-keysym :GREEK-IOTA-DIAERESIS #x7a5) (define-keysym :GREEK-OMICRON-ACCENT #x7a7) (define-keysym :GREEK-UPSILON-ACCENT #x7a8) (define-keysym :GREEK-UPSILON-DIERESIS #x7a9) (define-keysym :GREEK-OMEGA-ACCENT #x7ab) (define-keysym :GREEK-ACCENT-DIERESIS #x7ae) (define-keysym :GREEK-HORIZBAR #x7af) (define-keysym :|GREEK-alpha-ACCENT| #x7b1) (define-keysym :|GREEK-epsilon-ACCENT| #x7b2) (define-keysym :|GREEK-eta-ACCENT| #x7b3) (define-keysym :|GREEK-iota-ACCENT| #x7b4) (define-keysym :GREEK-IOTA-DIERESIS #x7b5) (define-keysym :GREEK-IOTAACCENT-DIERESIS #x7b6) (define-keysym :|GREEK-omicron-ACCENT| #x7b7) (define-keysym :|GREEK-upsilon-ACCENT| #x7b8) (define-keysym :|GREEK-upsilon-DIERESIS| #x7b9) (define-keysym :GREEK-UPSILONACCENT-DIERESIS #x7ba) (define-keysym :|GREEK-omega-ACCENT| #x7bb) (define-keysym :GREEK-ALPHA #x7c1) (define-keysym :GREEK-BETA #x7c2) (define-keysym :GREEK-GAMMA #x7c3) (define-keysym :GREEK-DELTA #x7c4) (define-keysym :GREEK-EPSILON #x7c5) (define-keysym :GREEK-ZETA #x7c6) (define-keysym :GREEK-ETA #x7c7) (define-keysym :GREEK-THETA #x7c8) (define-keysym :GREEK-IOTA #x7c9) (define-keysym :GREEK-KAPPA #x7ca) (define-keysym :GREEK-LAMDA #x7cb) (define-keysym :GREEK-LAMBDA #x7cb) (define-keysym :GREEK-MU #x7cc) (define-keysym :GREEK-NU #x7cd) (define-keysym :GREEK-XI #x7ce) (define-keysym :GREEK-OMICRON #x7cf) (define-keysym :GREEK-PI #x7d0) (define-keysym :GREEK-RHO #x7d1) (define-keysym :GREEK-SIGMA #x7d2) (define-keysym :GREEK-TAU #x7d4) (define-keysym :GREEK-UPSILON #x7d5) (define-keysym :GREEK-PHI #x7d6) (define-keysym :GREEK-CHI #x7d7) (define-keysym :GREEK-PSI #x7d8) (define-keysym :GREEK-OMEGA #x7d9) (define-keysym :|GREEK-alpha| #x7e1) (define-keysym :|GREEK-beta| #x7e2) (define-keysym :|GREEK-gamma| #x7e3) (define-keysym :|GREEK-delta| #x7e4) (define-keysym :|GREEK-epsilon| #x7e5) (define-keysym :|GREEK-zeta| #x7e6) (define-keysym :|GREEK-eta| #x7e7) (define-keysym :|GREEK-theta| #x7e8) (define-keysym :|GREEK-iota| #x7e9) (define-keysym :|GREEK-kappa| #x7ea) (define-keysym :|GREEK-lamda| #x7eb) (define-keysym :|GREEK-lambda| #x7eb) (define-keysym :|GREEK-mu| #x7ec) (define-keysym :|GREEK-nu| #x7ed) (define-keysym :|GREEK-xi| #x7ee) (define-keysym :|GREEK-omicron| #x7ef) (define-keysym :|GREEK-pi| #x7f0) (define-keysym :|GREEK-rho| #x7f1) (define-keysym :|GREEK-sigma| #x7f2) (define-keysym :GREEK-FINALSMALLSIGMA #x7f3) (define-keysym :|GREEK-tau| #x7f4) (define-keysym :|GREEK-upsilon| #x7f5) (define-keysym :|GREEK-phi| #x7f6) (define-keysym :|GREEK-chi| #x7f7) (define-keysym :|GREEK-psi| #x7f8) (define-keysym :|GREEK-omega| #x7f9) (define-keysym :GREEK-SWITCH #xff7e) ;;/* ;; * Technical ;; * Byte 3 = 8 ;; */ (define-keysym :LEFTRADICAL #x8a1) (define-keysym :TOPLEFTRADICAL #x8a2) (define-keysym :HORIZCONNECTOR #x8a3) (define-keysym :TOPINTEGRAL #x8a4) (define-keysym :BOTINTEGRAL #x8a5) (define-keysym :VERTCONNECTOR #x8a6) (define-keysym :TOPLEFTSQBRACKET #x8a7) (define-keysym :BOTLEFTSQBRACKET #x8a8) (define-keysym :TOPRIGHTSQBRACKET #x8a9) (define-keysym :BOTRIGHTSQBRACKET #x8aa) (define-keysym :TOPLEFTPARENS #x8ab) (define-keysym :BOTLEFTPARENS #x8ac) (define-keysym :TOPRIGHTPARENS #x8ad) (define-keysym :BOTRIGHTPARENS #x8ae) (define-keysym :LEFTMIDDLECURLYBRACE #x8af) (define-keysym :RIGHTMIDDLECURLYBRACE #x8b0) (define-keysym :TOPLEFTSUMMATION #x8b1) (define-keysym :BOTLEFTSUMMATION #x8b2) (define-keysym :TOPVERTSUMMATIONCONNECTOR #x8b3) (define-keysym :BOTVERTSUMMATIONCONNECTOR #x8b4) (define-keysym :TOPRIGHTSUMMATION #x8b5) (define-keysym :BOTRIGHTSUMMATION #x8b6) (define-keysym :RIGHTMIDDLESUMMATION #x8b7) (define-keysym :LESSTHANEQUAL #x8bc) (define-keysym :NOTEQUAL #x8bd) (define-keysym :GREATERTHANEQUAL #x8be) (define-keysym :INTEGRAL #x8bf) (define-keysym :THEREFORE #x8c0) (define-keysym :VARIATION #x8c1) (define-keysym :INFINITY #x8c2) (define-keysym :NABLA #x8c5) (define-keysym :APPROXIMATE #x8c8) (define-keysym :SIMILAREQUAL #x8c9) (define-keysym :IFONLYIF #x8cd) (define-keysym :IMPLIES #x8ce) (define-keysym :IDENTICAL #x8cf) (define-keysym :RADICAL #x8d6) (define-keysym :INCLUDEDIN #x8da) (define-keysym :INCLUDES #x8db) (define-keysym :INTERSECTION #x8dc) (define-keysym :UNION #x8dd) (define-keysym :LOGICALAND #x8de) (define-keysym :LOGICALOR #x8df) (define-keysym :PARTIALDERIVATIVE #x8ef) (define-keysym :FUNCTION #x8f6) (define-keysym :LEFTARROW #x8fb) (define-keysym :UPARROW #x8fc) (define-keysym :RIGHTARROW #x8fd) (define-keysym :DOWNARROW #x8fe) ;;/* ;; * Special ;; * Byte 3 = 9 ;; */ (define-keysym :BLANK #x9df) (define-keysym :SOLIDDIAMOND #x9e0) (define-keysym :CHECKERBOARD #x9e1) (define-keysym :HT #x9e2) (define-keysym :FF #x9e3) (define-keysym :CR #x9e4) (define-keysym :LF #x9e5) (define-keysym :NL #x9e8) (define-keysym :VT #x9e9) (define-keysym :LOWRIGHTCORNER #x9ea) (define-keysym :UPRIGHTCORNER #x9eb) (define-keysym :UPLEFTCORNER #x9ec) (define-keysym :LOWLEFTCORNER #x9ed) (define-keysym :CROSSINGLINES #x9ee) (define-keysym :HORIZLINESCAN1 #x9ef) (define-keysym :HORIZLINESCAN3 #x9f0) (define-keysym :HORIZLINESCAN5 #x9f1) (define-keysym :HORIZLINESCAN7 #x9f2) (define-keysym :HORIZLINESCAN9 #x9f3) (define-keysym :LEFTT #x9f4) (define-keysym :RIGHTT #x9f5) (define-keysym :BOTT #x9f6) (define-keysym :TOPT #x9f7) (define-keysym :VERTBAR #x9f8) ;;/* ;; * Publishing ;; * Byte 3 = a ;; */ (define-keysym :EMSPACE #xaa1) (define-keysym :ENSPACE #xaa2) (define-keysym :EM3SPACE #xaa3) (define-keysym :EM4SPACE #xaa4) (define-keysym :DIGITSPACE #xaa5) (define-keysym :PUNCTSPACE #xaa6) (define-keysym :THINSPACE #xaa7) (define-keysym :HAIRSPACE #xaa8) (define-keysym :EMDASH #xaa9) (define-keysym :ENDASH #xaaa) (define-keysym :SIGNIFBLANK #xaac) (define-keysym :ELLIPSIS #xaae) (define-keysym :DOUBBASELINEDOT #xaaf) (define-keysym :ONETHIRD #xab0) (define-keysym :TWOTHIRDS #xab1) (define-keysym :ONEFIFTH #xab2) (define-keysym :TWOFIFTHS #xab3) (define-keysym :THREEFIFTHS #xab4) (define-keysym :FOURFIFTHS #xab5) (define-keysym :ONESIXTH #xab6) (define-keysym :FIVESIXTHS #xab7) (define-keysym :CAREOF #xab8) (define-keysym :FIGDASH #xabb) (define-keysym :LEFTANGLEBRACKET #xabc) (define-keysym :DECIMALPOINT #xabd) (define-keysym :RIGHTANGLEBRACKET #xabe) (define-keysym :MARKER #xabf) (define-keysym :ONEEIGHTH #xac3) (define-keysym :THREEEIGHTHS #xac4) (define-keysym :FIVEEIGHTHS #xac5) (define-keysym :SEVENEIGHTHS #xac6) (define-keysym :TRADEMARK #xac9) (define-keysym :SIGNATUREMARK #xaca) (define-keysym :TRADEMARKINCIRCLE #xacb) (define-keysym :LEFTOPENTRIANGLE #xacc) (define-keysym :RIGHTOPENTRIANGLE #xacd) (define-keysym :EMOPENCIRCLE #xace) (define-keysym :EMOPENRECTANGLE #xacf) (define-keysym :LEFTSINGLEQUOTEMARK #xad0) (define-keysym :RIGHTSINGLEQUOTEMARK #xad1) (define-keysym :LEFTDOUBLEQUOTEMARK #xad2) (define-keysym :RIGHTDOUBLEQUOTEMARK #xad3) (define-keysym :PRESCRIPTION #xad4) (define-keysym :MINUTES #xad6) (define-keysym :SECONDS #xad7) (define-keysym :LATINCROSS #xad9) (define-keysym :HEXAGRAM #xada) (define-keysym :FILLEDRECTBULLET #xadb) (define-keysym :FILLEDLEFTTRIBULLET #xadc) (define-keysym :FILLEDRIGHTTRIBULLET #xadd) (define-keysym :EMFILLEDCIRCLE #xade) (define-keysym :EMFILLEDRECT #xadf) (define-keysym :ENOPENCIRCBULLET #xae0) (define-keysym :ENOPENSQUAREBULLET #xae1) (define-keysym :OPENRECTBULLET #xae2) (define-keysym :OPENTRIBULLETUP #xae3) (define-keysym :OPENTRIBULLETDOWN #xae4) (define-keysym :OPENSTAR #xae5) (define-keysym :ENFILLEDCIRCBULLET #xae6) (define-keysym :ENFILLEDSQBULLET #xae7) (define-keysym :FILLEDTRIBULLETUP #xae8) (define-keysym :FILLEDTRIBULLETDOWN #xae9) (define-keysym :LEFTPOINTER #xaea) (define-keysym :RIGHTPOINTER #xaeb) (define-keysym :CLUB #xaec) (define-keysym :DIAMOND #xaed) (define-keysym :HEART #xaee) (define-keysym :MALTESECROSS #xaf0) (define-keysym :DAGGER #xaf1) (define-keysym :DOUBLEDAGGER #xaf2) (define-keysym :CHECKMARK #xaf3) (define-keysym :BALLOTCROSS #xaf4) (define-keysym :MUSICALSHARP #xaf5) (define-keysym :MUSICALFLAT #xaf6) (define-keysym :MALESYMBOL #xaf7) (define-keysym :FEMALESYMBOL #xaf8) (define-keysym :TELEPHONE #xaf9) (define-keysym :TELEPHONERECORDER #xafa) (define-keysym :PHONOGRAPHCOPYRIGHT #xafb) (define-keysym :CARET #xafc) (define-keysym :SINGLELOWQUOTEMARK #xafd) (define-keysym :DOUBLELOWQUOTEMARK #xafe) (define-keysym :CURSOR #xaff) ;;/* ;; * APL ;; * Byte 3 = b ;; */ (define-keysym :LEFTCARET #xba3) (define-keysym :RIGHTCARET #xba6) (define-keysym :DOWNCARET #xba8) (define-keysym :UPCARET #xba9) (define-keysym :OVERBAR #xbc0) (define-keysym :DOWNTACK #xbc2) (define-keysym :UPSHOE #xbc3) (define-keysym :DOWNSTILE #xbc4) (define-keysym :UNDERBAR #xbc6) (define-keysym :JOT #xbca) (define-keysym :QUAD #xbcc) (define-keysym :UPTACK #xbce) (define-keysym :CIRCLE #xbcf) (define-keysym :UPSTILE #xbd3) (define-keysym :DOWNSHOE #xbd6) (define-keysym :RIGHTSHOE #xbd8) (define-keysym :LEFTSHOE #xbda) (define-keysym :LEFTTACK #xbdc) (define-keysym :RIGHTTACK #xbfc) ;;/* ;; * Hebrew ;; * Byte 3 = c ;; */ (define-keysym :HEBREW-DOUBLELOWLINE #xcdf) (define-keysym :HEBREW-ALEPH #xce0) (define-keysym :HEBREW-BET #xce1) (define-keysym :HEBREW-GIMEL #xce2) (define-keysym :HEBREW-DALET #xce3) (define-keysym :HEBREW-HE #xce4) (define-keysym :HEBREW-WAW #xce5) (define-keysym :HEBREW-ZAIN #xce6) (define-keysym :HEBREW-CHET #xce7) (define-keysym :HEBREW-TET #xce8) (define-keysym :HEBREW-YOD #xce9) (define-keysym :HEBREW-FINALKAPH #xcea) (define-keysym :HEBREW-KAPH #xceb) (define-keysym :HEBREW-LAMED #xcec) (define-keysym :HEBREW-FINALMEM #xced) (define-keysym :HEBREW-MEM #xcee) (define-keysym :HEBREW-FINALNUN #xcef) (define-keysym :HEBREW-NUN #xcf0) (define-keysym :HEBREW-SAMECH #xcf1) (define-keysym :HEBREW-AYIN #xcf2) (define-keysym :HEBREW-FINALPE #xcf3) (define-keysym :HEBREW-PE #xcf4) (define-keysym :HEBREW-FINALZADE #xcf5) (define-keysym :HEBREW-ZADE #xcf6) (define-keysym :HEBREW-QOPH #xcf7) (define-keysym :HEBREW-RESH #xcf8) (define-keysym :HEBREW-SHIN #xcf9) (define-keysym :HEBREW-TAW #xcfa) (define-keysym :HEBREW-SWITCH #xff7e) ;;/* ;; * Thai ;; * Byte 3 = d ;; */ (define-keysym :THAI-KOKAI #xda1) (define-keysym :THAI-KHOKHAI #xda2) (define-keysym :THAI-KHOKHUAT #xda3) (define-keysym :THAI-KHOKHWAI #xda4) (define-keysym :THAI-KHOKHON #xda5) (define-keysym :THAI-KHORAKHANG #xda6) (define-keysym :THAI-NGONGU #xda7) (define-keysym :THAI-CHOCHAN #xda8) (define-keysym :THAI-CHOCHING #xda9) (define-keysym :THAI-CHOCHANG #xdaa) (define-keysym :THAI-SOSO #xdab) (define-keysym :THAI-CHOCHOE #xdac) (define-keysym :THAI-YOYING #xdad) (define-keysym :THAI-DOCHADA #xdae) (define-keysym :THAI-TOPATAK #xdaf) (define-keysym :THAI-THOTHAN #xdb0) (define-keysym :THAI-THONANGMONTHO #xdb1) (define-keysym :THAI-THOPHUTHAO #xdb2) (define-keysym :THAI-NONEN #xdb3) (define-keysym :THAI-DODEK #xdb4) (define-keysym :THAI-TOTAO #xdb5) (define-keysym :THAI-THOTHUNG #xdb6) (define-keysym :THAI-THOTHAHAN #xdb7) (define-keysym :THAI-THOTHONG #xdb8) (define-keysym :THAI-NONU #xdb9) (define-keysym :THAI-BOBAIMAI #xdba) (define-keysym :THAI-POPLA #xdbb) (define-keysym :THAI-PHOPHUNG #xdbc) (define-keysym :THAI-FOFA #xdbd) (define-keysym :THAI-PHOPHAN #xdbe) (define-keysym :THAI-FOFAN #xdbf) (define-keysym :THAI-PHOSAMPHAO #xdc0) (define-keysym :THAI-MOMA #xdc1) (define-keysym :THAI-YOYAK #xdc2) (define-keysym :THAI-RORUA #xdc3) (define-keysym :THAI-RU #xdc4) (define-keysym :THAI-LOLING #xdc5) (define-keysym :THAI-LU #xdc6) (define-keysym :THAI-WOWAEN #xdc7) (define-keysym :THAI-SOSALA #xdc8) (define-keysym :THAI-SORUSI #xdc9) (define-keysym :THAI-SOSUA #xdca) (define-keysym :THAI-HOHIP #xdcb) (define-keysym :THAI-LOCHULA #xdcc) (define-keysym :THAI-OANG #xdcd) (define-keysym :THAI-HONOKHUK #xdce) (define-keysym :THAI-PAIYANNOI #xdcf) (define-keysym :THAI-SARAA #xdd0) (define-keysym :THAI-MAIHANAKAT #xdd1) (define-keysym :THAI-SARAAA #xdd2) (define-keysym :THAI-SARAAM #xdd3) (define-keysym :THAI-SARAI #xdd4) (define-keysym :THAI-SARAII #xdd5) (define-keysym :THAI-SARAUE #xdd6) (define-keysym :THAI-SARAUEE #xdd7) (define-keysym :THAI-SARAU #xdd8) (define-keysym :THAI-SARAUU #xdd9) (define-keysym :THAI-PHINTHU #xdda) (define-keysym :THAI-MAIHANAKAT-MAITHO #xdde) (define-keysym :THAI-BAHT #xddf) (define-keysym :THAI-SARAE #xde0) (define-keysym :THAI-SARAAE #xde1) (define-keysym :THAI-SARAO #xde2) (define-keysym :THAI-SARAAIMAIMUAN #xde3) (define-keysym :THAI-SARAAIMAIMALAI #xde4) (define-keysym :THAI-LAKKHANGYAO #xde5) (define-keysym :THAI-MAIYAMOK #xde6) (define-keysym :THAI-MAITAIKHU #xde7) (define-keysym :THAI-MAIEK #xde8) (define-keysym :THAI-MAITHO #xde9) (define-keysym :THAI-MAITRI #xdea) (define-keysym :THAI-MAICHATTAWA #xdeb) (define-keysym :THAI-THANTHAKHAT #xdec) (define-keysym :THAI-NIKHAHIT #xded) (define-keysym :THAI-LEKSUN #xdf0) (define-keysym :THAI-LEKNUNG #xdf1) (define-keysym :THAI-LEKSONG #xdf2) (define-keysym :THAI-LEKSAM #xdf3) (define-keysym :THAI-LEKSI #xdf4) (define-keysym :THAI-LEKHA #xdf5) (define-keysym :THAI-LEKHOK #xdf6) (define-keysym :THAI-LEKCHET #xdf7) (define-keysym :THAI-LEKPAET #xdf8) (define-keysym :THAI-LEKKAO #xdf9) ;;/* ;; * Korean ;; * Byte 3 = e ;; */ (define-keysym :HANGUL #xff31) (define-keysym :HANGUL-START #xff32) (define-keysym :HANGUL-END #xff33) (define-keysym :HANGUL-HANJA #xff34) (define-keysym :HANGUL-JAMO #xff35) (define-keysym :HANGUL-ROMAJA #xff36) (define-keysym :HANGUL-CODEINPUT #xff37) (define-keysym :HANGUL-JEONJA #xff38) (define-keysym :HANGUL-BANJA #xff39) (define-keysym :HANGUL-PRE-HANJA #xff3a) (define-keysym :HANGUL-POST-HANJA #xff3b) (define-keysym :HANGUL-SINGLE-CANDIDATE #xff3c) (define-keysym :HANGUL-MULTIPLE-CANDIDATE #xff3d) (define-keysym :HANGUL-PREVIOUS-CANDIDATE #xff3e) (define-keysym :HANGUL-SPECIAL #xff3f) (define-keysym :HANGUL-SWITCH #xff7e) (define-keysym :HANGUL-KIYEOG #xea1) (define-keysym :HANGUL-SSANG-KIYEOG #xea2) (define-keysym :HANGUL-KIYEOG-SIOS #xea3) (define-keysym :HANGUL-NIEUN #xea4) (define-keysym :HANGUL-NIEUN-JIEUJ #xea5) (define-keysym :HANGUL-NIEUN-HIEUH #xea6) (define-keysym :HANGUL-DIKEUD #xea7) (define-keysym :HANGUL-SSANG-DIKEUD #xea8) (define-keysym :HANGUL-RIEUL #xea9) (define-keysym :HANGUL-RIEUL-KIYEOG #xeaa) (define-keysym :HANGUL-RIEUL-MIEUM #xeab) (define-keysym :HANGUL-RIEUL-PIEUB #xeac) (define-keysym :HANGUL-RIEUL-SIOS #xead) (define-keysym :HANGUL-RIEUL-TIEUT #xeae) (define-keysym :HANGUL-RIEUL-PHIEUF #xeaf) (define-keysym :HANGUL-RIEUL-HIEUH #xeb0) (define-keysym :HANGUL-MIEUM #xeb1) (define-keysym :HANGUL-PIEUB #xeb2) (define-keysym :HANGUL-SSANG-PIEUB #xeb3) (define-keysym :HANGUL-PIEUB-SIOS #xeb4) (define-keysym :HANGUL-SIOS #xeb5) (define-keysym :HANGUL-SSANG-SIOS #xeb6) (define-keysym :HANGUL-IEUNG #xeb7) (define-keysym :HANGUL-JIEUJ #xeb8) (define-keysym :HANGUL-SSANG-JIEUJ #xeb9) (define-keysym :HANGUL-CIEUC #xeba) (define-keysym :HANGUL-KHIEUQ #xebb) (define-keysym :HANGUL-TIEUT #xebc) (define-keysym :HANGUL-PHIEUF #xebd) (define-keysym :HANGUL-HIEUH #xebe) (define-keysym :HANGUL-A #xebf) (define-keysym :HANGUL-AE #xec0) (define-keysym :HANGUL-YA #xec1) (define-keysym :HANGUL-YAE #xec2) (define-keysym :HANGUL-EO #xec3) (define-keysym :HANGUL-E #xec4) (define-keysym :HANGUL-YEO #xec5) (define-keysym :HANGUL-YE #xec6) (define-keysym :HANGUL-O #xec7) (define-keysym :HANGUL-WA #xec8) (define-keysym :HANGUL-WAE #xec9) (define-keysym :HANGUL-OE #xeca) (define-keysym :HANGUL-YO #xecb) (define-keysym :HANGUL-U #xecc) (define-keysym :HANGUL-WEO #xecd) (define-keysym :HANGUL-WE #xece) (define-keysym :HANGUL-WI #xecf) (define-keysym :HANGUL-YU #xed0) (define-keysym :HANGUL-EU #xed1) (define-keysym :HANGUL-YI #xed2) (define-keysym :HANGUL-I #xed3) (define-keysym :HANGUL-J-KIYEOG #xed4) (define-keysym :HANGUL-J-SSANG-KIYEOG #xed5) (define-keysym :HANGUL-J-KIYEOG-SIOS #xed6) (define-keysym :HANGUL-J-NIEUN #xed7) (define-keysym :HANGUL-J-NIEUN-JIEUJ #xed8) (define-keysym :HANGUL-J-NIEUN-HIEUH #xed9) (define-keysym :HANGUL-J-DIKEUD #xeda) (define-keysym :HANGUL-J-RIEUL #xedb) (define-keysym :HANGUL-J-RIEUL-KIYEOG #xedc) (define-keysym :HANGUL-J-RIEUL-MIEUM #xedd) (define-keysym :HANGUL-J-RIEUL-PIEUB #xede) (define-keysym :HANGUL-J-RIEUL-SIOS #xedf) (define-keysym :HANGUL-J-RIEUL-TIEUT #xee0) (define-keysym :HANGUL-J-RIEUL-PHIEUF #xee1) (define-keysym :HANGUL-J-RIEUL-HIEUH #xee2) (define-keysym :HANGUL-J-MIEUM #xee3) (define-keysym :HANGUL-J-PIEUB #xee4) (define-keysym :HANGUL-J-PIEUB-SIOS #xee5) (define-keysym :HANGUL-J-SIOS #xee6) (define-keysym :HANGUL-J-SSANG-SIOS #xee7) (define-keysym :HANGUL-J-IEUNG #xee8) (define-keysym :HANGUL-J-JIEUJ #xee9) (define-keysym :HANGUL-J-CIEUC #xeea) (define-keysym :HANGUL-J-KHIEUQ #xeeb) (define-keysym :HANGUL-J-TIEUT #xeec) (define-keysym :HANGUL-J-PHIEUF #xeed) (define-keysym :HANGUL-J-HIEUH #xeee) (define-keysym :HANGUL-RIEUL-YEORIN-HIEUH #xeef) (define-keysym :HANGUL-SUNKYEONGEUM-MIEUM #xef0) (define-keysym :HANGUL-SUNKYEONGEUM-PIEUB #xef1) (define-keysym :HANGUL-PAN-SIOS #xef2) (define-keysym :HANGUL-KKOGJI-DALRIN-IEUNG #xef3) (define-keysym :HANGUL-SUNKYEONGEUM-PHIEUF #xef4) (define-keysym :HANGUL-YEORIN-HIEUH #xef5) (define-keysym :HANGUL-ARAE-A #xef6) (define-keysym :HANGUL-ARAE-AE #xef7) (define-keysym :HANGUL-J-PAN-SIOS #xef8) (define-keysym :HANGUL-J-KKOGJI-DALRIN-IEUNG #xef9) (define-keysym :HANGUL-J-YEORIN-HIEUH #xefa) (define-keysym :KOREAN-WON #xeff) (define-keysym :ECU-SIGN #x20a0) (define-keysym :COLON-SIGN #x20a1) (define-keysym :CRUZEIRO-SIGN #x20a2) (define-keysym :FFRANC-SIGN #x20a3) (define-keysym :LIRA-SIGN #x20a4) (define-keysym :MILL-SIGN #x20a5) (define-keysym :NAIRA-SIGN #x20a6) (define-keysym :PESETA-SIGN #x20a7) (define-keysym :RUPEE-SIGN #x20a8) (define-keysym :WON-SIGN #x20a9) (define-keysym :NEW-SHEQEL-SIGN #x20aa) (define-keysym :DONG-SIGN #x20ab) (define-keysym :EURO-SIGN #x20ac) ;;/*********************************************************** ;; ;;Copyright (c) 1988 X Consortium ;; ;;Permission is hereby granted, free of charge, to any person obtaining a copy ;;of this software and associated documentation files (the "Software"), to deal ;;in the Software without restriction, including without limitation the rights ;;to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;copies of the Software, and to permit persons to whom the Software is ;;furnished to do so, subject to the following conditions: ;; ;;The above copyright notice and this permission notice shall be included in ;;all copies or substantial portions of the Software. ;; ;;THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN ;;AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN ;;CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;; ;;Except as contained in this notice, the name of the X Consortium shall not be ;;used in advertising or otherwise to promote the sale, use or other dealings ;;in this Software without prior written authorization from the X Consortium. ;; ;; ;;Copyright 1988 by Digital Equipment Corporation, Maynard, Massachusetts. ;; ;; All Rights Reserved ;; ;;Permission to use, copy, modify, and distribute this software and its ;;documentation for any purpose and without fee is hereby granted, ;;provided that the above copyright notice appear in all copies and that ;;both that copyright notice and this permission notice appear in ;;supporting documentation, and that the name of Digital not be ;;used in advertising or publicity pertaining to distribution of the ;;software without specific, written prior permission. ;; ;;DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ;;ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL ;;DIGITAL BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ;;ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, ;;WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ;;ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS ;;SOFTWARE. ;; ;;******************************************************************/ ;;/* ;; * DEC private keysyms ;; * (29th bit set) ;; */ (define-keysym :D-RING-ACCENT #x1000feb0) (define-keysym :D-CIRCUMFLEX-ACCENT #x1000fe5e) (define-keysym :D-CEDILLA-ACCENT #x1000fe2c) (define-keysym :D-ACUTE-ACCENT #x1000fe27) (define-keysym :D-GRAVE-ACCENT #x1000fe60) (define-keysym :D-TILDE #x1000fe7e) (define-keysym :D-DIAERESIS #x1000fe22) (define-keysym :D-REMOVE #x1000ff00) ;;/* ;; ;;Copyright (c) 1987 X Consortium ;; ;;Permission is hereby granted, free of charge, to any person obtaining ;;a copy of this software and associated documentation files (the ;;"Software"), to deal in the Software without restriction, including ;;without limitation the rights to use, copy, modify, merge, publish, ;;distribute, sublicense, and/or sell copies of the Software, and to ;;permit persons to whom the Software is furnished to do so, subject to ;;the following conditions: ;; ;;The above copyright notice and this permission notice shall be included ;;in all copies or substantial portions of the Software. ;; ;;THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS ;;OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. ;;IN NO EVENT SHALL THE X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR ;;OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ;;ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR ;;OTHER DEALINGS IN THE SOFTWARE. ;; ;;Except as contained in this notice, the name of the X Consortium shall ;;not be used in advertising or otherwise to promote the sale, use or ;;other dealings in this Software without prior written authorization ;;from the X Consortium. ;; ;;Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts, ;; ;; All Rights Reserved ;; ;;Permission to use, copy, modify, and distribute this software and its ;;documentation for any purpose and without fee is hereby granted, ;;provided that the above copyright notice appear in all copies and that ;;both that copyright notice and this permission notice appear in ;;supporting documentation, and that the names of Hewlett Packard ;;or Digital not be ;;used in advertising or publicity pertaining to distribution of the ;;software without specific, written prior permission. ;; ;;DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ;;ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL ;;DIGITAL BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ;;ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, ;;WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ;;ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS ;;SOFTWARE. ;; ;;HEWLETT-PACKARD MAKES NO WARRANTY OF ANY KIND WITH REGARD ;;TO THIS SOFWARE, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;;PURPOSE. Hewlett-Packard shall not be liable for errors ;;contained herein or direct, indirect, special, incidental or ;;consequential damages in connection with the furnishing, ;;performance, or use of this material. ;; ;;*/ (define-keysym :HP-CLEAR-LINE #x1000ff6f) (define-keysym :HP-INSERT-LINE #x1000ff70) (define-keysym :HP-DELETE-LINE #x1000ff71) (define-keysym :HP-INSERT-CHAR #x1000ff72) (define-keysym :HP-DELETE-CHAR #x1000ff73) (define-keysym :HP-BACK-TAB #x1000ff74) (define-keysym :HP-KP-BACK-TAB #x1000ff75) (define-keysym :HP-MODELOCK1 #x1000ff48) (define-keysym :HP-MODELOCK2 #x1000ff49) (define-keysym :HP-RESET #x1000ff6c) (define-keysym :HP-SYSTEM #x1000ff6d) (define-keysym :HP-USER #x1000ff6e) (define-keysym :HP-MUTE-ACUTE #x100000a8) (define-keysym :HP-MUTE-GRAVE #x100000a9) (define-keysym :HP-MUTE-ASCIICIRCUM #x100000aa) (define-keysym :HP-MUTE-DIAERESIS #x100000ab) (define-keysym :HP-MUTE-ASCII-TILDE #x100000ac) (define-keysym :HP-LIRA #x100000af) (define-keysym :HP-GUILDER #x100000be) (define-keysym :HP-Y-DIAERESIS #x100000ee) (define-keysym :HP-IO #x100000ee) (define-keysym :HP-LONGMINUS #x100000f6) (define-keysym :HP-BLOCK #x100000fc) (define-keysym :OSF-COPY #x1004ff02) (define-keysym :OSF-CUT #x1004ff03) (define-keysym :OSF-PASTE #x1004ff04) (define-keysym :OSF-BACK-TAB #x1004ff07) (define-keysym :OSF-BACK-SPACE #x1004ff08) (define-keysym :OSF-CLEAR #x1004ff0b) (define-keysym :OSF-ESCAPE #x1004ff1b) (define-keysym :OSF-ADD-MODE #x1004ff31) (define-keysym :OSF-PRIMARY-PASTE #x1004ff32) (define-keysym :OSF-QUICK-PASTE #x1004ff33) (define-keysym :OSF-PAGE-LEFT #x1004ff40) (define-keysym :OSF-PAGE-UP #x1004ff41) (define-keysym :OSF-PAGE-DOWN #x1004ff42) (define-keysym :OSF-PAGE-RIGHT #x1004ff43) (define-keysym :OSF-ACTIVATE #x1004ff44) (define-keysym :OSF-MENU-BAR #x1004ff45) (define-keysym :OSF-LEFT #x1004ff51) (define-keysym :OSF-UP #x1004ff52) (define-keysym :OSF-RIGHT #x1004ff53) (define-keysym :OSF-DOWN #x1004ff54) (define-keysym :OSF-END-LINE #x1004ff57) (define-keysym :OSF-BEGIN-LINE #x1004ff58) (define-keysym :OSF-END-DATA #x1004ff59) (define-keysym :OSF-BEGIN-DATA #x1004ff5a) (define-keysym :OSF-PREV-MENU #x1004ff5b) (define-keysym :OSF-NEXT-MENU #x1004ff5c) (define-keysym :OSF-PREV-FIELD #x1004ff5d) (define-keysym :OSF-NEXT-FIELD #x1004ff5e) (define-keysym :OSF-SELECT #x1004ff60) (define-keysym :OSF-INSERT #x1004ff63) (define-keysym :OSF-UNDO #x1004ff65) (define-keysym :OSF-MENU #x1004ff67) (define-keysym :OSF-CANCEL #x1004ff69) (define-keysym :OSF-HELP #x1004ff6a) (define-keysym :OSF-SELECT-ALL #x1004ff71) (define-keysym :OSF-DESELECT-ALL #x1004ff72) (define-keysym :OSF-RESELECT #x1004ff73) (define-keysym :OSF-EXTEND #x1004ff74) (define-keysym :OSF-RESTORE #x1004ff78) (define-keysym :OSF-DELETE #x1004ffff) ;;/************************************************************** ;; * The use of the following macros is deprecated. ;; * They are listed below only for backwards compatibility. ;; */ (define-keysym :RESET #x1000ff6c) (define-keysym :SYSTEM #x1000ff6d) (define-keysym :USER #x1000ff6e) (define-keysym :CLEAR-LINE #x1000ff6f) (define-keysym :INSERT-LINE #x1000ff70) (define-keysym :DELETE-LINE #x1000ff71) (define-keysym :INSERT-CHAR #x1000ff72) (define-keysym :DELETE-CHAR #x1000ff73) (define-keysym :BACK-TAB #x1000ff74) (define-keysym :KP-BACK-TAB #x1000ff75) (define-keysym :EXT16BIT-L #x1000ff76) (define-keysym :EXT16BIT-R #x1000ff77) (define-keysym :MUTE-ACUTE #x100000a8) (define-keysym :MUTE-GRAVE #x100000a9) (define-keysym :MUTE-ASCIICIRCUM #x100000aa) (define-keysym :MUTE-DIAERESIS #x100000ab) (define-keysym :MUTE-ASCII-TILDE #x100000ac) (define-keysym :LIRA #x100000af) (define-keysym :GUILDER #x100000be) (define-keysym :Y-DIAERESIS #x100000ee) (define-keysym :IO #x100000ee) (define-keysym :LONGMINUS #x100000f6) (define-keysym :BLOCK #x100000fc) ;;/************************************************************ ;; ;;Copyright (c) 1991 X Consortium ;; ;;Permission is hereby granted, free of charge, to any person obtaining a copy ;;of this software and associated documentation files (the "Software"), to deal ;;in the Software without restriction, including without limitation the rights ;;to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;copies of the Software, and to permit persons to whom the Software is ;;furnished to do so, subject to the following conditions: ;; ;;The above copyright notice and this permission notice shall be included in ;;all copies or substantial portions of the Software. ;; ;;THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN ;;AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN ;;CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;; ;;Except as contained in this notice, the name of the X Consortium shall not be ;;used in advertising or otherwise to promote the sale, use or other dealings ;;in this Software without prior written authorization from the X Consortium. ;; ;; ;;Copyright 1991 by Sun Microsystems, Inc. Mountain View, CA. ;; ;; All Rights Reserved ;; ;;Permission to use, copy, modify, and distribute this ;;software and its documentation for any purpose and without ;;fee is hereby granted, provided that the above copyright no- ;;tice appear in all copies and that both that copyright no- ;;tice and this permission notice appear in supporting docu- ;;mentation, and that the name of Sun not be used in ;;advertising or publicity pertaining to distribution of the ;;software without specific prior written permission. Sun ;;makes no representations about the suitability of this ;;software for any purpose. It is provided "as is" without any ;;express or implied warranty. ;; ;;SUN DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, ;;INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FIT- ;;NESS FOR A PARTICULAR PURPOSE. IN NO EVENT SHALL SUN BE LI- ;;ABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ;;ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR ;;PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR ;;OTHER TORTUOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH ;;THE USE OR PERFORMANCE OF THIS SOFTWARE. ;; ;;***********************************************************/ ;;/* ;; * Floating Accent ;; */ (define-keysym :SUN-FA-GRAVE #x1005ff00) (define-keysym :SUN-FA-CIRCUM #x1005ff01) (define-keysym :SUN-FA-TILDE #x1005ff02) (define-keysym :SUN-FA-ACUTE #x1005ff03) (define-keysym :SUN-FA-DIAERESIS #x1005ff04) (define-keysym :SUN-FA-CEDILLA #x1005ff05) ;;/* ;; * Miscellaneous Functions ;; */ (define-keysym :SUN-F36 #x1005ff10) (define-keysym :SUN-F37 #x1005ff11) (define-keysym :SUN-SYS-REQ #x1005ff60) (define-keysym :SUN-PRINT-SCREEN #xff61) ;;/* ;; * International & Multi-Key Character Composition ;; */ (define-keysym :SUN-COMPOSE #xff20) (define-keysym :SUN-ALT-GRAPH #xff7e) ;;/* ;; * Cursor Control ;; */ (define-keysym :SUN-PAGE-UP #xff55) (define-keysym :SUN-PAGE-DOWN #xff56) ;;/* ;; * Open Look Functions ;; */ (define-keysym :SUN-UNDO #xff65) (define-keysym :SUN-AGAIN #xff66) (define-keysym :SUN-FIND #xff68) (define-keysym :SUN-STOP #xff69) (define-keysym :SUN-PROPS #x1005ff70) (define-keysym :SUN-FRONT #x1005ff71) (define-keysym :SUN-COPY #x1005ff72) (define-keysym :SUN-OPEN #x1005ff73) (define-keysym :SUN-PASTE #x1005ff74) (define-keysym :SUN-CUT #x1005ff75) (define-keysym :SUN-POWER-SWITCH #x1005ff76) (define-keysym :SUN-AUDIO-LOWER-VOLUME #x1005ff77) (define-keysym :SUN-AUDIO-MUTE #x1005ff78) (define-keysym :SUN-AUDIO-RAISE-VOLUME #x1005ff79) (define-keysym :SUN-VIDEO-DEGAUSS #x1005ff7a) (define-keysym :SUN-VIDEO-LOWER-BRIGHTNESS #x1005ff7b) (define-keysym :SUN-VIDEO-RAISE-BRIGHTNESS #x1005ff7c) (define-keysym :SUN-POWER-SWITCH-SHIFT #x1005ff7d) ;;/****************************************************************** ;;Copyright 1987 by Apollo Computer Inc., Chelmsford, Massachusetts. ;;Copyright 1989 by Hewlett-Packard Company. ;; ;; All Rights Reserved ;; ;;Permission to use, duplicate, change, and distribute this software and ;;its documentation for any purpose and without fee is granted, provided ;;that the above copyright notice appear in such copy and that this ;;copyright notice appear in all supporting documentation, and that the ;;names of Apollo Computer Inc., the Hewlett-Packard Company, or the X ;;Consortium not be used in advertising or publicity pertaining to ;;distribution of the software without written prior permission. ;; ;;HEWLETT-PACKARD MAKES NO WARRANTY OF ANY KIND WITH REGARD ;;TO THIS SOFWARE, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;;PURPOSE. Hewlett-Packard shall not be liable for errors ;;contained herein or direct, indirect, special, incidental or ;;consequential damages in connection with the furnishing, ;;performance, or use of this material. ;; ;;This software is not subject to any license of the American ;;Telephone and Telegraph Company or of the Regents of the ;;University of California. ;;******************************************************************/ (define-keysym :AP-LINE-DEL #x1000ff00) (define-keysym :AP-CHAR-DEL #x1000ff01) (define-keysym :AP-COPY #x1000ff02) (define-keysym :AP-CUT #x1000ff03) (define-keysym :AP-PASTE #x1000ff04) (define-keysym :AP-MOVE #x1000ff05) (define-keysym :AP-GROW #x1000ff06) (define-keysym :AP-CMD #x1000ff07) (define-keysym :AP-SHELL #x1000ff08) (define-keysym :AP-LEFT-BAR #x1000ff09) (define-keysym :AP-RIGHT-BAR #x1000ff0a) (define-keysym :AP-LEFT-BOX #x1000ff0b) (define-keysym :AP-RIGHT-BOX #x1000ff0c) (define-keysym :AP-UP-BOX #x1000ff0d) (define-keysym :AP-DOWN-BOX #x1000ff0e) (define-keysym :AP-POP #x1000ff0f) (define-keysym :AP-READ #x1000ff10) (define-keysym :AP-EDIT #x1000ff11) (define-keysym :AP-SAVE #x1000ff12) (define-keysym :AP-EXIT #x1000ff13) (define-keysym :AP-REPEAT #x1000ff14) (define-keysym :AP-KP-PARENLEFT #x1000ffa8) (define-keysym :AP-KP-PARENRIGHT #x1000ffa9) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/CLX/keysyms-common.lisp0000644000175000017500000001303310103174575023025 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-XCOMMON; -*- ;;; -------------------------------------------------------------------------------------- ;;; Title: X11 keysym handling ;;; Created: 2002-02-11 ;;; Author: Gilbert Baumann ;;; License: LGPL (See file COPYING for details). ;;; -------------------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Support and port mixin for X based backends, handling keycode to ;;; keysym and character mapping, and handling of modifiers. (in-package :clim-xcommon) (defvar *keysym-hash-table* (make-hash-table :test #'eql)) (defvar *reverse-keysym-hash-table* (make-hash-table :test #'eq)) (defun define-keysym (name value) (pushnew name (gethash value *keysym-hash-table* nil)) (setf (gethash name *reverse-keysym-hash-table*) value)) (defun lookup-keysym (value) (car (last (gethash value *keysym-hash-table*)))) (defun reverse-lookup-keysym (value) (gethash value *reverse-keysym-hash-table*)) (defclass keysym-port-mixin () ((modifier-cache :accessor modifier-cache :initform nil))) (defgeneric modifier-mapping (port) (:documentation "Returns an array of lists of keysym keywords for each of the X modifiers shift lock control mod1 mod2 mod3 mod4 mod5")) (defmethod modifier-mapping (port) (error "Define me!")) ;;; The X state is the state before the current event, so key events ;;; for the modifier keys don't reflect the state that results from ;;; pressing or releasing those keys. We want the CLIM modifiers to ;;; reflect the post event state. (defun x-keysym-to-clim-modifiers (port event-key keychar keysym-keyword state) "event-key is :key-press or :key-release" (multiple-value-bind (clim-modifiers shift-lock? caps-lock? mode-switch?) (x-event-state-modifiers port state) (declare (ignore shift-lock? caps-lock? mode-switch?)) (if (characterp keychar) clim-modifiers ;; ?? true? (modify-modifiers event-key keysym-keyword clim-modifiers)))) ;;; Modifier cache ;;; ;;; Cache word is cons of two integers, CLIM modifier word and other bits for ;;; shift-lock, etc. The defconstants below are for the other word. (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +shift-lock+ 1) (defconstant +caps-lock+ 2) (defconstant +mode-switch+ 4) ) (defconstant +clim-modifiers+ '(((:meta-left :meta-right) #.+meta-key+) ((:hyper-left :hyper-right) #.+hyper-key+) ((:super-left :super-right) #.+super-key+) ((:shift-left :shift-right) #.+shift-key+) ((:control-left :control-right) #.+control-key+))) (defconstant +other-modifiers+ '((:shift-lock #.+shift-lock+) (:caps-lock #.+caps-lock+) (:mode-switch #.+mode-switch+))) (defun make-modifier-cache (port) (let* ((modifiers (modifier-mapping port)) (modifier-byte-size (length modifiers)) (num-modifiers (ash 1 modifier-byte-size)) (cache (make-array num-modifiers))) (loop for x-modifier from 0 below num-modifiers for clim-modifier = 0 for other-modifier = 0 do (loop for bit from 0 below modifier-byte-size for bit-modifiers = (aref modifiers bit) when (logbitp bit x-modifier) do (progn (loop for (syms val) in +clim-modifiers+ when (intersection syms bit-modifiers) do (setf clim-modifier (logior clim-modifier val))) (loop for (sym val) in +other-modifiers+ when (member sym bit-modifiers) do (setf other-modifier (logior other-modifier val)))) finally (setf (aref cache x-modifier) (cons clim-modifier other-modifier)))) (setf (modifier-cache port) cache))) (defgeneric x-event-state-modifiers (port state) (:documentation "For the X STATE, returns as multiple values, the corresponding set of CLIM modifiers and flags for shift lock, caps lock, and mode switch.")) (defmethod x-event-state-modifiers ((port keysym-port-mixin) state) (with-accessors ((modifier-cache modifier-cache)) port (unless modifier-cache (setf modifier-cache (make-modifier-cache port))) (destructuring-bind (clim-modifiers . other-modifiers) ;; Mask off the button state bits. (aref modifier-cache (mod state (length modifier-cache))) (values clim-modifiers (logtest +shift-lock+ other-modifiers) (logtest +caps-lock+ other-modifiers) (logtest +mode-switch+ other-modifiers))))) (defun modify-modifiers (event-key keysym-keyword modifiers) (let ((keysym-modifier (loop for (keysyms modifier) in +clim-modifiers+ if (member keysym-keyword keysyms) return modifier))) (cond ((and keysym-modifier (eq event-key :key-press)) (logior modifiers keysym-modifier)) ((and keysym-modifier (eq event-key :key-release)) (logandc2 modifiers keysym-modifier)) (t modifiers)))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/CLX/keysyms.lisp0000644000175000017500000000777211345155772021563 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-CLX; -*- ;;; -------------------------------------------------------------------------------------- ;;; Title: X11 keysym handling ;;; Created: 2002-02-11 ;;; Author: Gilbert Baumann ;;; License: LGPL (See file COPYING for details). ;;; -------------------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-clx) (defun modifier-keycode->keysyms (display keycode) (let ((first-x-keysym (xlib:keycode->keysym display keycode 0))) (when (zerop first-x-keysym) (return-from modifier-keycode->keysyms nil)) (let ((second-x-keysym (xlib:keycode->keysym display keycode 1))) (cons (clim-xcommon:lookup-keysym first-x-keysym) (if (eql first-x-keysym second-x-keysym) nil (list (clim-xcommon:lookup-keysym second-x-keysym))))))) ;;; The X state is the state before the current event, so key events ;;; for the modifier keys don't reflect the state that results from ;;; pressing or releasing those keys. We want the CLIM modifiers to ;;; reflect the post event state. (defun x-event-to-key-name-and-modifiers (port event-key keycode state) (multiple-value-bind (clim-modifiers shift-lock? caps-lock? mode-switch?) (clim-xcommon:x-event-state-modifiers port state) ;; We filter away the shift state if there is a difference between ;; the shifted and unshifted keysym. This is so eg. #\A will not ;; look like "#\A with a Shift modifier", as this makes gesture ;; processing more difficult. (let* ((display (clx-port-display port)) (shift? (logtest +shift-key+ clim-modifiers)) (shift-modifier? (if shift-lock? (not shift?) (if caps-lock? t shift?))) (shifted-keysym (xlib:keycode->keysym display keycode (+ 1 (if mode-switch? 2 0)))) (unshifted-keysym (xlib:keycode->keysym display keycode (if mode-switch? 2 0))) (keysym (if shift-modifier? shifted-keysym unshifted-keysym))) (let* ((keysym-keyword (clim-xcommon:lookup-keysym keysym)) (char (xlib:keysym->character display keysym (+ (if shift-modifier? 1 0) (if mode-switch? 2 0)))) (modifiers (clim-xcommon:x-keysym-to-clim-modifiers port event-key char (clim-xcommon:lookup-keysym keysym) state))) (values char (if (= shifted-keysym unshifted-keysym) modifiers (logandc2 modifiers +shift-key+)) keysym-keyword))))) ;;;; (defun numeric-keysym-to-character (keysym) (and (<= 0 keysym 255) (code-char keysym))) (defun keysym-to-character (keysym) (numeric-keysym-to-character (clim-xcommon:reverse-lookup-keysym keysym))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/CLX/medium.lisp0000644000175000017500000017244111345155772021333 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-CLX -*- ;;; (c) copyright 1998,1999,2000,2001 by Michael McDonald (mikemac@mikemac.com) ;;; (c) copyright 2000 by ;;; Iban Hatchondo (hatchond@emi.u-bordeaux.fr) ;;; Julien Boninfante (boninfan@emi.u-bordeaux.fr) ;;; Robert Strandh (strandh@labri.u-bordeaux.fr) ;;; (c) copyright 2001 by Arnaud Rouanet (rouanet@emi.u-bordeaux.fr) ;;; (c) copyright 1998,1999 by Gilbert Baumann ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-clx) ;;; Needed changes: ;; The gc slot in clx-medium must be either thread local, or ;; [preferred] we should have a unified drawing options -> gcontext ;; cache. ;; --GB ;;; CLX-MEDIUM class (defclass clx-medium (basic-medium) ((gc :initform nil) (picture :initform nil) (last-medium-device-region :initform nil) (clipping-region-tmp :initform (vector 0 0 0 0) :documentation "This object is reused to avoid consing in the most common case when configuring the clipping region.") (buffer :initform nil :accessor medium-buffer))) #+CLX-EXT-RENDER (defun clx-medium-picture (clx-medium) (with-slots (picture) clx-medium (or picture (setf picture (xlib:render-create-picture (port-lookup-mirror (port clx-medium) (medium-sheet clx-medium))))))) ;;; secondary methods for changing text styles and line styles (defmethod (setf medium-text-style) :before (text-style (medium clx-medium)) (with-slots (gc) medium (when gc (let ((old-text-style (medium-text-style medium))) (unless (eq text-style old-text-style) (setf (xlib:gcontext-font gc) (text-style-to-X-font (port medium) (medium-text-style medium)))))))) ;;; Translate from CLIM styles to CLX styles. (defconstant +cap-shape-map+ '((:butt . :butt) (:square . :projecting) (:round . :round) (:no-end-point . :not-last))) (defun translate-cap-shape (clim-shape) (let ((clx-shape (cdr (assoc clim-shape +cap-shape-map+)))) (if clx-shape clx-shape (progn (warn "Unknown cap style ~S, using :round" clim-shape) :round)))) (defmethod (setf medium-line-style) :before (line-style (medium clx-medium)) (with-slots (gc) medium (when gc (let ((old-line-style (medium-line-style medium))) (unless (eql (line-style-thickness line-style) (line-style-thickness old-line-style)) ;; this is kind of false, since the :unit should be taken ;; into account -RS 2001-08-24 (setf (xlib:gcontext-line-width gc) (round (line-style-thickness line-style)))) (unless (eq (line-style-cap-shape line-style) (line-style-cap-shape old-line-style)) (setf (xlib:gcontext-cap-style gc) (translate-cap-shape (line-style-cap-shape line-style)))) (unless (eq (line-style-joint-shape line-style) (line-style-joint-shape old-line-style)) (setf (xlib:gcontext-join-style gc) (line-style-joint-shape line-style))) ;; we could do better here by comparing elements of the vector ;; -RS 2001-08-24 (unless (eq (line-style-dashes line-style) (line-style-dashes old-line-style)) (setf (xlib:gcontext-line-style gc) (if (line-style-dashes line-style) :dash :solid) (xlib:gcontext-dashes gc) (case (line-style-dashes line-style) ((t nil) 3) (otherwise (line-style-dashes line-style))))))))) (defun %set-gc-clipping-region (medium gc) (declare (type clx-medium medium)) (let ((clipping-region (medium-device-region medium)) (tmp (slot-value medium 'clipping-region-tmp)) (port (port medium))) (cond ((region-equal clipping-region +nowhere+) (setf (xlib:gcontext-clip-mask gc) #())) ((typep clipping-region 'standard-rectangle) (multiple-value-bind (x1 y1 width height) (region->clipping-values clipping-region) (setf (aref tmp 0) x1 (aref tmp 1) y1 (aref tmp 2) width (aref tmp 3) height (xlib:gcontext-clip-mask gc :unsorted) tmp))) (t (let ((rect-seq (clipping-region->rect-seq clipping-region))) (when rect-seq #+nil ;; ok, what McCLIM is generating is not :yx-banded... ;; (currently at least) (setf (xlib:gcontext-clip-mask gc :yx-banded) rect-seq) #-nil ;; the region code doesn't support yx-banding... ;; or does it? what does y-banding mean in this implementation? ;; well, apparantly it doesn't mean what y-sorted means ;; to clx :] we stick with :unsorted until that can be sorted out (setf (xlib:gcontext-clip-mask gc :unsorted) rect-seq))))))) (defgeneric medium-gcontext (medium ink)) (defmethod medium-gcontext :before ((medium clx-medium) ink) (let* ((port (port medium)) (mirror (port-lookup-mirror port (medium-sheet medium)))) (with-slots (gc) medium (unless gc (setq gc (xlib:create-gcontext :drawable mirror)) (and gc (setf (xlib:gcontext-fill-style gc) :solid)))))) (defmethod medium-gcontext ((medium clx-medium) (ink color)) (declare (optimize (debug 3))) (let* ((port (port medium)) (mirror (port-lookup-mirror port (medium-sheet medium))) (line-style (medium-line-style medium))) (with-slots (gc last-medium-device-region) medium (unless gc (setq gc (xlib:create-gcontext :drawable mirror)) ;; this is kind of false, since the :unit should be taken ;; into account -RS 2001-08-24 (setf (xlib:gcontext-line-width gc) (line-style-thickness line-style) (xlib:gcontext-cap-style gc) (translate-cap-shape (line-style-cap-shape line-style)) (xlib:gcontext-join-style gc) (line-style-joint-shape line-style)) (let ((dashes (line-style-dashes line-style))) (unless (null dashes) (setf (xlib:gcontext-line-style gc) :dash (xlib:gcontext-dashes gc) (if (eq dashes t) 3 dashes))))) (setf (xlib:gcontext-function gc) boole-1) (setf (xlib:gcontext-foreground gc) (X-pixel port ink) (xlib:gcontext-background gc) (X-pixel port (medium-background medium))) (let ((fn (text-style-to-X-font port (medium-text-style medium)))) (when (typep fn 'xlib:font) (setf (xlib:gcontext-font gc) fn))) (unless (eq last-medium-device-region (medium-device-region medium)) (setf last-medium-device-region (medium-device-region medium)) (%set-gc-clipping-region medium gc)) gc))) (defmethod medium-gcontext ((medium clx-medium) (ink (eql +transparent-ink+))) (let ((drawable (port-lookup-mirror (port medium) (medium-sheet medium)))) (with-slots (gc) medium (or gc (setf gc (xlib:create-gcontext :drawable drawable)))))) (defmethod medium-gcontext ((medium clx-medium) (ink (eql +foreground-ink+))) (medium-gcontext medium (medium-foreground medium))) (defmethod medium-gcontext ((medium clx-medium) (ink (eql +background-ink+))) (medium-gcontext medium (medium-background medium))) (defmethod medium-gcontext ((medium clx-medium) (ink (eql +flipping-ink+))) (let* ((gc (medium-gcontext medium (medium-background medium))) (port (port medium)) (flipper (logxor (X-pixel port (medium-foreground medium)) (X-pixel port (medium-background medium))))) ;; Now, (logxor flipper foreground) => background ;; (logxor flipper background) => foreground (setf (xlib:gcontext-function gc) boole-xor) (setf (xlib:gcontext-foreground gc) flipper) (setf (xlib:gcontext-background gc) flipper) gc)) ;;; From Tagore Smith (defmethod medium-gcontext ((medium clx-medium) (ink climi::standard-flipping-ink)) (let* ((gc (medium-gcontext medium (medium-background medium))) (port (port medium)) (color1 (slot-value ink 'climi::design1)) (color2 (slot-value ink 'climi::design2)) (flipper (logxor (X-pixel port color1) (X-pixel port color2)))) (setf (xlib:gcontext-function gc) boole-xor) (setf (xlib:gcontext-foreground gc) flipper) (setf (xlib:gcontext-background gc) flipper) gc)) (defmethod medium-gcontext ((medium clx-medium) (ink climi::indexed-pattern)) (design-gcontext medium ink)) (defmethod medium-gcontext ((medium clx-medium) (ink climi::rectangular-tile)) (design-gcontext medium ink)) ;;;; (defmethod design-gcontext :around ((medium clx-medium) (ink climi::indexed-pattern)) (let ((design-cache (slot-value (port medium) 'design-cache))) (let ((cached (gethash ink design-cache))) (or cached (setf (gethash ink design-cache) (call-next-method)))))) (defun st3 (x y z) (values (logand (truncate (* x 255)) 255) (logand (truncate (* y 255)) 255) (logand (truncate (* z 255)) 255))) (declaim (ftype (function (sequence) (values (simple-array (unsigned-byte 8) 1) (simple-array (unsigned-byte 8) 1) (simple-array (unsigned-byte 8) 1) (simple-array (unsigned-byte 8) 1))) inks-to-rgb)) (defun inks-to-rgb (inks) "Returns four values: byte arrays for the red, green, blue, and opacity components [0,255] of a sequence of inks" (let ((red-map (make-array (length inks) :element-type '(unsigned-byte 8) :initial-element 255)) (green-map (make-array (length inks) :element-type '(unsigned-byte 8) :initial-element 0)) (blue-map (make-array (length inks) :element-type '(unsigned-byte 8) :initial-element 255)) (opacity-map (make-array (length inks) :element-type '(unsigned-byte 8) :initial-element 255)) (length (length inks))) (loop for index from 0 below length as ink = (elt inks index) do (flet ((transform (parameter) (logand (truncate (* parameter 255)) 255))) (cond ((colorp ink) (multiple-value-bind (r g b) (color-rgb ink) (setf (elt red-map index) (transform r) (elt green-map index) (transform g) (elt blue-map index) (transform b) (elt opacity-map index) 255))) ((eq ink +transparent-ink+) (setf (elt opacity-map index) 0))))) (values red-map green-map blue-map opacity-map))) (defun integer-count-bits (integer) (loop for i from 0 below (integer-length integer) sum (ldb (byte 1 i) integer))) (defun compute-channel-fields (mask num-bytes) (loop with counted-bits = 0 with output-width = (integer-count-bits mask) for index from (1- num-bytes) downto 0 as submask = (ldb (byte 8 (* 8 index)) mask) as submask-bits = (integer-count-bits submask) as output-shift-left = (- (integer-length submask) submask-bits) as input-position = (+ (- 8 counted-bits submask-bits)) collect (if (zerop submask) nil (prog1 (list output-shift-left submask-bits input-position) (assert (<= output-width 8)) (incf counted-bits submask-bits))))) (defun compute-channel-expressions (channel-mask-specs num-bytes) (labels ((single-channel-expressions (mask channel-name) (mapcar (lambda (fieldspec) (and fieldspec (destructuring-bind (output-shift-left submask-bits input-position) fieldspec `(ash (ldb (byte ,submask-bits ,input-position) ,channel-name) ,output-shift-left)))) (compute-channel-fields mask num-bytes) ))) (reduce (lambda (left-exprs right-exprs) (mapcar (lambda (left-expr right-expr) (if right-expr (cons right-expr left-expr) left-expr)) left-exprs right-exprs)) channel-mask-specs :key (lambda (channel-mask-spec) (destructuring-bind (var-name mask) channel-mask-spec (single-channel-expressions mask var-name))) :initial-value (map 'list #'identity (make-array num-bytes :initial-element nil))))) (defun generate-pixel-assignments (array-var index-var channel-mask-specs num-bytes byte-order) `(setf ,@(mapcan (lambda (byte-exprs byte-index) (and byte-exprs (list `(elt ,array-var (+ ,index-var ,byte-index)) (if (= 1 (length byte-exprs)) (first byte-exprs) `(logior ,@byte-exprs))))) (compute-channel-expressions channel-mask-specs num-bytes) (funcall (ecase byte-order (:lsbfirst #'reverse) (:msbfirst #'identity)) (loop for i from 0 below num-bytes collect i))))) (defun generate-indexed-converter-expr (rgb-masks byte-order num-bytes) `(lambda (image-array converted-data mask-data width height inks) (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)) (type xlib:card16 width height) (type (simple-array xlib:card8 1) converted-data mask-data)) (macrolet ((conversion-body () `(let ((index 0) (mask-index 0) (mask-bitcursor 1)) (declare (type (unsigned-byte 9) mask-bitcursor) (type xlib:array-index mask-index index)) (multiple-value-bind (red-map green-map blue-map opacity-map) (inks-to-rgb inks) (dotimes (y height) (unless (= 1 mask-bitcursor) (setf mask-bitcursor 1 mask-index (1+ mask-index))) (dotimes (x width) (let ((ink-index (aref image-array y x))) (when (< (elt opacity-map ink-index) #x40) ; FIXME? Arbitrary threshold. (setf (elt mask-data mask-index) (logxor (elt mask-data mask-index) mask-bitcursor))) #+NIL (setf (elt converted-data (+ index 0)) (elt blue-map ink-index) (elt converted-data (+ index 1)) (elt green-map ink-index) (elt converted-data (+ index 2)) (elt red-map ink-index)) (let ((red (elt red-map ink-index)) (green (elt green-map ink-index)) (blue (elt blue-map ink-index))) ,',(generate-pixel-assignments 'converted-data 'index (mapcar #'list '(red green blue) rgb-masks) num-bytes byte-order)) (setf index (+ ,',num-bytes index) mask-bitcursor (ash mask-bitcursor 1) mask-index (+ mask-index (ash mask-bitcursor -8)) mask-bitcursor (logand (logior mask-bitcursor (ash mask-bitcursor -8)) #xff))))))))) ;; We win big if we produce several specialized versions of this according ;; to the type of array holding the color indexes. (typecase image-array ((simple-array xlib:card8 2) ; 256-color images (locally (declare (type (simple-array xlib:card8 2) image-array)) (conversion-body))) ((simple-array fixnum 2) ; High-color index images (XPM reader produces these..) (locally (declare (type (simple-array fixnum 2) image-array)) (conversion-body))) (t (conversion-body)))))) (defun convert-indexed->mask (image-array mask-data width height inks) (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)) (type xlib:card16 width height) (type (simple-array xlib:card8 1) mask-data)) (macrolet ((conversion-body () '(let ((mask-index 0) (mask-bitcursor 1)) (declare (type (unsigned-byte 9) mask-bitcursor) (type xlib:array-index mask-index)) (multiple-value-bind (red-map green-map blue-map opacity-map) (inks-to-rgb inks) (declare (ignore red-map green-map blue-map)) (dotimes (y height) (unless (= 1 mask-bitcursor) (setf mask-bitcursor 1 mask-index (1+ mask-index))) (dotimes (x width) (let ((ink-index (aref image-array y x))) (when (< (elt opacity-map ink-index) #x40) ; FIXME? Arbitrary threshold. (setf (elt mask-data mask-index) (logxor (elt mask-data mask-index) mask-bitcursor))) (setf mask-bitcursor (ash mask-bitcursor 1) mask-index (+ mask-index (ash mask-bitcursor -8)) mask-bitcursor (logand (logior mask-bitcursor (ash mask-bitcursor -8)) #xff))))))))) ;; Again, we win big if we produce several specialized versions of this. (typecase image-array ((simple-array xlib:card8 2) ; 256-color images (locally (declare (type (simple-array xlib:card8 2) image-array)) (conversion-body))) ((simple-array fixnum 2) ; High-color index images (XPM reader produces these..) (locally (declare (type (simple-array fixnum 2) image-array)) (conversion-body))) (t (conversion-body))))) (defparameter *pixel-converter-cache* (make-hash-table :test 'equal)) (defun ensure-indexed-converter (rgb-masks byte-order bytes-per-pixel) (let ((key (list rgb-masks byte-order bytes-per-pixel))) (symbol-macrolet ((fn (gethash key *pixel-converter-cache*))) (or fn (setf fn (compile nil (generate-indexed-converter-expr rgb-masks byte-order bytes-per-pixel))))))) (defun visual-get-indexed-converter (visual-info byte-order bytes-per-pixel) (let ((rgb-masks (list (xlib:visual-info-red-mask visual-info) (xlib:visual-info-green-mask visual-info) (xlib:visual-info-blue-mask visual-info)))) (ensure-indexed-converter rgb-masks byte-order bytes-per-pixel))) (defparameter *typical-pixel-formats* '(((#xFF0000 #xFF00 #xFF) :LSBFIRST 4) ((#xFF0000 #xFF00 #xFF) :MSBFIRST 4)) "This is a table of the most likely pixel formats. Converters for these should be compiled in advance. Compiling the indexed->rgba converter in advance will eliminate the pause observable the first time an indexed pattern is drawn.") (dolist (format *typical-pixel-formats*) (apply 'ensure-indexed-converter format)) (defun fill-pixmap-indexed (visual-info depth byte-order array pm pm-gc mask mask-gc w h inks) (assert (= (array-total-size array) (* w h))) (let* ((ceil-w-8 (ceiling w 8)) (bytes-per-pixel (case depth ((24 32) 4) ((15 16) 2) (otherwise nil))) (mask-data (make-array (* ceil-w-8 h) :element-type '(unsigned-byte 8) :initial-element #xff)) (pixel-converter nil)) (if (and bytes-per-pixel (member byte-order '(:lsbfirst :msbfirst)) (setf pixel-converter (visual-get-indexed-converter visual-info byte-order bytes-per-pixel))) ;; Fast path - Image upload (let ((converted-data (make-array (* bytes-per-pixel (array-total-size array)) :element-type 'xlib:card8))) ;; Fill the pixel arrays (funcall pixel-converter array converted-data mask-data w h inks) ;; Create an xlib "image" and copy it to our pixmap. ;; I do this because I'm not smart enough to operate xlib:put-raw-image. (let ((image (xlib:create-image :bits-per-pixel (* 8 bytes-per-pixel) :depth depth :width w :height h :format :z-pixmap :data converted-data))) (xlib:put-image (pixmap-mirror pm) pm-gc image :x 0 :y 0 :width w :height h))) ;; Fallback for unsupported visual, plotting pixels (progn (dotimes (y h) (dotimes (x w) (let ((ink (elt inks (aref array y x)))) (unless (eq ink +transparent-ink+) (draw-point* pm x y :ink ink))))) (convert-indexed->mask array mask-data w h inks))) ;; We can use image upload for the mask in either case. (let ((mask-image (xlib:create-image :bits-per-pixel 1 :depth 1 :bit-lsb-first-p t :byte-lsb-first-p t :width w :height h :data mask-data))) (xlib:put-image mask mask-gc mask-image :x 0 :y 0 :width w :height h)))) (defmethod design-gcontext ((medium clx-medium) (ink climi::indexed-pattern)) (let* ((array (slot-value ink 'climi::array)) (inks (map 'vector (lambda (ink) (cond ((eql ink +foreground-ink+) (medium-foreground medium)) ((eql ink +background-ink+) (medium-background medium)) ((eql ink +flipping-ink+) (error "Flipping ink within patterns is not supported.")) (t ink))) (slot-value ink 'climi::designs))) (w (array-dimension array 1)) (h (array-dimension array 0))) (assert (not (zerop w))) (assert (not (zerop h))) ;; Establish color and mask pixmaps (let* ((display (clx-port-display (port medium))) (screen (clx-port-screen (port medium))) (drawable (port-lookup-mirror (port medium) (medium-sheet medium))) (pm (allocate-pixmap (first (port-grafts (port medium))) w h)) (mask (xlib:create-pixmap :drawable drawable #+NIL (port-lookup-mirror (port medium) (first (port-grafts (port medium)))) :depth 1 :width w :height h)) (pm-gc (xlib:create-gcontext :drawable (pixmap-mirror pm))) (mask-gc (xlib:create-gcontext :drawable mask :foreground 1))) (xlib:draw-rectangle mask mask-gc 0 0 w h t) (setf (xlib:gcontext-foreground mask-gc) 0) (let ((gc (xlib:create-gcontext :drawable drawable))) (setf (xlib:gcontext-fill-style gc) :tiled (xlib:gcontext-tile gc) (port-lookup-mirror (port pm) pm) (xlib:gcontext-clip-x gc) 0 (xlib:gcontext-clip-y gc) 0 (xlib:gcontext-ts-x gc) 0 (xlib:gcontext-ts-y gc) 0 (xlib:gcontext-clip-mask gc) mask) (let ((byte-order (xlib:display-byte-order display)) ;; Hmm. Pixmaps are not windows, so you can't query their visual. ;; We'd like to draw to pixmaps as well as windows, so use the ;; depth and visual of the screen root, and hope this works. ;(visual-info (xlib:window-visual-info drawable)) (visual-info (xlib:visual-info display (xlib:screen-root-visual screen))) (depth (xlib:screen-root-depth screen)) (*print-base* 16)) (fill-pixmap-indexed visual-info depth byte-order array pm pm-gc mask mask-gc w h inks)) (xlib:free-gcontext mask-gc) (xlib:free-gcontext pm-gc) gc)))) (defmethod design-gcontext ((medium clx-medium) (ink climi::rectangular-tile)) (let* ((design (slot-value ink 'climi::design)) (w (slot-value ink 'climi::width)) (h (slot-value ink 'climi::height))) (let ((pm (allocate-pixmap (first (port-grafts (port medium))) w h))) ;dito (draw-rectangle* pm 0 0 w h :ink design) (let ((gc (xlib:create-gcontext :drawable (port-lookup-mirror (port medium) (medium-sheet medium))))) (setf (xlib:gcontext-fill-style gc) :tiled (xlib:gcontext-tile gc) (port-lookup-mirror (port pm) pm) (xlib:gcontext-clip-x gc) 0 (xlib:gcontext-clip-y gc) 0 (xlib:gcontext-ts-x gc) 0 (xlib:gcontext-ts-y gc) 0) gc)))) (defmethod medium-gcontext ((medium clx-medium) (ink climi::transformed-design)) (let ((transformation (climi::transformed-design-transformation ink)) (design (climi::transformed-design-design ink))) (unless (translation-transformation-p transformation) (error "Sorry, not yet implemented.")) ;; Bah! (typecase design ((or climi::indexed-pattern climi::rectangular-tile) (multiple-value-bind (tx ty) (transform-position transformation 0 0) (let ((gc-x (round-coordinate tx)) (gc-y (round-coordinate ty)) (gc (design-gcontext medium design))) (setf (xlib:gcontext-ts-x gc) gc-x (xlib:gcontext-ts-y gc) gc-y (xlib:gcontext-clip-x gc) gc-x (xlib:gcontext-clip-y gc) gc-y) gc))) (t (error "You lost, we not yet implemented transforming an ~S." (type-of ink)))))) ;;;; #+nil (defun clipping-region->rect-seq (clipping-region) (loop for region in (nreverse (region-set-regions clipping-region :normalize :x-banding)) as rectangle = (bounding-rectangle region) nconcing (list (round (rectangle-min-x rectangle)) (round (rectangle-min-y rectangle)) (round (rectangle-width rectangle)) (round (rectangle-height rectangle))))) (defun region->clipping-values (region) (with-bounding-rectangle* (min-x min-y max-x max-y) region (let ((clip-x (round-coordinate min-x)) (clip-y (round-coordinate min-y))) (values clip-x clip-y (- (round-coordinate max-x) clip-x) (- (round-coordinate max-y) clip-y))))) ; this seems to work, but find out why all of these +nowhere+s are coming from ; and kill them at the source... #-nil (defun clipping-region->rect-seq (clipping-region) (typecase clipping-region (area (multiple-value-list (region->clipping-values clipping-region))) (t (loop for region in (nreverse (mapcan (lambda (v) (unless (eq v +nowhere+) (list v))) (region-set-regions clipping-region :normalize :y-banding))) nconcing (multiple-value-list (region->clipping-values region)))))) (defmacro with-clx-graphics ((medium) &body body) `(let* ((port (port ,medium)) (mirror (or (medium-buffer ,medium) (port-lookup-mirror port (medium-sheet ,medium))))) (when mirror (let* ((line-style (medium-line-style ,medium)) (ink (medium-ink ,medium)) (gc (medium-gcontext ,medium ink))) line-style ink (unwind-protect (unless (eql ink +transparent-ink+) (progn ,@body)) #+ignore(xlib:free-gcontext gc)))))) ;;; Pixmaps ;;; width and height arguments should be integers, but we'll leave the calls ;;; to round in for now. (defmethod medium-copy-area ((from-drawable clx-medium) from-x from-y width height (to-drawable clx-medium) to-x to-y) (with-transformed-position ((sheet-native-transformation (medium-sheet from-drawable)) from-x from-y) (with-transformed-position ((sheet-native-transformation (medium-sheet to-drawable)) to-x to-y) (multiple-value-bind (width height) (transform-distance (medium-transformation from-drawable) width height) (xlib:copy-area (sheet-direct-mirror (medium-sheet from-drawable)) (medium-gcontext from-drawable +background-ink+) (round-coordinate from-x) (round-coordinate from-y) (round width) (round height) (or (medium-buffer to-drawable) (sheet-direct-mirror (medium-sheet to-drawable))) (round-coordinate to-x) (round-coordinate to-y)))))) (defmethod medium-copy-area ((from-drawable clx-medium) from-x from-y width height (to-drawable pixmap) to-x to-y) (with-transformed-position ((sheet-native-transformation (medium-sheet from-drawable)) from-x from-y) (xlib:copy-area (sheet-direct-mirror (medium-sheet from-drawable)) (medium-gcontext from-drawable +background-ink+) (round-coordinate from-x) (round-coordinate from-y) (round width) (round height) (pixmap-mirror to-drawable) (round-coordinate to-x) (round-coordinate to-y)))) (defmethod medium-copy-area ((from-drawable pixmap) from-x from-y width height (to-drawable clx-medium) to-x to-y) (with-transformed-position ((sheet-native-transformation (medium-sheet to-drawable)) to-x to-y) (xlib:copy-area (pixmap-mirror from-drawable) (medium-gcontext to-drawable +background-ink+) (round-coordinate from-x) (round-coordinate from-y) (round width) (round height) (or (medium-buffer to-drawable) (sheet-direct-mirror (medium-sheet to-drawable))) (round-coordinate to-x) (round-coordinate to-y)))) (defmethod medium-copy-area ((from-drawable pixmap) from-x from-y width height (to-drawable pixmap) to-x to-y) (xlib:copy-area (pixmap-mirror from-drawable) (medium-gcontext (sheet-medium (slot-value to-drawable 'sheet)) +background-ink+) (round-coordinate from-x) (round-coordinate from-y) (round width) (round height) (pixmap-mirror to-drawable) (round-coordinate to-x) (round-coordinate to-y))) ;;; Medium-specific Drawing Functions (defmethod medium-draw-point* ((medium clx-medium) x y) (with-transformed-position ((sheet-native-transformation (medium-sheet medium)) x y) (with-clx-graphics (medium) (cond ((< (line-style-thickness line-style) 2) (let ((x (round-coordinate x)) (y (round-coordinate y))) (when (and (typep x '(signed-byte 16)) (typep y '(signed-byte 16))) (xlib:draw-point mirror gc x y)))) (t (let* ((radius (/ (line-style-thickness line-style) 2)) (min-x (round-coordinate (- x radius))) (min-y (round-coordinate (- y radius))) (max-x (round-coordinate (+ x radius))) (max-y (round-coordinate (+ y radius)))) (when (and (typep min-x '(signed-byte 16)) (typep min-y '(signed-byte 16))) (xlib:draw-arc mirror gc min-x min-y (- max-x min-x) (- max-y min-y) 0 (* 2 pi) t)))))))) (defmethod medium-draw-points* ((medium clx-medium) coord-seq) (with-transformed-positions ((sheet-native-transformation (medium-sheet medium)) coord-seq) (with-clx-graphics (medium) (cond ((< (line-style-thickness line-style) 2) (do-sequence ((x y) coord-seq) (let ((x (round-coordinate x)) (y (round-coordinate y))) (when (and (typep x '(signed-byte 16)) (typep y '(signed-byte 16))) (xlib:draw-point mirror gc x y))))) (t (let ((radius (/ (line-style-thickness line-style) 2))) (do-sequence ((x y) coord-seq) (let ((min-x (round-coordinate (- x radius))) (min-y (round-coordinate (- y radius))) (max-x (round-coordinate (+ x radius))) (max-y (round-coordinate (+ y radius)))) (when (and (typep min-x '(signed-byte 16)) (typep min-y '(signed-byte 16))) (xlib:draw-arc mirror gc min-x min-y (- max-x min-x) (- max-y min-y) 0 (* 2 pi) t)))))))))) (defmethod medium-draw-line* ((medium clx-medium) x1 y1 x2 y2) (let ((tr (sheet-native-transformation (medium-sheet medium)))) (with-transformed-position (tr x1 y1) (with-transformed-position (tr x2 y2) (with-clx-graphics (medium) (let ((x1 (round-coordinate x1)) (y1 (round-coordinate y1)) (x2 (round-coordinate x2)) (y2 (round-coordinate y2))) (cond ((and (<= #x-8000 x1 #x7FFF) (<= #x-8000 y1 #x7FFF) (<= #x-8000 x2 #x7FFF) (<= #x-8000 y2 #x7FFF)) (xlib:draw-line mirror gc x1 y1 x2 y2)) (t (let ((line (region-intersection (make-rectangle* #x-8000 #x-8000 #x7FFF #x7FFF) (make-line* x1 y1 x2 y2)))) (when (linep line) (multiple-value-bind (x1 y1) (line-start-point* line) (multiple-value-bind (x2 y2) (line-end-point* line) (xlib:draw-line mirror gc (min #x7FFF (max #x-8000 (round-coordinate x1))) (min #x7FFF (max #x-8000 (round-coordinate y1))) (min #x7FFF (max #x-8000 (round-coordinate x2))) (min #x7FFF (max #x-8000 (round-coordinate y2)))))))))))))))) ;; Invert the transformation and apply it here, as the :around methods on ;; transform-coordinates-mixin will cause it to be applied twice, and we ;; need to undo one of those. The transform-coordinates-mixin stuff needs ;; to be eliminated. (defmethod medium-draw-lines* ((medium clx-medium) coord-seq) (let ((tr (invert-transformation (medium-transformation medium)))) (with-transformed-positions (tr coord-seq) (do-sequence ((x1 y1 x2 y2) coord-seq) (medium-draw-line* medium x1 y1 x2 y2))))) (defmethod medium-draw-polygon* ((medium clx-medium) coord-seq closed filled) ;; TODO: ;; . cons less ;; . clip (assert (evenp (length coord-seq))) (with-transformed-positions ((sheet-native-transformation (medium-sheet medium)) coord-seq) (setq coord-seq (map 'vector #'round-coordinate coord-seq)) (with-clx-graphics (medium) (xlib:draw-lines mirror gc (if closed (concatenate 'vector coord-seq (vector (elt coord-seq 0) (elt coord-seq 1))) coord-seq) :fill-p filled)))) (defmethod medium-draw-rectangle* ((medium clx-medium) left top right bottom filled) (medium-draw-rectangle-using-ink* medium (medium-ink medium) left top right bottom filled)) (defmethod medium-draw-rectangle-using-ink* ((medium clx-medium) (ink t) left top right bottom filled) (let ((tr (sheet-native-transformation (medium-sheet medium)))) (with-transformed-position (tr left top) (with-transformed-position (tr right bottom) (with-clx-graphics (medium) (if (< right left) (rotatef left right)) (if (< bottom top) (rotatef top bottom)) (let ((left (round-coordinate left)) (top (round-coordinate top)) (right (round-coordinate right)) (bottom (round-coordinate bottom))) ;; To clip rectangles, we just need to clamp the ;; coordinates (xlib:draw-rectangle mirror gc (max #x-8000 (min #x7FFF left)) (max #x-8000 (min #x7FFF top)) (max 0 (min #xFFFF (- right left))) (max 0 (min #xFFFF (- bottom top))) filled))))))) #+CLX-EXT-RENDER (defmethod medium-draw-rectangle-using-ink* ((medium clx-medium) (ink climi::uniform-compositum) x1 y1 x2 y2 filled) (let ((tr (sheet-native-transformation (medium-sheet medium))) (port (port medium))) (with-transformed-position (tr x1 y1) (with-transformed-position (tr x2 y2) (let ((x1 (round-coordinate x1)) (y1 (round-coordinate y1)) (x2 (round-coordinate x2)) (y2 (round-coordinate y2))) (multiple-value-bind (r g b) (color-rgb (slot-value ink 'climi::ink)) (let ((a (opacity-value (slot-value ink 'climi::mask)))) ;; Hmm, XRender uses pre-multiplied alpha, how useful! (setf r (min #xffff (max 0 (round (* #xffff a r)))) g (min #xffff (max 0 (round (* #xffff a g)))) b (min #xffff (max 0 (round (* #xffff a b)))) a (min #xffff (max 0 (round (* #xffff a))))) (let ((picture (clx-medium-picture medium))) (xlib:render-fill-rectangle picture :over (list r g b a) (max #x-8000 (min #x7FFF x1)) (max #x-8000 (min #x7FFF y1)) (max 0 (min #xFFFF (- x2 x1))) (max 0 (min #xFFFF (- y2 y1)))))))))))) (defmethod medium-draw-rectangles* ((medium clx-medium) position-seq filled) (assert (evenp (length position-seq))) (with-transformed-positions ((sheet-native-transformation (medium-sheet medium)) position-seq) (with-clx-graphics (medium) (loop for (left top right bottom) on position-seq by #'cddddr for min-x = (round-coordinate left) for max-x = (round-coordinate right) for min-y = (round-coordinate top) for max-y = (round-coordinate bottom) nconcing (list min-x min-y (- max-x min-x) (- min-y max-y)) into points finally (xlib:draw-rectangles mirror gc points filled))))) ;;; Round the parameters of the ellipse so that it occupies the expected pixels (defmethod medium-draw-ellipse* ((medium clx-medium) center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy start-angle end-angle filled) (unless (or (= radius-2-dx radius-1-dy 0) (= radius-1-dx radius-2-dy 0)) (error "MEDIUM-DRAW-ELLIPSE* not yet implemented for non axis-aligned ellipses.")) (with-transformed-position ((sheet-native-transformation (medium-sheet medium)) center-x center-y) (let* ((arc-angle (- end-angle start-angle)) (arc-angle (if (< arc-angle 0) (+ (* pi 2) arc-angle) arc-angle))) (with-clx-graphics (medium) (let* ((radius-dx (abs (+ radius-1-dx radius-2-dx))) (radius-dy (abs (+ radius-1-dy radius-2-dy))) (min-x (round-coordinate (- center-x radius-dx))) (min-y (round-coordinate (- center-y radius-dy))) (max-x (round-coordinate (+ center-x radius-dx))) (max-y (round-coordinate (+ center-y radius-dy)))) #+nil (when (typep mirror 'xlib:pixmap) (break)) (xlib:draw-arc mirror gc min-x min-y (- max-x min-x) (- max-y min-y) (mod start-angle (* 2 pi)) arc-angle filled)))))) (defmethod medium-draw-circle* ((medium clx-medium) center-x center-y radius start-angle end-angle filled) (with-transformed-position ((sheet-native-transformation (medium-sheet medium)) center-x center-y) (let* ((arc-angle (- end-angle start-angle)) (arc-angle (if (< arc-angle 0) (+ (* pi 2) arc-angle) arc-angle)) (min-x (round-coordinate (- center-x radius))) (min-y (round-coordinate (- center-y radius))) (max-x (round-coordinate (+ center-x radius))) (max-y (round-coordinate (+ center-y radius)))) (with-clx-graphics (medium) (xlib:draw-arc mirror gc min-x min-y (- max-x min-x) (- min-y max-y) start-angle arc-angle filled))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Methods for text styles (defmethod text-style-ascent (text-style (medium clx-medium)) (let ((font (text-style-to-X-font (port medium) text-style))) (xlib:font-ascent font))) (defmethod text-style-descent (text-style (medium clx-medium)) (let ((font (text-style-to-X-font (port medium) text-style))) (xlib:font-descent font))) (defmethod text-style-height (text-style (medium clx-medium)) (let ((font (text-style-to-X-font (port medium) text-style))) (+ (xlib:font-ascent font) (xlib:font-descent font)))) (defmethod text-style-character-width (text-style (medium clx-medium) char) (xlib:char-width (text-style-to-X-font (port medium) text-style) (char-code char))) (defmethod text-style-width (text-style (medium clx-medium)) (text-style-character-width text-style medium #\m)) (eval-when (:compile-toplevel :execute) ;; ASCII / CHAR-CODE compatibility checking (unless (equal (mapcar #'char-code '(#\Backspace #\Tab #\Linefeed #\Page #\Return #\Rubout)) '(8 9 10 12 13 127)) (error "~S not ASCII-compatible for semi-standard characters: ~ implement a CLX translate function for this implementation." 'code-char)) (let ((standard-chars " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~")) (dotimes (i 95) (unless (eql (char standard-chars i) (code-char (+ i 32))) (error "~S not ASCII-compatible for standard character ~S: ~ implement a CLX translate function for this implementation." 'code-char (code-char (+ i 32))))))) ;;; The default CLX translation function is defined to work only for ;;; ASCII characters; quoting from the documentation, ;;; ;;; The default :translate function handles all characters that ;;; satisfy graphic-char-p by converting each character into its ;;; ASCII code. ;;; ;;; We provide our own translation function which is essentially the ;;; same as that of CLX, but with the ASCII restriction relaxed. This ;;; is by no means a proper solution to the problem of ;;; internationalization, because fonts tend not to have a complete ;;; coverage of the entirety of the Unicode space, even assuming that ;;; the underlying lisp supports it (this is the case at least for SBCL, ;;; CLISP and CCL); instead, the translation function is meant to ;;; handle font sets by requesting the X server change fonts in the ;;; middle of rendering strings. However, the below stands a chance ;;; of working when using ISO-8859-1-encoded fonts, and will tend to ;;; lose in other cases. (defun translate (src src-start src-end afont dst dst-start) (declare (type sequence src) (type xlib:array-index src-start src-end dst-start) (type (or null xlib:font) afont) (type vector dst)) ;; FIXME: what if AFONT is null? (let ((min-char-index (xlib:font-min-char afont)) (max-char-index (xlib:font-max-char afont))) (if (stringp src) (do ((i src-start (xlib::index+ i 1)) (j dst-start (xlib::index+ j 1)) (char)) ((xlib::index>= i src-end) i) (declare (type xlib:array-index i j)) (setq char (char-code (char src i))) (if (or (< char min-char-index) (> char max-char-index)) (progn (warn "Character ~S not representable in font ~S" (char src i) afont) (return i)) (setf (aref dst j) char))) (do ((i src-start (xlib::index+ i 1)) (j dst-start (xlib::index+ j 1)) (elt)) ((xlib::index>= i src-end) i) (declare (type xlib:array-index i j)) (setq elt (elt src i)) (when (characterp elt) (setq elt (char-code elt))) (if (or (not (integerp elt)) (< elt min-char-index) (> elt max-char-index)) (progn (warn "Thing ~S not representable in font ~S" (elt src i) afont) (return i)) (setf (aref dst j) elt)))))) (defmethod text-size ((medium clx-medium) string &key text-style (start 0) end) (when (characterp string) (setf string (make-string 1 :initial-element string))) (unless end (setf end (length string))) (unless text-style (setf text-style (medium-text-style medium))) (let ((xfont (text-style-to-X-font (port medium) text-style))) (cond ((= start end) (values 0 0 0 0 0)) (t (let ((position-newline (position #\newline string :start start :end end))) (cond ((not (null position-newline)) (multiple-value-bind (width ascent descent left right font-ascent font-descent direction first-not-done) (xlib:text-extents xfont string :start start :end position-newline :translate #'translate) (declare (ignorable left right font-ascent font-descent direction first-not-done)) (multiple-value-bind (w h x y baseline) (text-size medium string :text-style text-style :start (1+ position-newline) :end end) (values (max w width) (+ ascent descent h) x (+ ascent descent y) (+ ascent descent baseline))))) (t (multiple-value-bind (width ascent descent left right font-ascent font-descent direction first-not-done) (xlib:text-extents xfont string :start start :end end :translate #'translate) (declare (ignorable left right font-ascent font-descent direction first-not-done)) (values width (+ ascent descent) width 0 ascent)) )))))) ) (defmethod climi::text-bounding-rectangle* ((medium clx-medium) string &key text-style (start 0) end) (when (characterp string) (setf string (make-string 1 :initial-element string))) (unless end (setf end (length string))) (unless text-style (setf text-style (medium-text-style medium))) (let ((xfont (text-style-to-X-font (port medium) text-style))) (cond ((= start end) (values 0 0 0 0)) (t (let ((position-newline (position #\newline string :start start :end end))) (cond ((not (null position-newline)) (multiple-value-bind (width ascent descent left right font-ascent font-descent direction first-not-done) (xlib:text-extents xfont string :start start :end position-newline :translate #'translate) (declare (ignorable left right font-ascent font-descent direction first-not-done)) (multiple-value-bind (minx miny maxx maxy) (climi::text-bounding-rectangle* medium string :text-style text-style :start (1+ position-newline) :end end) (values (min minx left) (- ascent) (max maxx right) (+ descent maxy))))) (t (multiple-value-bind (width ascent descent left right font-ascent font-descent direction first-not-done) (xlib:text-extents xfont string :start start :end end :translate #'translate) (declare (ignore width direction first-not-done)) ;; FIXME: Potential style points: ;; * (min 0 left), (max width right) ;; * font-ascent / ascent (values left (- font-ascent) right font-descent))))))))) (defmethod medium-draw-text* ((medium clx-medium) string x y start end align-x align-y toward-x toward-y transform-glyphs) (declare (ignore toward-x toward-y transform-glyphs)) (with-transformed-position ((sheet-native-transformation (medium-sheet medium)) x y) (with-clx-graphics (medium) (when (characterp string) (setq string (make-string 1 :initial-element string))) (when (null end) (setq end (length string))) (multiple-value-bind (text-width text-height x-cursor y-cursor baseline) (text-size medium string :start start :end end) (declare (ignore x-cursor y-cursor)) (unless (and (eq align-x :left) (eq align-y :baseline)) (setq x (- x (ecase align-x (:left 0) (:center (round text-width 2)) (:right text-width)))) (setq y (ecase align-y (:top (+ y baseline)) (:center (+ y baseline (- (floor text-height 2)))) (:baseline y) (:bottom (+ y baseline (- text-height))))))) (let ((x (round-coordinate x)) (y (round-coordinate y))) (when (and (<= #x-8000 x #x7FFF) (<= #x-8000 y #x7FFF)) (multiple-value-bind (halt width) (xlib:draw-glyphs mirror gc x y string :start start :end end :translate #'translate))))))) (defmethod medium-buffering-output-p ((medium clx-medium)) t) (defmethod (setf medium-buffering-output-p) (buffer-p (medium clx-medium)) buffer-p) (defmethod medium-draw-glyph ((medium clx-medium) element x y align-x align-y toward-x toward-y transform-glyphs) (declare (ignore toward-x toward-y transform-glyphs align-x align-y)) (with-transformed-position ((sheet-native-transformation (medium-sheet medium)) x y) (with-clx-graphics (medium) (xlib:draw-glyph mirror gc (round-coordinate x) (round-coordinate y) element :size 16 :translate #'translate)))) ;;; Other Medium-specific Output Functions (defmethod medium-finish-output ((medium clx-medium)) (xlib:display-finish-output (clx-port-display (port medium)))) (defmethod medium-force-output ((medium clx-medium)) (xlib:display-force-output (clx-port-display (port medium)))) (defmethod medium-clear-area ((medium clx-medium) left top right bottom) (let ((tr (sheet-native-transformation (medium-sheet medium)))) (with-transformed-position (tr left top) (with-transformed-position (tr right bottom) (let ((min-x (round-coordinate (min left right))) (min-y (round-coordinate (min top bottom))) (max-x (round-coordinate (max left right))) (max-y (round-coordinate (max top bottom)))) (xlib:draw-rectangle (or (medium-buffer medium) (port-lookup-mirror (port medium) (medium-sheet medium))) (medium-gcontext medium (medium-background medium)) (max #x-8000 (min #x7fff min-x)) (max #x-8000 (min #x7fff min-y)) (max 0 (min #xffff (- max-x min-x))) (max 0 (min #xffff (- max-y min-y))) t)))))) (defmethod medium-beep ((medium clx-medium)) (xlib:bell (clx-port-display (port medium)))) ;;;; ; With-double-buffering is broken, so I remove it for now - BTS #+nil (defmethod invoke-with-special-choices (continuation (medium clx-medium)) (let ((sheet (medium-sheet medium))) (with-double-buffering (sheet) (funcall continuation (sheet-medium sheet))))) (defmethod invoke-with-special-choices (continuation (medium clx-medium)) (let ((sheet (medium-sheet medium))) (funcall continuation (sheet-medium sheet)))) ;;;; (defmethod medium-miter-limit ((medium clx-medium)) #.(* pi (/ 11 180))) (defmethod climi::medium-invoke-with-possible-double-buffering (frame pane (medium clx-medium) continuation) (if (climi::pane-double-buffering pane) (let* ((mirror (sheet-direct-mirror pane)) (width (xlib:drawable-width mirror)) (height (xlib:drawable-height mirror)) (depth (xlib:drawable-depth mirror)) (pixmap (xlib:create-pixmap :width width :height height :depth depth :drawable mirror))) (setf (medium-buffer medium) pixmap) (unwind-protect (funcall continuation) (xlib:copy-area pixmap (medium-gcontext medium (medium-foreground medium)) 0 0 width height mirror 0 0) (xlib:free-pixmap pixmap) (setf (medium-buffer medium) nil))) (funcall continuation))) ;;; RGB-IMAGE support, from Closure (defmethod climi::medium-draw-image-design* ((medium clx-medium) (design climi::rgb-image-design) x y) (let* ((da (sheet-direct-mirror (medium-sheet medium))) (image (slot-value design 'climi::image)) (width (climi::image-width image)) (height (climi::image-height image))) (destructuring-bind (&optional pixmap mask) (slot-value design 'climi::medium-data) (unless pixmap (setf pixmap (compute-rgb-image-pixmap da image)) (when (climi::image-alpha-p image) (setf mask (compute-rgb-image-mask da image))) (setf (slot-value design 'climi::medium-data) (list pixmap mask))) (multiple-value-bind (x y) (transform-position (sheet-device-transformation (medium-sheet medium)) x y) (setf x (round x)) (setf y (round y)) (let ((gcontext (xlib:create-gcontext :drawable da))) (cond (mask (xlib:with-gcontext (gcontext :clip-mask mask :clip-x x :clip-y y) (xlib:copy-area pixmap gcontext 0 0 width height da x y))) (t (xlib:copy-area pixmap gcontext 0 0 width height da x y)))))))) (defmethod climi::medium-free-image-design ((medium clx-medium) (design climi::rgb-image-design)) (destructuring-bind (&optional pixmap mask) (slot-value design 'climi::medium-data) (when pixmap (xlib:free-pixmap pixmap) (when mask (xlib:free-pixmap mask)) (setf (slot-value design 'climi::medium-data) nil)))) (defun compute-rgb-image-pixmap (drawable image) (let* ((width (climi::image-width image)) (height (climi::image-height image)) (depth (xlib:drawable-depth drawable)) (im (image-to-ximage-for-drawable drawable image))) (setf width (max width 1)) (setf height (max height 1)) (let* ((pixmap (xlib:create-pixmap :drawable drawable :width width :height height :depth depth)) (gc (xlib:create-gcontext :drawable pixmap))) (unless (or (>= width 2048) (>= height 2048)) ;### CLX bug (xlib:put-image pixmap gc im :src-x 0 :src-y 0 :x 0 :y 0 :width width :height height)) (xlib:free-gcontext gc) pixmap))) (defun compute-rgb-image-mask (drawable image) (let* ((width (climi::image-width image)) (height (climi::image-height image)) (bitmap (xlib:create-pixmap :drawable drawable :width width :height height :depth 1)) (gc (xlib:create-gcontext :drawable bitmap :foreground 1 :background 0)) (idata (climi::image-data image)) (xdata (make-array (list height width) :element-type '(unsigned-byte 1))) (im (xlib:create-image :width width :height height :depth 1 :data xdata)) ) (dotimes (y width) (dotimes (x height) (if (> (aref idata x y) #x80000000) (setf (aref xdata x y) 0) (setf (aref xdata x y) 1)))) (unless (or (>= width 2048) (>= height 2048)) ;### CLX breaks here (xlib:put-image bitmap gc im :src-x 0 :src-y 0 :x 0 :y 0 :width width :height height :bitmap-p nil)) (xlib:free-gcontext gc) bitmap)) (defun image-to-ximage-for-drawable (drawable image) (image-to-ximage image (xlib:drawable-depth drawable) (pixel-translator (xlib:window-colormap drawable)))) (defun image-to-ximage (image depth translator) (let* ((width (climi::image-width image)) (height (climi::image-height image)) (idata (climi::image-data image)) ;; FIXME: this (and the :BITS-PER-PIXEL, below) is a hack on ;; top of a hack. At some point in the past, XFree86 and/or ;; X.org decided that they would no longer support pixmaps ;; with 24 bpp, which seems to be what most AIMAGEs want to ;; be. For now, force everything to a 32-bit pixmap. (xdata (make-array (list height width) :element-type '(unsigned-byte 32))) (ximage (xlib:create-image :width width :height height :depth depth :bits-per-pixel 32 :data xdata))) (declare (type (simple-array (unsigned-byte 32) (* *)) idata)) (loop for x fixnum from 0 below width do (loop for y fixnum from 0 below height do (setf (aref xdata y x) (funcall translator x y (ldb (byte 24 0) (aref idata y x)))))) ximage)) (defun mask->byte (mask) (let ((h (integer-length mask))) (let ((l (integer-length (logxor mask (1- (ash 1 h)))))) (byte (- h l) l)))) ;; fixme! This is not just incomplete, but also incorrect: The original ;; true color code knew how to deal with non-linear RGB value ;; allocation. (defvar *translator-cache-lock* (clim-sys:make-lock "translator cache lock")) (defvar *translator-cache* (make-hash-table :test #'equal)) (defun pixel-translator (colormap) (unless (eq (xlib:visual-info-class (xlib:colormap-visual-info colormap)) :true-color) (error "sorry, cannot draw rgb image for non-true-color drawable yet")) (let* ((info (xlib:colormap-visual-info colormap)) (rbyte (mask->byte (xlib:visual-info-red-mask info))) (gbyte (mask->byte (xlib:visual-info-green-mask info))) (bbyte (mask->byte (xlib:visual-info-blue-mask info))) (key (list rbyte gbyte bbyte))) (clim-sys:with-lock-held (*translator-cache-lock*) (or (gethash key *translator-cache*) ;; COMPILE instead of a closure, because out-of-line byte specifiers ;; are universally slow. Getting them inline like this is *much* ;; faster. (setf (gethash key *translator-cache*) (compile nil `(lambda (x y sample) (declare (ignore x y)) (dpb (the (unsigned-byte 8) (ldb (byte 8 0) sample)) ',rbyte (dpb (the (unsigned-byte 8) (ldb (byte 8 8) sample)) ',gbyte (dpb (the (unsigned-byte 8) (ldb (byte 8 16) sample)) ',bbyte 0)))))))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/PostScript/0000755000175000017500000000000011347763424020636 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/PostScript/standard-metrics.lisp0000600000175000017500000046173310423413306024762 0ustar pdmpdm (in-package :clim-postscript) (define-font-metrics '"Times-Roman" '683 '217 '0 '((32 "space" 250 0 0 0 0) (33 "exclam" 333 676 9 -130 238) (34 "quotedbl" 408 676 -431 -77 331) (35 "numbersign" 500 662 0 -5 496) (36 "dollar" 500 727 87 -44 457) (37 "percent" 833 676 13 -61 772) (38 "ampersand" 778 676 13 -42 750) (39 "quoteright" 333 676 -433 -79 218) (40 "parenleft" 333 676 177 -48 304) (41 "parenright" 333 676 177 -29 285) (42 "asterisk" 500 676 -265 -69 432) (43 "plus" 564 506 0 -30 534) (44 "comma" 250 102 141 -56 195) (45 "hyphen" 333 257 -194 -39 285) (46 "period" 250 100 11 -70 181) (47 "slash" 278 676 14 9 287) (48 "zero" 500 676 14 -24 476) (49 "one" 500 676 0 -111 394) (50 "two" 500 676 0 -30 475) (51 "three" 500 676 14 -43 431) (52 "four" 500 676 0 -12 472) (53 "five" 500 688 14 -32 438) (54 "six" 500 684 14 -34 468) (55 "seven" 500 662 8 -20 449) (56 "eight" 500 676 14 -56 445) (57 "nine" 500 676 22 -30 459) (58 "colon" 278 459 11 -81 192) (59 "semicolon" 278 459 141 -80 219) (60 "less" 564 514 8 -28 536) (61 "equal" 564 386 -120 -30 534) (62 "greater" 564 514 8 -28 536) (63 "question" 444 676 8 -68 414) (64 "at" 921 676 14 -116 809) (65 "A" 722 674 0 -15 706) (66 "B" 667 662 0 -17 593) (67 "C" 667 676 14 -28 633) (68 "D" 722 662 0 -16 685) (69 "E" 611 662 0 -12 597) (70 "F" 556 662 0 -12 546) (71 "G" 722 676 14 -32 709) (72 "H" 722 662 0 -19 702) (73 "I" 333 662 0 -18 315) (74 "J" 389 662 14 -10 370) (75 "K" 722 662 0 -34 723) (76 "L" 611 662 0 -12 598) (77 "M" 889 662 0 -12 863) (78 "N" 722 662 11 -12 707) (79 "O" 722 676 14 -34 688) (80 "P" 556 662 0 -16 542) (81 "Q" 722 676 178 -34 701) (82 "R" 667 662 0 -17 659) (83 "S" 556 676 14 -42 491) (84 "T" 611 662 0 -17 593) (85 "U" 722 662 14 -14 705) (86 "V" 722 662 11 -16 697) (87 "W" 944 662 11 -5 932) (88 "X" 722 662 0 -10 704) (89 "Y" 722 662 0 -22 703) (90 "Z" 611 662 0 -9 597) (91 "bracketleft" 333 662 156 -88 299) (92 "backslash" 278 676 14 9 287) (93 "bracketright" 333 662 156 -34 245) (94 "asciicircum" 469 662 -297 -24 446) (95 "underscore" 500 -75 125 0 500) (96 "quoteleft" 333 676 -433 -115 254) (97 "a" 444 460 10 -37 442) (98 "b" 500 683 10 -3 468) (99 "c" 444 460 10 -25 412) (100 "d" 500 683 10 -27 491) (101 "e" 444 460 10 -25 424) (102 "f" 333 683 0 -20 383) (103 "g" 500 460 218 -28 470) (104 "h" 500 683 0 -9 487) (105 "i" 278 683 0 -16 253) (106 "j" 278 683 218 70 194) (107 "k" 500 683 0 -7 505) (108 "l" 278 683 0 -19 257) (109 "m" 778 460 0 -16 775) (110 "n" 500 460 0 -16 485) (111 "o" 500 460 10 -29 470) (112 "p" 500 460 217 -5 470) (113 "q" 500 460 217 -24 488) (114 "r" 333 460 0 -5 335) (115 "s" 389 460 10 -51 348) (116 "t" 278 579 10 -13 279) (117 "u" 500 450 10 -9 479) (118 "v" 500 450 14 -19 477) (119 "w" 722 450 14 -21 694) (120 "x" 500 450 0 -17 479) (121 "y" 500 450 218 -14 475) (122 "z" 444 450 0 -27 418) (123 "braceleft" 480 680 181 -100 350) (124 "bar" 200 676 14 -67 133) (125 "braceright" 480 680 181 -130 380) (126 "asciitilde" 541 323 -183 -40 502) (161 "exclamdown" 333 467 218 -97 205) (162 "cent" 500 579 138 -53 448) (163 "sterling" 500 676 8 -12 490) (164 "fraction" 167 676 14 168 331) (165 "yen" 500 662 0 53 512) (166 "florin" 500 676 189 -7 490) (167 "section" 500 676 148 -70 426) (168 "currency" 500 602 -58 22 522) (169 "quotesingle" 180 676 -431 -48 133) (170 "quotedblleft" 444 676 -433 -43 414) (171 "guillemotleft" 500 416 -33 -42 456) (172 "guilsinglleft" 333 416 -33 -63 285) (173 "guilsinglright" 333 416 -33 -48 270) (174 "fi" 556 683 0 -31 521) (175 "fl" 556 683 0 -32 521) (177 "endash" 500 250 -201 0 500) (178 "dagger" 500 676 149 -59 442) (179 "daggerdbl" 500 676 153 -58 442) (180 "periodcentered" 250 310 -199 -70 181) (182 "paragraph" 453 662 154 22 450) (183 "bullet" 350 466 -196 -40 310) (184 "quotesinglbase" 333 102 141 -79 218) (185 "quotedblbase" 444 102 141 -45 416) (186 "quotedblright" 444 676 -433 -30 401) (187 "guillemotright" 500 416 -33 -44 458) (188 "ellipsis" 1000 100 11 -111 888) (189 "perthousand" 1000 706 19 -7 994) (191 "questiondown" 444 466 218 -30 376) (193 "grave" 333 678 -507 -19 242) (194 "acute" 333 678 -507 -93 317) (195 "circumflex" 333 674 -507 -11 322) (196 "tilde" 333 638 -532 -1 331) (197 "macron" 333 601 -547 -11 322) (198 "breve" 333 664 -507 -26 307) (199 "dotaccent" 333 623 -523 -118 216) (200 "dieresis" 333 623 -523 -18 315) (202 "ring" 333 711 -512 -67 266) (203 "cedilla" 333 0 215 -52 261) (205 "hungarumlaut" 333 678 -507 3 377) (206 "ogonek" 333 0 165 -64 249) (207 "caron" 333 674 -507 -11 322) (208 "emdash" 1000 250 -201 0 1000) (225 "AE" 889 662 0 0 863) (227 "ordfeminine" 276 676 -394 -4 270) (232 "Lslash" 611 662 0 -12 598) (233 "Oslash" 722 734 80 -34 688) (234 "OE" 889 668 6 -30 885) (235 "ordmasculine" 310 676 -394 -6 304) (241 "ae" 667 460 10 -38 632) (245 "dotlessi" 278 460 0 -16 253) (248 "lslash" 278 683 0 -19 259) (249 "oslash" 500 551 112 -29 470) (250 "oe" 722 460 10 -30 690) (251 "germandbls" 500 683 9 -12 468) (-1 "Zcaron" 611 886 0 -9 597) (-1 "ccedilla" 444 460 215 -25 412) (-1 "ydieresis" 500 623 218 -14 475) (-1 "atilde" 444 638 10 -37 442) (-1 "icircumflex" 278 674 0 16 295) (-1 "threesuperior" 300 676 -262 -15 291) (-1 "ecircumflex" 444 674 10 -25 424) (-1 "thorn" 500 683 217 -5 470) (-1 "egrave" 444 678 10 -25 424) (-1 "twosuperior" 300 676 -270 -1 296) (-1 "eacute" 444 678 10 -25 424) (-1 "otilde" 500 638 10 -29 470) (-1 "Aacute" 722 890 0 -15 706) (-1 "ocircumflex" 500 674 10 -29 470) (-1 "yacute" 500 678 218 -14 475) (-1 "udieresis" 500 623 10 -9 479) (-1 "threequarters" 750 676 14 -15 718) (-1 "acircumflex" 444 674 10 -37 442) (-1 "Eth" 722 662 0 -16 685) (-1 "edieresis" 444 623 10 -25 424) (-1 "ugrave" 500 678 10 -9 479) (-1 "trademark" 980 662 -256 -30 957) (-1 "ograve" 500 678 10 -29 470) (-1 "scaron" 389 674 10 -39 350) (-1 "Idieresis" 333 835 0 -18 315) (-1 "uacute" 500 678 10 -9 479) (-1 "agrave" 444 678 10 -37 442) (-1 "ntilde" 500 638 0 -16 485) (-1 "aring" 444 711 10 -37 442) (-1 "zcaron" 444 674 0 -27 418) (-1 "Icircumflex" 333 886 0 -11 322) (-1 "Ntilde" 722 850 11 -12 707) (-1 "ucircumflex" 500 674 10 -9 479) (-1 "Ecircumflex" 611 886 0 -12 597) (-1 "Iacute" 333 890 0 -18 317) (-1 "Ccedilla" 667 676 215 -28 633) (-1 "Odieresis" 722 835 14 -34 688) (-1 "Scaron" 556 886 14 -42 491) (-1 "Edieresis" 611 835 0 -12 597) (-1 "Igrave" 333 890 0 -18 315) (-1 "adieresis" 444 623 10 -37 442) (-1 "Ograve" 722 890 14 -34 688) (-1 "Egrave" 611 890 0 -12 597) (-1 "Ydieresis" 722 835 0 -22 703) (-1 "registered" 760 676 14 -38 722) (-1 "Otilde" 722 850 14 -34 688) (-1 "onequarter" 750 676 14 -37 718) (-1 "Ugrave" 722 890 14 -14 705) (-1 "Ucircumflex" 722 886 14 -14 705) (-1 "Thorn" 556 662 0 -16 542) (-1 "divide" 564 516 10 -30 534) (-1 "Atilde" 722 850 0 -15 706) (-1 "Uacute" 722 890 14 -14 705) (-1 "Ocircumflex" 722 886 14 -34 688) (-1 "logicalnot" 564 386 -108 -30 534) (-1 "Aring" 722 898 0 -15 706) (-1 "idieresis" 278 623 0 9 288) (-1 "iacute" 278 678 0 -16 290) (-1 "aacute" 444 678 10 -37 442) (-1 "plusminus" 564 506 0 -30 534) (-1 "multiply" 564 497 -8 -38 527) (-1 "Udieresis" 722 835 14 -14 705) (-1 "minus" 564 286 -220 -30 534) (-1 "onesuperior" 300 676 -270 -57 248) (-1 "Eacute" 611 890 0 -12 597) (-1 "Acircumflex" 722 886 0 -15 706) (-1 "copyright" 760 676 14 -38 722) (-1 "Agrave" 722 890 0 -15 706) (-1 "odieresis" 500 623 10 -29 470) (-1 "oacute" 500 678 10 -29 470) (-1 "degree" 400 676 -390 -57 343) (-1 "igrave" 278 678 0 8 253) (-1 "mu" 500 450 218 -36 512) (-1 "Oacute" 722 890 14 -34 688) (-1 "eth" 500 686 10 -29 471) (-1 "Adieresis" 722 835 0 -15 706) (-1 "Yacute" 722 890 0 -22 703) (-1 "brokenbar" 200 676 14 -67 133) (-1 "onehalf" 750 676 14 -31 746))) (define-font-metrics '"Times-Bold" '676 '205 '0 '((32 "space" 250 0 0 0 0) (33 "exclam" 333 691 13 -81 251) (34 "quotedbl" 555 691 -404 -83 472) (35 "numbersign" 500 700 0 -4 496) (36 "dollar" 500 750 99 -29 472) (37 "percent" 1000 692 14 -124 877) (38 "ampersand" 833 691 16 -62 787) (39 "quoteright" 333 691 -356 -79 263) (40 "parenleft" 333 694 168 -46 306) (41 "parenright" 333 694 168 -27 287) (42 "asterisk" 500 691 -255 -56 447) (43 "plus" 570 506 0 -33 537) (44 "comma" 250 155 180 -39 223) (45 "hyphen" 333 287 -171 -44 287) (46 "period" 250 156 13 -41 210) (47 "slash" 278 691 19 24 302) (48 "zero" 500 688 13 -24 476) (49 "one" 500 688 0 -65 442) (50 "two" 500 688 0 -17 478) (51 "three" 500 688 14 -16 468) (52 "four" 500 688 0 -19 475) (53 "five" 500 676 8 -22 470) (54 "six" 500 688 13 -28 475) (55 "seven" 500 676 0 -17 477) (56 "eight" 500 688 13 -28 472) (57 "nine" 500 688 13 -26 473) (58 "colon" 333 472 13 -82 251) (59 "semicolon" 333 472 180 -82 266) (60 "less" 570 514 8 -31 539) (61 "equal" 570 399 -107 -33 537) (62 "greater" 570 514 8 -31 539) (63 "question" 500 689 13 -57 445) (64 "at" 930 691 19 -108 822) (65 "A" 722 690 0 -9 689) (66 "B" 667 676 0 -16 619) (67 "C" 722 691 19 -49 687) (68 "D" 722 676 0 -14 690) (69 "E" 667 676 0 -16 641) (70 "F" 611 676 0 -16 583) (71 "G" 778 691 19 -37 755) (72 "H" 778 676 0 -21 759) (73 "I" 389 676 0 -20 370) (74 "J" 500 676 96 -3 479) (75 "K" 778 676 0 -30 769) (76 "L" 667 676 0 -19 638) (77 "M" 944 676 0 -14 921) (78 "N" 722 676 18 -16 701) (79 "O" 778 691 19 -35 743) (80 "P" 611 676 0 -16 600) (81 "Q" 778 691 176 -35 743) (82 "R" 722 676 0 -26 715) (83 "S" 556 692 19 -35 513) (84 "T" 667 676 0 -31 636) (85 "U" 722 676 19 -16 701) (86 "V" 722 676 18 -16 701) (87 "W" 1000 676 15 -19 981) (88 "X" 722 676 0 -16 699) (89 "Y" 722 676 0 -15 699) (90 "Z" 667 676 0 -28 634) (91 "bracketleft" 333 678 149 -67 301) (92 "backslash" 278 691 19 25 303) (93 "bracketright" 333 678 149 -32 266) (94 "asciicircum" 581 676 -311 -73 509) (95 "underscore" 500 -75 125 0 500) (96 "quoteleft" 333 691 -356 -70 254) (97 "a" 500 473 14 -25 488) (98 "b" 556 676 14 -17 521) (99 "c" 444 473 14 -25 430) (100 "d" 556 676 14 -25 534) (101 "e" 444 473 14 -25 426) (102 "f" 333 691 0 -14 389) (103 "g" 500 473 206 -28 483) (104 "h" 556 676 0 -16 534) (105 "i" 278 691 0 -16 255) (106 "j" 333 691 203 57 263) (107 "k" 556 676 0 -22 543) (108 "l" 278 676 0 -16 255) (109 "m" 833 473 0 -16 814) (110 "n" 556 473 0 -21 539) (111 "o" 500 473 14 -25 476) (112 "p" 556 473 205 -19 524) (113 "q" 556 473 205 -34 536) (114 "r" 444 473 0 -29 434) (115 "s" 389 473 14 -25 361) (116 "t" 333 630 12 -20 332) (117 "u" 556 461 14 -16 537) (118 "v" 500 461 14 -21 485) (119 "w" 722 461 14 -23 707) (120 "x" 500 461 0 -12 484) (121 "y" 500 461 205 -16 480) (122 "z" 444 461 0 -21 420) (123 "braceleft" 394 698 175 -22 340) (124 "bar" 220 691 19 -66 154) (125 "braceright" 394 698 175 -54 372) (126 "asciitilde" 520 333 -173 -29 491) (161 "exclamdown" 333 501 203 -82 252) (162 "cent" 500 588 140 -53 458) (163 "sterling" 500 684 14 -21 477) (164 "fraction" 167 688 12 168 329) (165 "yen" 500 676 0 64 547) (166 "florin" 500 706 155 0 498) (167 "section" 500 691 132 -57 443) (168 "currency" 500 613 -61 26 526) (169 "quotesingle" 278 691 -404 -75 204) (170 "quotedblleft" 500 691 -356 -32 486) (171 "guillemotleft" 500 415 -36 -23 473) (172 "guilsinglleft" 333 415 -36 -51 305) (173 "guilsinglright" 333 415 -36 -28 282) (174 "fi" 556 691 0 -14 536) (175 "fl" 556 691 0 -14 536) (177 "endash" 500 271 -181 0 500) (178 "dagger" 500 691 134 -47 453) (179 "daggerdbl" 500 691 132 -45 456) (180 "periodcentered" 250 417 -248 -41 210) (182 "paragraph" 540 676 186 0 519) (183 "bullet" 350 478 -198 -35 315) (184 "quotesinglbase" 333 155 180 -79 263) (185 "quotedblbase" 500 155 180 -14 468) (186 "quotedblright" 500 691 -356 -14 468) (187 "guillemotright" 500 415 -36 -27 477) (188 "ellipsis" 1000 156 13 -82 917) (189 "perthousand" 1000 706 29 -7 995) (191 "questiondown" 500 501 201 -55 443) (193 "grave" 333 713 -528 -8 246) (194 "acute" 333 713 -528 -86 324) (195 "circumflex" 333 704 -528 2 335) (196 "tilde" 333 674 -547 16 349) (197 "macron" 333 637 -565 -1 331) (198 "breve" 333 691 -528 -15 318) (199 "dotaccent" 333 667 -537 -103 230) (200 "dieresis" 333 667 -537 2 335) (202 "ring" 333 740 -527 -60 273) (203 "cedilla" 333 0 218 -68 294) (205 "hungarumlaut" 333 713 -528 13 425) (206 "ogonek" 333 44 173 -90 319) (207 "caron" 333 704 -528 2 335) (208 "emdash" 1000 271 -181 0 1000) (225 "AE" 1000 676 0 -4 951) (227 "ordfeminine" 300 688 -397 1 301) (232 "Lslash" 667 676 0 -19 638) (233 "Oslash" 778 737 74 -35 743) (234 "OE" 1000 684 5 -22 981) (235 "ordmasculine" 330 688 -397 -18 312) (241 "ae" 722 473 14 -33 693) (245 "dotlessi" 278 461 0 -16 255) (248 "lslash" 278 676 0 22 303) (249 "oslash" 500 549 92 -25 476) (250 "oe" 722 473 14 -22 696) (251 "germandbls" 556 691 12 -19 517) (-1 "Zcaron" 667 914 0 -28 634) (-1 "ccedilla" 444 473 218 -25 430) (-1 "ydieresis" 500 667 205 -16 480) (-1 "atilde" 500 674 14 -25 488) (-1 "icircumflex" 278 704 0 36 301) (-1 "threesuperior" 300 688 -268 -3 297) (-1 "ecircumflex" 444 704 14 -25 426) (-1 "thorn" 556 676 205 -19 524) (-1 "egrave" 444 713 14 -25 426) (-1 "twosuperior" 300 688 -275 0 300) (-1 "eacute" 444 713 14 -25 426) (-1 "otilde" 500 674 14 -25 476) (-1 "Aacute" 722 923 0 -9 689) (-1 "ocircumflex" 500 704 14 -25 476) (-1 "yacute" 500 713 205 -16 480) (-1 "udieresis" 556 667 14 -16 537) (-1 "threequarters" 750 688 12 -23 733) (-1 "acircumflex" 500 704 14 -25 488) (-1 "Eth" 722 676 0 -6 690) (-1 "edieresis" 444 667 14 -25 426) (-1 "ugrave" 556 713 14 -16 537) (-1 "trademark" 1000 676 -271 -24 977) (-1 "ograve" 500 713 14 -25 476) (-1 "scaron" 389 704 14 -25 363) (-1 "Idieresis" 389 877 0 -20 370) (-1 "uacute" 556 713 14 -16 537) (-1 "agrave" 500 713 14 -25 488) (-1 "ntilde" 556 674 0 -21 539) (-1 "aring" 500 740 14 -25 488) (-1 "zcaron" 444 704 0 -21 420) (-1 "Icircumflex" 389 914 0 -20 370) (-1 "Ntilde" 722 884 18 -16 701) (-1 "ucircumflex" 556 704 14 -16 537) (-1 "Ecircumflex" 667 914 0 -16 641) (-1 "Iacute" 389 923 0 -20 370) (-1 "Ccedilla" 722 691 218 -49 687) (-1 "Odieresis" 778 877 19 -35 743) (-1 "Scaron" 556 914 19 -35 513) (-1 "Edieresis" 667 877 0 -16 641) (-1 "Igrave" 389 923 0 -20 370) (-1 "adieresis" 500 667 14 -25 488) (-1 "Ograve" 778 923 19 -35 743) (-1 "Egrave" 667 923 0 -16 641) (-1 "Ydieresis" 722 877 0 -15 699) (-1 "registered" 747 691 19 -26 721) (-1 "Otilde" 778 884 19 -35 743) (-1 "onequarter" 750 688 12 -28 743) (-1 "Ugrave" 722 923 19 -16 701) (-1 "Ucircumflex" 722 914 19 -16 701) (-1 "Thorn" 611 676 0 -16 600) (-1 "divide" 570 537 31 -33 537) (-1 "Atilde" 722 884 0 -9 689) (-1 "Uacute" 722 923 19 -16 701) (-1 "Ocircumflex" 778 914 19 -35 743) (-1 "logicalnot" 570 399 -108 -33 537) (-1 "Aring" 722 935 0 -9 689) (-1 "idieresis" 278 667 0 36 301) (-1 "iacute" 278 713 0 -16 290) (-1 "aacute" 500 713 14 -25 488) (-1 "plusminus" 570 506 0 -33 537) (-1 "multiply" 570 490 -16 -48 522) (-1 "Udieresis" 722 877 19 -16 701) (-1 "minus" 570 297 -209 -33 537) (-1 "onesuperior" 300 688 -275 -28 273) (-1 "Eacute" 667 923 0 -16 641) (-1 "Acircumflex" 722 914 0 -9 689) (-1 "copyright" 747 691 19 -26 721) (-1 "Agrave" 722 923 0 -9 689) (-1 "odieresis" 500 667 14 -25 476) (-1 "oacute" 500 713 14 -25 476) (-1 "degree" 400 688 -402 -57 343) (-1 "igrave" 278 713 0 26 255) (-1 "mu" 556 461 206 -33 536) (-1 "Oacute" 778 923 19 -35 743) (-1 "eth" 500 691 14 -25 476) (-1 "Adieresis" 722 877 0 -9 689) (-1 "Yacute" 722 928 0 -15 699) (-1 "brokenbar" 220 691 19 -66 154) (-1 "onehalf" 750 688 12 7 775))) (define-font-metrics '"Times-Italic" '683 '205 '-15.5 '((32 "space" 250 0 0 0 0) (33 "exclam" 333 667 11 -39 302) (34 "quotedbl" 420 666 -421 -144 432) (35 "numbersign" 500 676 0 -2 540) (36 "dollar" 500 731 89 -31 497) (37 "percent" 833 676 13 -79 790) (38 "ampersand" 778 666 18 -76 723) (39 "quoteright" 333 666 -436 -151 290) (40 "parenleft" 333 669 181 -42 315) (41 "parenright" 333 669 180 -16 289) (42 "asterisk" 500 666 -255 -128 492) (43 "plus" 675 506 0 -86 590) (44 "comma" 250 101 129 4 135) (45 "hyphen" 333 255 -192 -49 282) (46 "period" 250 100 11 -27 138) (47 "slash" 278 666 18 65 386) (48 "zero" 500 676 7 -32 497) (49 "one" 500 676 0 -49 409) (50 "two" 500 676 0 -12 452) (51 "three" 500 676 7 -15 465) (52 "four" 500 676 0 -1 479) (53 "five" 500 666 7 -15 491) (54 "six" 500 686 7 -30 521) (55 "seven" 500 666 8 -75 537) (56 "eight" 500 676 7 -30 493) (57 "nine" 500 676 17 -23 492) (58 "colon" 333 441 11 -50 261) (59 "semicolon" 333 441 129 -27 261) (60 "less" 675 514 8 -84 592) (61 "equal" 675 386 -120 -86 590) (62 "greater" 675 514 8 -84 592) (63 "question" 500 664 12 -132 472) (64 "at" 920 666 18 -118 806) (65 "A" 611 668 0 51 564) (66 "B" 611 653 0 8 588) (67 "C" 667 666 18 -66 689) (68 "D" 722 653 0 8 700) (69 "E" 611 653 0 1 634) (70 "F" 611 653 0 -8 645) (71 "G" 722 666 18 -52 722) (72 "H" 722 653 0 8 767) (73 "I" 333 653 0 8 384) (74 "J" 444 653 18 6 491) (75 "K" 667 653 0 -7 722) (76 "L" 556 653 0 8 559) (77 "M" 833 653 0 18 873) (78 "N" 667 653 15 20 727) (79 "O" 722 666 18 -60 699) (80 "P" 611 653 0 0 605) (81 "Q" 722 666 182 -59 699) (82 "R" 611 653 0 13 588) (83 "S" 500 667 18 -17 508) (84 "T" 556 653 0 -59 633) (85 "U" 722 653 18 -102 765) (86 "V" 611 653 18 -76 688) (87 "W" 833 653 18 -71 906) (88 "X" 611 653 0 29 655) (89 "Y" 556 653 0 -78 633) (90 "Z" 556 653 0 6 606) (91 "bracketleft" 389 663 153 -21 391) (92 "backslash" 278 666 18 41 319) (93 "bracketright" 389 663 153 -12 382) (94 "asciicircum" 422 666 -301 0 422) (95 "underscore" 500 -75 125 0 500) (96 "quoteleft" 333 666 -436 -171 310) (97 "a" 500 441 11 -17 476) (98 "b" 500 683 11 -23 473) (99 "c" 444 441 11 -30 425) (100 "d" 500 683 13 -15 527) (101 "e" 444 441 11 -31 412) (102 "f" 278 678 207 147 424) (103 "g" 500 441 206 -8 472) (104 "h" 500 683 9 -19 478) (105 "i" 278 654 11 -49 264) (106 "j" 278 654 207 124 276) (107 "k" 444 683 11 -14 461) (108 "l" 278 683 11 -41 279) (109 "m" 722 441 9 -12 704) (110 "n" 500 441 9 -14 474) (111 "o" 500 441 11 -27 468) (112 "p" 500 441 205 75 469) (113 "q" 500 441 209 -25 483) (114 "r" 389 441 0 -45 412) (115 "s" 389 442 13 -16 366) (116 "t" 278 546 11 -37 296) (117 "u" 500 441 11 -42 475) (118 "v" 444 441 18 -21 426) (119 "w" 667 441 18 -16 648) (120 "x" 444 441 11 27 447) (121 "y" 444 441 206 24 426) (122 "z" 389 428 81 2 380) (123 "braceleft" 400 687 177 -51 407) (124 "bar" 275 666 18 -105 171) (125 "braceright" 400 687 177 7 349) (126 "asciitilde" 541 323 -183 -40 502) (161 "exclamdown" 389 473 205 -59 322) (162 "cent" 500 560 143 -77 472) (163 "sterling" 500 670 6 -10 517) (164 "fraction" 167 676 10 169 337) (165 "yen" 500 653 0 -27 603) (166 "florin" 500 682 182 -25 507) (167 "section" 500 666 162 -53 461) (168 "currency" 500 597 -53 22 522) (169 "quotesingle" 214 666 -421 -132 241) (170 "quotedblleft" 556 666 -436 -166 514) (171 "guillemotleft" 500 403 -37 -53 445) (172 "guilsinglleft" 333 403 -37 -51 281) (173 "guilsinglright" 333 403 -37 -52 282) (174 "fi" 500 681 207 141 481) (175 "fl" 500 682 204 141 518) (177 "endash" 500 243 -197 6 505) (178 "dagger" 500 666 159 -101 488) (179 "daggerdbl" 500 666 143 -22 491) (180 "periodcentered" 250 310 -199 -70 181) (182 "paragraph" 523 653 123 -55 616) (183 "bullet" 350 461 -191 -40 310) (184 "quotesinglbase" 333 101 129 -44 183) (185 "quotedblbase" 556 101 129 -57 405) (186 "quotedblright" 556 666 -436 -151 499) (187 "guillemotright" 500 403 -37 -55 447) (188 "ellipsis" 889 100 11 -57 762) (189 "perthousand" 1000 706 19 -25 1010) (191 "questiondown" 500 471 205 -28 368) (193 "grave" 333 664 -492 -121 311) (194 "acute" 333 664 -494 -180 403) (195 "circumflex" 333 661 -492 -91 385) (196 "tilde" 333 624 -517 -100 427) (197 "macron" 333 583 -532 -99 411) (198 "breve" 333 650 -492 -117 418) (199 "dotaccent" 333 606 -508 -207 305) (200 "dieresis" 333 606 -508 -107 405) (202 "ring" 333 691 -492 -155 355) (203 "cedilla" 333 0 217 30 182) (205 "hungarumlaut" 333 664 -494 -93 486) (206 "ogonek" 333 40 169 20 200) (207 "caron" 333 661 -492 -121 426) (208 "emdash" 889 243 -197 6 894) (225 "AE" 889 653 0 27 911) (227 "ordfeminine" 276 676 -406 -42 352) (232 "Lslash" 556 653 0 8 559) (233 "Oslash" 722 722 105 -60 699) (234 "OE" 944 666 8 -49 964) (235 "ordmasculine" 310 676 -406 -67 362) (241 "ae" 667 441 11 -23 640) (245 "dotlessi" 278 441 11 -49 235) (248 "lslash" 278 683 11 -37 307) (249 "oslash" 500 554 135 -28 469) (250 "oe" 667 441 12 -20 646) (251 "germandbls" 500 679 207 168 493) (-1 "Zcaron" 556 873 0 6 606) (-1 "ccedilla" 444 441 217 -26 425) (-1 "ydieresis" 444 606 206 24 441) (-1 "atilde" 500 624 11 -17 511) (-1 "icircumflex" 278 661 11 -34 328) (-1 "threesuperior" 300 676 -268 -43 339) (-1 "ecircumflex" 444 661 11 -31 441) (-1 "thorn" 500 683 205 75 469) (-1 "egrave" 444 664 11 -31 412) (-1 "twosuperior" 300 676 -271 -33 324) (-1 "eacute" 444 664 11 -31 459) (-1 "otilde" 500 624 11 -27 496) (-1 "Aacute" 611 876 0 51 564) (-1 "ocircumflex" 500 661 11 -27 468) (-1 "yacute" 444 664 206 24 459) (-1 "udieresis" 500 606 11 -42 479) (-1 "threequarters" 750 676 10 -23 736) (-1 "acircumflex" 500 661 11 -17 476) (-1 "Eth" 722 653 0 8 700) (-1 "edieresis" 444 606 11 -31 451) (-1 "ugrave" 500 664 11 -42 475) (-1 "trademark" 980 653 -247 -30 957) (-1 "ograve" 500 664 11 -27 468) (-1 "scaron" 389 661 13 -16 454) (-1 "Idieresis" 333 818 0 8 435) (-1 "uacute" 500 664 11 -42 477) (-1 "agrave" 500 664 11 -17 476) (-1 "ntilde" 500 624 9 -14 476) (-1 "aring" 500 691 11 -17 476) (-1 "zcaron" 389 661 81 2 434) (-1 "Icircumflex" 333 873 0 8 425) (-1 "Ntilde" 667 836 15 20 727) (-1 "ucircumflex" 500 661 11 -42 475) (-1 "Ecircumflex" 611 873 0 1 634) (-1 "Iacute" 333 876 0 8 413) (-1 "Ccedilla" 667 666 217 -66 689) (-1 "Odieresis" 722 818 18 -60 699) (-1 "Scaron" 500 873 18 -17 520) (-1 "Edieresis" 611 818 0 1 634) (-1 "Igrave" 333 876 0 8 384) (-1 "adieresis" 500 606 11 -17 489) (-1 "Ograve" 722 876 18 -60 699) (-1 "Egrave" 611 876 0 1 634) (-1 "Ydieresis" 556 818 0 -78 633) (-1 "registered" 760 666 18 -41 719) (-1 "Otilde" 722 836 18 -60 699) (-1 "onequarter" 750 676 10 -33 736) (-1 "Ugrave" 722 876 18 -102 765) (-1 "Ucircumflex" 722 873 18 -102 765) (-1 "Thorn" 611 653 0 0 569) (-1 "divide" 675 517 11 -86 590) (-1 "Atilde" 611 836 0 51 566) (-1 "Uacute" 722 876 18 -102 765) (-1 "Ocircumflex" 722 873 18 -60 699) (-1 "logicalnot" 675 386 -108 -86 590) (-1 "Aring" 611 883 0 51 564) (-1 "idieresis" 278 606 11 -49 353) (-1 "iacute" 278 664 11 -49 356) (-1 "aacute" 500 664 11 -17 487) (-1 "plusminus" 675 506 0 -86 590) (-1 "multiply" 675 497 -8 -93 582) (-1 "Udieresis" 722 818 18 -102 765) (-1 "minus" 675 286 -220 -86 590) (-1 "onesuperior" 300 676 -271 -43 284) (-1 "Eacute" 611 876 0 1 634) (-1 "Acircumflex" 611 873 0 51 564) (-1 "copyright" 760 666 18 -41 719) (-1 "Agrave" 611 876 0 51 564) (-1 "odieresis" 500 606 11 -27 489) (-1 "oacute" 500 664 11 -27 487) (-1 "degree" 400 676 -390 -101 387) (-1 "igrave" 278 664 11 -49 284) (-1 "mu" 500 428 209 30 497) (-1 "Oacute" 722 876 18 -60 699) (-1 "eth" 500 683 11 -27 482) (-1 "Adieresis" 611 818 0 51 564) (-1 "Yacute" 556 876 0 -78 633) (-1 "brokenbar" 275 666 18 -105 171) (-1 "onehalf" 750 676 10 -34 749))) (define-font-metrics '"Times-BoldItalic" '699 '205 '-15 '((32 "space" 250 0 0 0 0) (33 "exclam" 389 684 13 -67 370) (34 "quotedbl" 555 685 -398 -136 536) (35 "numbersign" 500 700 0 33 533) (36 "dollar" 500 733 100 20 497) (37 "percent" 833 692 10 -39 793) (38 "ampersand" 778 682 19 -5 699) (39 "quoteright" 333 685 -369 -98 302) (40 "parenleft" 333 685 179 -28 344) (41 "parenright" 333 685 179 44 271) (42 "asterisk" 500 685 -249 -65 456) (43 "plus" 570 506 0 -33 537) (44 "comma" 250 134 182 60 144) (45 "hyphen" 333 282 -166 -2 271) (46 "period" 250 135 13 9 139) (47 "slash" 278 685 18 64 342) (48 "zero" 500 683 14 -17 477) (49 "one" 500 683 0 -5 419) (50 "two" 500 683 0 27 446) (51 "three" 500 683 13 15 450) (52 "four" 500 683 0 15 503) (53 "five" 500 669 13 11 487) (54 "six" 500 679 15 -23 509) (55 "seven" 500 669 0 -52 525) (56 "eight" 500 683 13 -3 476) (57 "nine" 500 683 10 12 475) (58 "colon" 333 459 13 -23 264) (59 "semicolon" 333 459 183 25 264) (60 "less" 570 514 8 -31 539) (61 "equal" 570 399 -107 -33 537) (62 "greater" 570 514 8 -31 539) (63 "question" 500 684 13 -79 470) (64 "at" 832 685 18 -63 770) (65 "A" 667 683 0 67 593) (66 "B" 667 669 0 24 624) (67 "C" 667 685 18 -32 677) (68 "D" 722 669 0 46 685) (69 "E" 667 669 0 27 653) (70 "F" 667 669 0 13 660) (71 "G" 722 685 18 -21 706) (72 "H" 778 669 0 24 799) (73 "I" 389 669 0 32 406) (74 "J" 500 669 99 46 524) (75 "K" 667 669 0 21 702) (76 "L" 611 669 0 22 590) (77 "M" 889 669 12 29 917) (78 "N" 722 669 15 27 748) (79 "O" 722 685 18 -27 691) (80 "P" 611 669 0 27 613) (81 "Q" 722 685 208 -27 691) (82 "R" 667 669 0 29 623) (83 "S" 556 685 18 -2 526) (84 "T" 611 669 0 -50 650) (85 "U" 722 669 18 -67 744) (86 "V" 667 669 18 -65 715) (87 "W" 889 669 18 -65 940) (88 "X" 667 669 0 24 694) (89 "Y" 611 669 0 -73 659) (90 "Z" 611 669 0 11 590) (91 "bracketleft" 333 674 159 37 362) (92 "backslash" 278 685 18 1 279) (93 "bracketright" 333 674 157 56 343) (94 "asciicircum" 570 669 -304 -67 503) (95 "underscore" 500 -75 125 0 500) (96 "quoteleft" 333 685 -369 -128 332) (97 "a" 500 462 14 21 455) (98 "b" 500 699 13 14 444) (99 "c" 444 462 13 5 392) (100 "d" 500 699 13 21 517) (101 "e" 444 462 13 -5 398) (102 "f" 333 698 205 169 446) (103 "g" 500 462 203 52 478) (104 "h" 556 699 9 13 498) (105 "i" 278 684 9 -2 263) (106 "j" 278 684 207 189 279) (107 "k" 500 699 8 23 483) (108 "l" 278 699 9 -2 290) (109 "m" 778 462 9 14 722) (110 "n" 556 462 9 6 493) (111 "o" 500 462 13 3 441) (112 "p" 500 462 205 120 446) (113 "q" 500 462 205 -1 471) (114 "r" 389 462 0 21 389) (115 "s" 389 462 13 19 333) (116 "t" 278 594 9 11 281) (117 "u" 556 462 9 -15 492) (118 "v" 444 462 13 -16 401) (119 "w" 667 462 13 -16 614) (120 "x" 500 462 13 46 469) (121 "y" 444 462 205 94 392) (122 "z" 389 449 78 43 368) (123 "braceleft" 348 686 187 -5 436) (124 "bar" 220 685 18 -66 154) (125 "braceright" 348 686 187 129 302) (126 "asciitilde" 570 333 -173 -54 516) (161 "exclamdown" 389 492 205 -19 322) (162 "cent" 500 576 143 -42 439) (163 "sterling" 500 683 12 32 510) (164 "fraction" 167 683 14 169 324) (165 "yen" 500 669 0 -33 628) (166 "florin" 500 707 156 87 537) (167 "section" 500 685 143 -36 459) (168 "currency" 500 586 -34 26 526) (169 "quotesingle" 278 685 -398 -128 268) (170 "quotedblleft" 500 685 -369 -53 513) (171 "guillemotleft" 500 415 -32 -12 468) (172 "guilsinglleft" 333 415 -32 -32 303) (173 "guilsinglright" 333 415 -32 -10 281) (174 "fi" 556 703 205 188 514) (175 "fl" 556 704 205 186 553) (177 "endash" 500 269 -178 40 477) (178 "dagger" 500 685 145 -91 494) (179 "daggerdbl" 500 685 139 -10 493) (180 "periodcentered" 250 405 -257 -51 199) (182 "paragraph" 500 669 193 57 562) (183 "bullet" 350 525 -175 0 350) (184 "quotesinglbase" 333 134 182 5 199) (185 "quotedblbase" 500 134 182 57 403) (186 "quotedblright" 500 685 -369 -53 513) (187 "guillemotright" 500 415 -32 -12 468) (188 "ellipsis" 1000 135 13 -40 852) (189 "perthousand" 1000 706 29 -7 996) (191 "questiondown" 500 492 205 -30 421) (193 "grave" 333 697 -516 -85 297) (194 "acute" 333 697 -516 -139 379) (195 "circumflex" 333 690 -516 -40 367) (196 "tilde" 333 655 -536 -48 407) (197 "macron" 333 623 -553 -51 393) (198 "breve" 333 678 -516 -71 387) (199 "dotaccent" 333 655 -525 -163 293) (200 "dieresis" 333 655 -525 -55 397) (202 "ring" 333 729 -516 -127 340) (203 "cedilla" 333 5 218 80 156) (205 "hungarumlaut" 333 697 -516 -69 498) (206 "ogonek" 333 44 173 40 189) (207 "caron" 333 690 -516 -79 411) (208 "emdash" 1000 269 -178 40 977) (225 "AE" 944 669 0 64 918) (227 "ordfeminine" 266 685 -399 -16 330) (232 "Lslash" 611 669 0 22 590) (233 "Oslash" 722 764 125 -27 691) (234 "OE" 944 677 8 -23 946) (235 "ordmasculine" 300 685 -400 -56 347) (241 "ae" 722 462 13 5 673) (245 "dotlessi" 278 462 9 -2 238) (248 "lslash" 278 699 9 13 301) (249 "oslash" 500 560 119 3 441) (250 "oe" 722 462 13 -6 674) (251 "germandbls" 500 705 200 200 473) (-1 "Zcaron" 611 897 0 11 590) (-1 "ccedilla" 444 462 218 24 392) (-1 "ydieresis" 444 655 205 94 438) (-1 "atilde" 500 655 14 21 491) (-1 "icircumflex" 278 690 9 2 325) (-1 "threesuperior" 300 683 -265 -17 321) (-1 "ecircumflex" 444 690 13 -5 423) (-1 "thorn" 500 699 205 120 446) (-1 "egrave" 444 697 13 -5 398) (-1 "twosuperior" 300 683 -274 -2 313) (-1 "eacute" 444 697 13 -5 435) (-1 "otilde" 500 655 13 3 491) (-1 "Aacute" 667 904 0 67 593) (-1 "ocircumflex" 500 690 13 3 451) (-1 "yacute" 444 697 205 94 435) (-1 "udieresis" 556 655 9 -15 494) (-1 "threequarters" 750 683 14 -7 726) (-1 "acircumflex" 500 690 14 21 455) (-1 "Eth" 722 669 0 31 700) (-1 "edieresis" 444 655 13 -5 443) (-1 "ugrave" 556 697 9 -15 492) (-1 "trademark" 1000 669 -263 -32 968) (-1 "ograve" 500 697 13 3 441) (-1 "scaron" 389 690 13 19 439) (-1 "Idieresis" 389 862 0 32 445) (-1 "uacute" 556 697 9 -15 492) (-1 "agrave" 500 697 14 21 455) (-1 "ntilde" 556 655 9 6 504) (-1 "aring" 500 729 14 21 455) (-1 "zcaron" 389 690 78 43 424) (-1 "Icircumflex" 389 897 0 32 420) (-1 "Ntilde" 722 862 15 27 748) (-1 "ucircumflex" 556 690 9 -15 492) (-1 "Ecircumflex" 667 897 0 27 653) (-1 "Iacute" 389 904 0 32 412) (-1 "Ccedilla" 667 685 218 -32 677) (-1 "Odieresis" 722 862 18 -27 691) (-1 "Scaron" 556 897 18 -2 526) (-1 "Edieresis" 667 862 0 27 653) (-1 "Igrave" 389 904 0 32 406) (-1 "adieresis" 500 655 14 21 471) (-1 "Ograve" 722 904 18 -27 691) (-1 "Egrave" 667 904 0 27 653) (-1 "Ydieresis" 611 862 0 -73 659) (-1 "registered" 747 685 18 -30 718) (-1 "Otilde" 722 862 18 -27 691) (-1 "onequarter" 750 683 14 -7 721) (-1 "Ugrave" 722 904 18 -67 744) (-1 "Ucircumflex" 722 897 18 -67 744) (-1 "Thorn" 611 669 0 27 573) (-1 "divide" 570 535 29 -33 537) (-1 "Atilde" 667 862 0 67 593) (-1 "Uacute" 722 904 18 -67 744) (-1 "Ocircumflex" 722 897 18 -27 691) (-1 "logicalnot" 606 399 -108 -51 555) (-1 "Aring" 667 921 0 67 593) (-1 "idieresis" 278 655 9 -2 360) (-1 "iacute" 278 697 9 -2 352) (-1 "aacute" 500 697 14 21 463) (-1 "plusminus" 570 506 0 -33 537) (-1 "multiply" 570 490 -16 -48 522) (-1 "Udieresis" 722 862 18 -67 744) (-1 "minus" 606 297 -209 -51 555) (-1 "onesuperior" 300 683 -274 -30 301) (-1 "Eacute" 667 904 0 27 653) (-1 "Acircumflex" 667 897 0 67 593) (-1 "copyright" 747 685 18 -30 718) (-1 "Agrave" 667 904 0 67 593) (-1 "odieresis" 500 655 13 3 466) (-1 "oacute" 500 697 13 3 463) (-1 "degree" 400 683 -397 -83 369) (-1 "igrave" 278 697 9 -2 260) (-1 "mu" 576 449 207 60 516) (-1 "Oacute" 722 904 18 -27 691) (-1 "eth" 500 699 13 3 454) (-1 "Adieresis" 667 862 0 67 593) (-1 "Yacute" 611 904 0 -73 659) (-1 "brokenbar" 220 685 18 -66 154) (-1 "onehalf" 750 683 14 9 723))) (define-font-metrics '"Courier" '629 '157 '0 '((32 "space" 600 0 0 0 0) (33 "exclam" 600 572 15 -236 364) (34 "quotedbl" 600 562 -328 -187 413) (35 "numbersign" 600 639 32 -93 507) (36 "dollar" 600 662 126 -105 496) (37 "percent" 600 622 15 -81 518) (38 "ampersand" 600 543 15 -63 538) (39 "quoteright" 600 562 -328 -213 376) (40 "parenleft" 600 622 108 -269 440) (41 "parenright" 600 622 108 -160 331) (42 "asterisk" 600 607 -257 -116 484) (43 "plus" 600 470 -44 -80 520) (44 "comma" 600 122 112 -181 344) (45 "hyphen" 600 285 -231 -103 497) (46 "period" 600 109 15 -229 371) (47 "slash" 600 629 80 -125 475) (48 "zero" 600 622 15 -106 494) (49 "one" 600 622 0 -96 505) (50 "two" 600 622 0 -70 471) (51 "three" 600 622 15 -75 466) (52 "four" 600 622 0 -78 500) (53 "five" 600 607 15 -92 497) (54 "six" 600 622 15 -111 497) (55 "seven" 600 607 0 -82 483) (56 "eight" 600 622 15 -102 498) (57 "nine" 600 622 15 -96 489) (58 "colon" 600 385 15 -229 371) (59 "semicolon" 600 385 112 -181 371) (60 "less" 600 472 -42 -41 519) (61 "equal" 600 376 -138 -80 520) (62 "greater" 600 472 -42 -66 544) (63 "question" 600 572 15 -129 492) (64 "at" 600 622 15 -77 533) (65 "A" 600 562 0 -3 597) (66 "B" 600 562 0 -43 559) (67 "C" 600 580 18 -41 540) (68 "D" 600 562 0 -43 574) (69 "E" 600 562 0 -53 550) (70 "F" 600 562 0 -53 545) (71 "G" 600 580 18 -31 575) (72 "H" 600 562 0 -32 568) (73 "I" 600 562 0 -96 504) (74 "J" 600 562 18 -34 566) (75 "K" 600 562 0 -38 582) (76 "L" 600 562 0 -47 554) (77 "M" 600 562 0 -4 596) (78 "N" 600 562 13 -7 593) (79 "O" 600 580 18 -43 557) (80 "P" 600 562 0 -79 558) (81 "Q" 600 580 138 -43 557) (82 "R" 600 562 0 -38 588) (83 "S" 600 580 20 -72 529) (84 "T" 600 562 0 -38 563) (85 "U" 600 562 18 -17 583) (86 "V" 600 562 13 4 604) (87 "W" 600 562 13 3 603) (88 "X" 600 562 0 -23 577) (89 "Y" 600 562 0 -24 576) (90 "Z" 600 562 0 -86 514) (91 "bracketleft" 600 622 108 -269 442) (92 "backslash" 600 629 80 -118 482) (93 "bracketright" 600 622 108 -158 331) (94 "asciicircum" 600 622 -354 -94 506) (95 "underscore" 600 -75 125 0 600) (96 "quoteleft" 600 562 -328 -224 387) (97 "a" 600 441 15 -53 559) (98 "b" 600 629 15 -14 575) (99 "c" 600 441 15 -66 529) (100 "d" 600 629 15 -45 591) (101 "e" 600 441 15 -66 548) (102 "f" 600 629 0 -114 531) (103 "g" 600 441 157 -45 566) (104 "h" 600 629 0 -18 582) (105 "i" 600 657 0 -95 505) (106 "j" 600 657 157 -82 410) (107 "k" 600 629 0 -43 580) (108 "l" 600 629 0 -95 505) (109 "m" 600 441 0 5 605) (110 "n" 600 441 0 -26 575) (111 "o" 600 441 15 -62 538) (112 "p" 600 441 157 -9 555) (113 "q" 600 441 157 -45 591) (114 "r" 600 441 0 -60 559) (115 "s" 600 441 15 -80 513) (116 "t" 600 561 15 -87 530) (117 "u" 600 426 15 -21 562) (118 "v" 600 426 10 -10 590) (119 "w" 600 426 10 4 604) (120 "x" 600 426 0 -20 580) (121 "y" 600 426 157 -7 592) (122 "z" 600 426 0 -99 502) (123 "braceleft" 600 622 108 -182 437) (124 "bar" 600 750 250 -275 326) (125 "braceright" 600 622 108 -163 418) (126 "asciitilde" 600 320 -197 -63 540) (161 "exclamdown" 600 430 157 -236 364) (162 "cent" 600 614 49 -96 500) (163 "sterling" 600 611 21 -84 521) (164 "fraction" 600 665 57 -92 509) (165 "yen" 600 562 0 -26 574) (166 "florin" 600 622 143 -4 539) (167 "section" 600 580 78 -113 488) (168 "currency" 600 506 -58 -73 527) (169 "quotesingle" 600 562 -328 -259 341) (170 "quotedblleft" 600 562 -328 -143 471) (171 "guillemotleft" 600 446 -70 -37 563) (172 "guilsinglleft" 600 446 -70 -149 451) (173 "guilsinglright" 600 446 -70 -149 451) (174 "fi" 600 629 0 -3 597) (175 "fl" 600 629 0 -3 597) (177 "endash" 600 285 -231 -75 525) (178 "dagger" 600 580 78 -141 459) (179 "daggerdbl" 600 580 78 -141 459) (180 "periodcentered" 600 327 -189 -222 378) (182 "paragraph" 600 562 78 -50 511) (183 "bullet" 600 383 -130 -172 428) (184 "quotesinglbase" 600 100 134 -213 376) (185 "quotedblbase" 600 100 134 -143 457) (186 "quotedblright" 600 562 -328 -143 457) (187 "guillemotright" 600 446 -70 -37 563) (188 "ellipsis" 600 111 15 -37 563) (189 "perthousand" 600 622 15 -3 600) (191 "questiondown" 600 430 157 -108 471) (193 "grave" 600 672 -497 -151 378) (194 "acute" 600 672 -497 -242 469) (195 "circumflex" 600 654 -477 -124 476) (196 "tilde" 600 606 -489 -105 503) (197 "macron" 600 565 -525 -120 480) (198 "breve" 600 609 -501 -153 447) (199 "dotaccent" 600 580 -477 -249 352) (200 "dieresis" 600 595 -492 -148 453) (202 "ring" 600 627 -463 -218 382) (203 "cedilla" 600 10 151 -224 362) (205 "hungarumlaut" 600 672 -497 -133 540) (206 "ogonek" 600 0 151 -227 370) (207 "caron" 600 669 -492 -124 476) (208 "emdash" 600 285 -231 0 600) (225 "AE" 600 562 0 -3 550) (227 "ordfeminine" 600 580 -249 -156 442) (232 "Lslash" 600 562 0 -47 554) (233 "Oslash" 600 629 80 -43 557) (234 "OE" 600 562 0 -7 567) (235 "ordmasculine" 600 580 -249 -157 443) (241 "ae" 600 441 15 -19 570) (245 "dotlessi" 600 426 0 -95 505) (248 "lslash" 600 629 0 -95 505) (249 "oslash" 600 506 80 -62 538) (250 "oe" 600 441 15 -19 559) (251 "germandbls" 600 629 15 -48 588) (-1 "Odieresis" 600 731 18 -43 557) (-1 "logicalnot" 600 369 -108 -87 513) (-1 "minus" 600 283 -232 -80 520) (-1 "merge" 600 436 15 -160 440) (-1 "degree" 600 622 -269 -123 477) (-1 "dectab" 600 227 0 -18 582) (-1 "ll" 600 629 0 -18 567) (-1 "IJ" 600 562 18 -32 583) (-1 "Eacute" 600 793 0 -53 550) (-1 "Ocircumflex" 600 775 18 -43 557) (-1 "ucircumflex" 600 654 15 -21 562) (-1 "left" 600 348 -68 -70 530) (-1 "threesuperior" 600 622 -240 -155 406) (-1 "up" 600 437 0 -160 440) (-1 "multiply" 600 470 -43 -87 515) (-1 "Scaron" 600 805 20 -72 529) (-1 "tab" 600 562 0 -19 581) (-1 "Ucircumflex" 600 775 18 -17 583) (-1 "divide" 600 467 -48 -87 513) (-1 "Acircumflex" 600 775 0 -3 597) (-1 "eacute" 600 672 15 -66 548) (-1 "uacute" 600 672 15 -21 562) (-1 "Aacute" 600 793 0 -3 597) (-1 "copyright" 600 580 18 0 600) (-1 "twosuperior" 600 622 -249 -177 424) (-1 "Ecircumflex" 600 775 0 -53 550) (-1 "ntilde" 600 606 0 -26 575) (-1 "down" 600 426 15 -160 440) (-1 "center" 600 580 -14 -40 560) (-1 "onesuperior" 600 622 -249 -172 428) (-1 "ij" 600 657 157 -37 490) (-1 "edieresis" 600 595 15 -66 548) (-1 "graybox" 600 599 0 -76 525) (-1 "odieresis" 600 595 15 -62 538) (-1 "Ograve" 600 793 18 -43 557) (-1 "threequarters" 600 666 56 -8 593) (-1 "plusminus" 600 558 -44 -87 513) (-1 "prescription" 600 562 15 -27 577) (-1 "eth" 600 629 15 -62 538) (-1 "largebullet" 600 297 -220 -261 339) (-1 "egrave" 600 672 15 -66 548) (-1 "ccedilla" 600 441 151 -66 529) (-1 "notegraphic" 600 572 15 -136 464) (-1 "Udieresis" 600 731 18 -17 583) (-1 "Gcaron" 600 805 18 -31 575) (-1 "arrowdown" 600 608 15 -116 484) (-1 "format" 600 607 157 -5 56) (-1 "Otilde" 600 732 18 -43 557) (-1 "Idieresis" 600 731 0 -96 504) (-1 "adieresis" 600 595 15 -53 559) (-1 "ecircumflex" 600 654 15 -66 548) (-1 "Eth" 600 562 0 -30 574) (-1 "onequarter" 600 665 57 0 600) (-1 "LL" 600 562 0 -8 592) (-1 "agrave" 600 672 15 -53 559) (-1 "Zcaron" 600 805 0 -86 514) (-1 "Scedilla" 600 580 151 -72 529) (-1 "Idot" 600 716 0 -96 504) (-1 "Iacute" 600 793 0 -96 504) (-1 "indent" 600 348 -68 -70 530) (-1 "Ugrave" 600 793 18 -17 583) (-1 "scaron" 600 669 15 -80 513) (-1 "overscore" 600 629 -579 0 600) (-1 "Aring" 600 753 0 -3 597) (-1 "Ccedilla" 600 580 151 -41 540) (-1 "Igrave" 600 793 0 -96 504) (-1 "brokenbar" 600 675 175 -275 326) (-1 "Oacute" 600 793 18 -43 557) (-1 "otilde" 600 606 15 -62 538) (-1 "Yacute" 600 793 0 -24 576) (-1 "lira" 600 611 21 -73 521) (-1 "Icircumflex" 600 775 0 -96 504) (-1 "Atilde" 600 732 0 -3 597) (-1 "Uacute" 600 793 18 -17 583) (-1 "Ydieresis" 600 731 0 -24 576) (-1 "ydieresis" 600 595 157 -7 592) (-1 "idieresis" 600 595 0 -95 505) (-1 "Adieresis" 600 731 0 -3 597) (-1 "mu" 600 426 157 -21 562) (-1 "trademark" 600 562 -263 23 623) (-1 "oacute" 600 672 15 -62 538) (-1 "acircumflex" 600 654 15 -53 559) (-1 "Agrave" 600 793 0 -3 597) (-1 "return" 600 562 0 -19 581) (-1 "atilde" 600 606 15 -53 559) (-1 "square" 600 562 0 -19 581) (-1 "registered" 600 580 18 0 600) (-1 "stop" 600 562 0 -19 581) (-1 "udieresis" 600 595 15 -21 562) (-1 "arrowup" 600 623 0 -116 484) (-1 "igrave" 600 672 0 -95 505) (-1 "Edieresis" 600 731 0 -53 550) (-1 "zcaron" 600 669 0 -99 502) (-1 "arrowboth" 600 483 -115 28 628) (-1 "gcaron" 600 669 157 -45 566) (-1 "arrowleft" 600 483 -115 24 624) (-1 "aacute" 600 672 15 -53 559) (-1 "ocircumflex" 600 654 15 -62 538) (-1 "scedilla" 600 441 151 -80 513) (-1 "ograve" 600 672 15 -62 538) (-1 "onehalf" 600 665 57 0 611) (-1 "ugrave" 600 672 15 -21 562) (-1 "Ntilde" 600 732 13 -7 593) (-1 "iacute" 600 672 0 -95 505) (-1 "arrowright" 600 483 -115 24 624) (-1 "Thorn" 600 562 0 -79 538) (-1 "Egrave" 600 793 0 -53 550) (-1 "thorn" 600 629 157 6 555) (-1 "aring" 600 627 15 -53 559) (-1 "yacute" 600 672 157 -7 592) (-1 "icircumflex" 600 654 0 -94 505))) (define-font-metrics '"Courier-Oblique" '629 '157 '-12 '((32 "space" 600 0 0 0 0) (33 "exclam" 600 572 15 -243 464) (34 "quotedbl" 600 562 -328 -273 532) (35 "numbersign" 600 639 32 -133 596) (36 "dollar" 600 662 126 -108 596) (37 "percent" 600 622 15 -134 599) (38 "ampersand" 600 543 15 -87 580) (39 "quoteright" 600 562 -328 -283 495) (40 "parenleft" 600 622 108 -313 572) (41 "parenright" 600 622 108 -137 396) (42 "asterisk" 600 607 -257 -212 580) (43 "plus" 600 470 -44 -129 580) (44 "comma" 600 122 112 -157 370) (45 "hyphen" 600 285 -231 -152 558) (46 "period" 600 109 15 -238 382) (47 "slash" 600 629 80 -112 604) (48 "zero" 600 622 15 -154 575) (49 "one" 600 622 0 -98 515) (50 "two" 600 622 0 -70 568) (51 "three" 600 622 15 -82 538) (52 "four" 600 622 0 -108 541) (53 "five" 600 607 15 -99 589) (54 "six" 600 622 15 -155 629) (55 "seven" 600 607 0 -182 612) (56 "eight" 600 622 15 -132 588) (57 "nine" 600 622 15 -93 574) (58 "colon" 600 385 15 -238 441) (59 "semicolon" 600 385 112 -157 441) (60 "less" 600 472 -42 -96 610) (61 "equal" 600 376 -138 -109 600) (62 "greater" 600 472 -42 -85 599) (63 "question" 600 572 15 -222 583) (64 "at" 600 622 15 -127 582) (65 "A" 600 562 0 -3 607) (66 "B" 600 562 0 -43 616) (67 "C" 600 580 18 -93 655) (68 "D" 600 562 0 -43 645) (69 "E" 600 562 0 -53 660) (70 "F" 600 562 0 -53 660) (71 "G" 600 580 18 -83 645) (72 "H" 600 562 0 -32 687) (73 "I" 600 562 0 -96 623) (74 "J" 600 562 18 -52 685) (75 "K" 600 562 0 -38 671) (76 "L" 600 562 0 -47 607) (77 "M" 600 562 0 -4 715) (78 "N" 600 562 13 -7 712) (79 "O" 600 580 18 -94 625) (80 "P" 600 562 0 -79 644) (81 "Q" 600 580 138 -95 625) (82 "R" 600 562 0 -38 598) (83 "S" 600 580 20 -76 650) (84 "T" 600 562 0 -108 665) (85 "U" 600 562 18 -125 702) (86 "V" 600 562 13 -105 723) (87 "W" 600 562 13 -106 722) (88 "X" 600 562 0 -23 675) (89 "Y" 600 562 0 -133 695) (90 "Z" 600 562 0 -86 610) (91 "bracketleft" 600 622 108 -246 574) (92 "backslash" 600 629 80 -249 468) (93 "bracketright" 600 622 108 -135 463) (94 "asciicircum" 600 622 -354 -175 587) (95 "underscore" 600 -75 125 27 584) (96 "quoteleft" 600 562 -328 -343 457) (97 "a" 600 441 15 -76 569) (98 "b" 600 629 15 -29 625) (99 "c" 600 441 15 -106 608) (100 "d" 600 629 15 -85 640) (101 "e" 600 441 15 -106 598) (102 "f" 600 629 0 -114 662) (103 "g" 600 441 157 -61 657) (104 "h" 600 629 0 -33 592) (105 "i" 600 657 0 -95 515) (106 "j" 600 657 157 -52 550) (107 "k" 600 629 0 -58 633) (108 "l" 600 629 0 -95 515) (109 "m" 600 441 0 5 615) (110 "n" 600 441 0 -26 585) (111 "o" 600 441 15 -102 588) (112 "p" 600 441 157 24 605) (113 "q" 600 441 157 -85 682) (114 "r" 600 441 0 -60 636) (115 "s" 600 441 15 -78 584) (116 "t" 600 561 15 -167 561) (117 "u" 600 426 15 -101 572) (118 "v" 600 426 10 -90 681) (119 "w" 600 426 10 -76 695) (120 "x" 600 426 0 -20 655) (121 "y" 600 426 157 4 683) (122 "z" 600 426 0 -99 593) (123 "braceleft" 600 622 108 -233 569) (124 "bar" 600 750 250 -222 485) (125 "braceright" 600 622 108 -140 477) (126 "asciitilde" 600 320 -197 -116 600) (161 "exclamdown" 600 430 157 -225 445) (162 "cent" 600 614 49 -151 588) (163 "sterling" 600 611 21 -124 621) (164 "fraction" 600 665 57 -84 646) (165 "yen" 600 562 0 -120 693) (166 "florin" 600 622 143 26 671) (167 "section" 600 580 78 -104 590) (168 "currency" 600 506 -58 -94 628) (169 "quotesingle" 600 562 -328 -345 460) (170 "quotedblleft" 600 562 -328 -262 541) (171 "guillemotleft" 600 446 -70 -92 652) (172 "guilsinglleft" 600 446 -70 -204 540) (173 "guilsinglright" 600 446 -70 -170 506) (174 "fi" 600 629 0 -3 619) (175 "fl" 600 629 0 -3 619) (177 "endash" 600 285 -231 -124 586) (178 "dagger" 600 580 78 -217 546) (179 "daggerdbl" 600 580 78 -163 546) (180 "periodcentered" 600 327 -189 -275 434) (182 "paragraph" 600 562 78 -100 630) (183 "bullet" 600 383 -130 -224 485) (184 "quotesinglbase" 600 100 134 -185 397) (185 "quotedblbase" 600 100 134 -115 478) (186 "quotedblright" 600 562 -328 -213 576) (187 "guillemotright" 600 446 -70 -58 618) (188 "ellipsis" 600 111 15 -46 575) (189 "perthousand" 600 622 15 -59 627) (191 "questiondown" 600 430 157 -105 466) (193 "grave" 600 672 -497 -294 484) (194 "acute" 600 672 -497 -348 612) (195 "circumflex" 600 654 -477 -229 581) (196 "tilde" 600 606 -489 -212 629) (197 "macron" 600 565 -525 -232 600) (198 "breve" 600 609 -501 -279 576) (199 "dotaccent" 600 580 -477 -360 466) (200 "dieresis" 600 595 -492 -262 570) (202 "ring" 600 627 -463 -332 500) (203 "cedilla" 600 10 151 -197 344) (205 "hungarumlaut" 600 672 -497 -239 683) (206 "ogonek" 600 0 151 -207 348) (207 "caron" 600 669 -492 -262 614) (208 "emdash" 600 285 -231 -49 661) (225 "AE" 600 562 0 -3 655) (227 "ordfeminine" 600 580 -249 -209 512) (232 "Lslash" 600 562 0 -47 607) (233 "Oslash" 600 629 80 -94 625) (234 "OE" 600 562 0 -59 672) (235 "ordmasculine" 600 580 -249 -210 535) (241 "ae" 600 441 15 -41 626) (245 "dotlessi" 600 426 0 -95 515) (248 "lslash" 600 629 0 -95 583) (249 "oslash" 600 506 80 -102 588) (250 "oe" 600 441 15 -54 615) (251 "germandbls" 600 629 15 -48 617) (-1 "Odieresis" 600 731 18 -94 625) (-1 "logicalnot" 600 369 -108 -155 591) (-1 "minus" 600 283 -232 -129 580) (-1 "merge" 600 436 15 -187 503) (-1 "degree" 600 622 -269 -214 576) (-1 "dectab" 600 227 0 -18 593) (-1 "ll" 600 629 0 -33 616) (-1 "IJ" 600 562 18 -32 702) (-1 "Eacute" 600 793 0 -53 668) (-1 "Ocircumflex" 600 775 18 -94 625) (-1 "ucircumflex" 600 654 15 -101 572) (-1 "left" 600 348 -68 -114 580) (-1 "threesuperior" 600 622 -240 -213 501) (-1 "up" 600 437 0 -223 503) (-1 "multiply" 600 470 -43 -103 607) (-1 "Scaron" 600 805 20 -76 673) (-1 "tab" 600 562 0 -19 641) (-1 "Ucircumflex" 600 775 18 -125 702) (-1 "divide" 600 467 -48 -136 573) (-1 "Acircumflex" 600 775 0 -3 607) (-1 "eacute" 600 672 15 -106 612) (-1 "uacute" 600 672 15 -101 602) (-1 "Aacute" 600 793 0 -3 658) (-1 "copyright" 600 580 18 -53 667) (-1 "twosuperior" 600 622 -249 -230 535) (-1 "Ecircumflex" 600 775 0 -53 660) (-1 "ntilde" 600 606 0 -26 629) (-1 "down" 600 426 15 -187 467) (-1 "center" 600 580 -14 -103 623) (-1 "onesuperior" 600 622 -249 -231 491) (-1 "ij" 600 657 157 -37 630) (-1 "edieresis" 600 595 15 -106 598) (-1 "graybox" 600 599 0 -76 652) (-1 "odieresis" 600 595 15 -102 588) (-1 "Ograve" 600 793 18 -94 625) (-1 "threequarters" 600 666 56 -73 659) (-1 "plusminus" 600 558 -44 -96 594) (-1 "prescription" 600 562 15 -27 617) (-1 "eth" 600 629 15 -102 639) (-1 "largebullet" 600 297 -220 -315 395) (-1 "egrave" 600 672 15 -106 598) (-1 "ccedilla" 600 441 151 -106 614) (-1 "notegraphic" 600 572 15 -143 564) (-1 "Udieresis" 600 731 18 -125 702) (-1 "Gcaron" 600 805 18 -83 645) (-1 "arrowdown" 600 608 15 -152 520) (-1 "format" 600 607 157 28 185) (-1 "Otilde" 600 732 18 -94 656) (-1 "Idieresis" 600 731 0 -96 623) (-1 "adieresis" 600 595 15 -76 570) (-1 "ecircumflex" 600 654 15 -106 598) (-1 "Eth" 600 562 0 -43 645) (-1 "onequarter" 600 665 57 -65 674) (-1 "LL" 600 562 0 -8 647) (-1 "agrave" 600 672 15 -76 569) (-1 "Zcaron" 600 805 0 -86 643) (-1 "Scedilla" 600 580 151 -76 650) (-1 "Idot" 600 716 0 -96 623) (-1 "Iacute" 600 793 0 -96 638) (-1 "indent" 600 348 -68 -108 574) (-1 "Ugrave" 600 793 18 -125 702) (-1 "scaron" 600 669 15 -78 614) (-1 "overscore" 600 629 -579 -123 734) (-1 "Aring" 600 753 0 -3 607) (-1 "Ccedilla" 600 580 151 -93 658) (-1 "Igrave" 600 793 0 -96 623) (-1 "brokenbar" 600 675 175 -238 469) (-1 "Oacute" 600 793 18 -94 638) (-1 "otilde" 600 606 15 -102 629) (-1 "Yacute" 600 793 0 -133 695) (-1 "lira" 600 611 21 -118 621) (-1 "Icircumflex" 600 775 0 -96 623) (-1 "Atilde" 600 732 0 -3 656) (-1 "Uacute" 600 793 18 -125 702) (-1 "Ydieresis" 600 731 0 -133 695) (-1 "ydieresis" 600 595 157 4 683) (-1 "idieresis" 600 595 0 -95 540) (-1 "Adieresis" 600 731 0 -3 607) (-1 "mu" 600 426 157 -72 572) (-1 "trademark" 600 562 -263 -75 742) (-1 "oacute" 600 672 15 -102 612) (-1 "acircumflex" 600 654 15 -76 581) (-1 "Agrave" 600 793 0 -3 607) (-1 "return" 600 562 0 -79 700) (-1 "atilde" 600 606 15 -76 629) (-1 "square" 600 562 0 -19 700) (-1 "registered" 600 580 18 -53 667) (-1 "stop" 600 562 0 -19 700) (-1 "udieresis" 600 595 15 -101 572) (-1 "arrowup" 600 623 0 -209 577) (-1 "igrave" 600 672 0 -95 515) (-1 "Edieresis" 600 731 0 -53 660) (-1 "zcaron" 600 669 0 -99 624) (-1 "arrowboth" 600 483 -115 -36 692) (-1 "gcaron" 600 669 157 -61 657) (-1 "arrowleft" 600 483 -115 -40 693) (-1 "aacute" 600 672 15 -76 612) (-1 "ocircumflex" 600 654 15 -102 588) (-1 "scedilla" 600 441 151 -78 584) (-1 "ograve" 600 672 15 -102 588) (-1 "onehalf" 600 665 57 -65 669) (-1 "ugrave" 600 672 15 -101 572) (-1 "Ntilde" 600 732 13 -7 712) (-1 "iacute" 600 672 0 -95 612) (-1 "arrowright" 600 483 -115 -34 688) (-1 "Thorn" 600 562 0 -79 606) (-1 "Egrave" 600 793 0 -53 660) (-1 "thorn" 600 629 157 24 605) (-1 "aring" 600 627 15 -76 569) (-1 "yacute" 600 672 157 4 683) (-1 "icircumflex" 600 654 0 -95 551))) (define-font-metrics '"Courier-Bold" '626 '142 '0 '((32 "space" 600 0 0 0 0) (33 "exclam" 600 572 15 -202 398) (34 "quotedbl" 600 562 -277 -135 465) (35 "numbersign" 600 651 45 -56 544) (36 "dollar" 600 666 126 -82 519) (37 "percent" 600 616 15 -5 595) (38 "ampersand" 600 543 15 -36 546) (39 "quoteright" 600 562 -277 -171 423) (40 "parenleft" 600 616 102 -219 461) (41 "parenright" 600 616 102 -139 381) (42 "asterisk" 600 601 -219 -91 509) (43 "plus" 600 478 -39 -71 529) (44 "comma" 600 174 111 -123 393) (45 "hyphen" 600 313 -203 -100 500) (46 "period" 600 171 15 -192 408) (47 "slash" 600 626 77 -98 502) (48 "zero" 600 616 15 -87 513) (49 "one" 600 616 0 -81 539) (50 "two" 600 616 0 -61 499) (51 "three" 600 616 15 -63 501) (52 "four" 600 616 0 -53 507) (53 "five" 600 601 15 -70 521) (54 "six" 600 616 15 -90 521) (55 "seven" 600 601 0 -55 494) (56 "eight" 600 616 15 -83 517) (57 "nine" 600 616 15 -79 510) (58 "colon" 600 425 15 -191 407) (59 "semicolon" 600 425 111 -123 408) (60 "less" 600 501 -15 -66 523) (61 "equal" 600 398 -118 -71 529) (62 "greater" 600 501 -15 -77 534) (63 "question" 600 580 14 -98 501) (64 "at" 600 616 15 -16 584) (65 "A" 600 562 0 9 609) (66 "B" 600 562 0 -30 573) (67 "C" 600 580 18 -22 560) (68 "D" 600 562 0 -30 594) (69 "E" 600 562 0 -25 560) (70 "F" 600 562 0 -39 570) (71 "G" 600 580 18 -22 594) (72 "H" 600 562 0 -20 580) (73 "I" 600 562 0 -77 523) (74 "J" 600 562 18 -37 601) (75 "K" 600 562 0 -21 599) (76 "L" 600 562 0 -39 578) (77 "M" 600 562 0 2 602) (78 "N" 600 562 12 -8 610) (79 "O" 600 580 18 -22 578) (80 "P" 600 562 0 -48 559) (81 "Q" 600 580 138 -32 578) (82 "R" 600 562 0 -24 599) (83 "S" 600 582 22 -47 553) (84 "T" 600 562 0 -21 579) (85 "U" 600 562 18 -4 596) (86 "V" 600 562 0 13 613) (87 "W" 600 562 0 18 618) (88 "X" 600 562 0 -12 588) (89 "Y" 600 562 0 -12 589) (90 "Z" 600 562 0 -62 539) (91 "bracketleft" 600 616 102 -245 475) (92 "backslash" 600 626 77 -99 503) (93 "bracketright" 600 616 102 -125 355) (94 "asciicircum" 600 616 -250 -108 492) (95 "underscore" 600 -75 125 0 600) (96 "quoteleft" 600 562 -277 -178 428) (97 "a" 600 454 15 -35 570) (98 "b" 600 626 15 0 584) (99 "c" 600 459 15 -40 545) (100 "d" 600 626 15 -20 591) (101 "e" 600 454 15 -40 563) (102 "f" 600 626 0 -83 547) (103 "g" 600 454 146 -30 580) (104 "h" 600 626 0 -5 592) (105 "i" 600 658 0 -77 523) (106 "j" 600 658 146 -63 440) (107 "k" 600 626 0 -20 585) (108 "l" 600 626 0 -77 523) (109 "m" 600 454 0 22 626) (110 "n" 600 454 0 -18 592) (111 "o" 600 454 15 -30 570) (112 "p" 600 454 142 1 570) (113 "q" 600 454 142 -20 591) (114 "r" 600 454 0 -47 580) (115 "s" 600 459 17 -68 535) (116 "t" 600 562 15 -47 532) (117 "u" 600 439 15 1 569) (118 "v" 600 439 0 1 601) (119 "w" 600 439 0 18 618) (120 "x" 600 439 0 -6 594) (121 "y" 600 439 142 4 601) (122 "z" 600 439 0 -81 520) (123 "braceleft" 600 616 102 -160 464) (124 "bar" 600 750 250 -255 345) (125 "braceright" 600 616 102 -136 440) (126 "asciitilde" 600 356 -153 -71 530) (161 "exclamdown" 600 449 146 -202 398) (162 "cent" 600 614 49 -66 518) (163 "sterling" 600 611 28 -72 558) (164 "fraction" 600 661 60 -25 576) (165 "yen" 600 562 0 -10 590) (166 "florin" 600 616 131 30 572) (167 "section" 600 580 70 -83 517) (168 "currency" 600 517 -49 -54 546) (169 "quotesingle" 600 562 -277 -227 373) (170 "quotedblleft" 600 562 -277 -71 535) (171 "guillemotleft" 600 446 -70 -8 553) (172 "guilsinglleft" 600 446 -70 -141 459) (173 "guilsinglright" 600 446 -70 -141 459) (174 "fi" 600 626 0 -12 593) (175 "fl" 600 626 0 -12 593) (177 "endash" 600 313 -203 -65 535) (178 "dagger" 600 580 70 -106 494) (179 "daggerdbl" 600 580 70 -106 494) (180 "periodcentered" 600 351 -165 -196 404) (182 "paragraph" 600 580 70 -6 576) (183 "bullet" 600 430 -132 -140 460) (184 "quotesinglbase" 600 143 142 -175 427) (185 "quotedblbase" 600 143 142 -65 529) (186 "quotedblright" 600 562 -277 -61 525) (187 "guillemotright" 600 446 -70 -47 592) (188 "ellipsis" 600 116 15 -26 574) (189 "perthousand" 600 616 15 113 713) (191 "questiondown" 600 449 146 -99 502) (193 "grave" 600 661 -508 -132 395) (194 "acute" 600 661 -508 -205 468) (195 "circumflex" 600 657 -483 -103 497) (196 "tilde" 600 636 -493 -89 512) (197 "macron" 600 585 -505 -88 512) (198 "breve" 600 631 -468 -83 517) (199 "dotaccent" 600 625 -485 -230 370) (200 "dieresis" 600 625 -485 -128 472) (202 "ring" 600 678 -481 -198 402) (203 "cedilla" 600 0 206 -205 387) (205 "hungarumlaut" 600 661 -488 -68 588) (206 "ogonek" 600 0 199 -169 367) (207 "caron" 600 667 -493 -103 497) (208 "emdash" 600 313 -203 10 610) (225 "AE" 600 562 0 29 602) (227 "ordfeminine" 600 580 -196 -147 453) (232 "Lslash" 600 562 0 -39 578) (233 "Oslash" 600 584 22 -22 578) (234 "OE" 600 562 0 25 595) (235 "ordmasculine" 600 580 -196 -147 453) (241 "ae" 600 454 15 4 601) (245 "dotlessi" 600 439 0 -77 523) (248 "lslash" 600 626 0 -77 523) (249 "oslash" 600 463 24 -30 570) (250 "oe" 600 454 15 18 611) (251 "germandbls" 600 626 15 -22 596) (-1 "Odieresis" 600 748 18 -22 578) (-1 "logicalnot" 600 413 -103 -71 529) (-1 "minus" 600 313 -203 -71 529) (-1 "merge" 600 487 15 -137 464) (-1 "degree" 600 616 -243 -86 474) (-1 "dectab" 600 320 0 -8 592) (-1 "ll" 600 626 0 12 600) (-1 "IJ" 600 562 18 8 622) (-1 "Eacute" 600 784 0 -25 560) (-1 "Ocircumflex" 600 780 18 -22 578) (-1 "ucircumflex" 600 657 15 1 569) (-1 "left" 600 371 -44 -65 535) (-1 "threesuperior" 600 616 -222 -138 433) (-1 "up" 600 447 0 -136 463) (-1 "multiply" 600 478 -39 -81 520) (-1 "Scaron" 600 790 22 -47 553) (-1 "tab" 600 562 0 -19 581) (-1 "Ucircumflex" 600 780 18 -4 596) (-1 "divide" 600 500 -16 -71 529) (-1 "Acircumflex" 600 780 0 9 609) (-1 "eacute" 600 661 15 -40 563) (-1 "uacute" 600 661 15 1 569) (-1 "Aacute" 600 784 0 9 609) (-1 "copyright" 600 580 18 0 600) (-1 "twosuperior" 600 616 -230 -143 436) (-1 "Ecircumflex" 600 780 0 -25 560) (-1 "ntilde" 600 636 0 -18 592) (-1 "down" 600 439 15 -137 464) (-1 "center" 600 580 -14 -40 560) (-1 "onesuperior" 600 616 -230 -153 447) (-1 "ij" 600 658 146 -6 574) (-1 "edieresis" 600 625 15 -40 563) (-1 "graybox" 600 599 0 -76 525) (-1 "odieresis" 600 625 15 -30 570) (-1 "Ograve" 600 784 18 -22 578) (-1 "threequarters" 600 661 60 47 648) (-1 "plusminus" 600 515 -24 -71 529) (-1 "prescription" 600 562 15 -24 599) (-1 "eth" 600 626 27 -58 543) (-1 "largebullet" 600 333 -229 -248 352) (-1 "egrave" 600 661 15 -40 563) (-1 "ccedilla" 600 459 206 -40 545) (-1 "notegraphic" 600 572 15 -77 523) (-1 "Udieresis" 600 748 18 -4 596) (-1 "Gcaron" 600 790 18 -22 594) (-1 "arrowdown" 600 608 15 -144 456) (-1 "format" 600 601 146 -5 115) (-1 "Otilde" 600 759 18 -22 578) (-1 "Idieresis" 600 748 0 -77 523) (-1 "adieresis" 600 625 15 -35 570) (-1 "ecircumflex" 600 657 15 -40 563) (-1 "Eth" 600 562 0 -30 594) (-1 "onequarter" 600 661 60 56 656) (-1 "LL" 600 562 0 45 645) (-1 "agrave" 600 661 15 -35 570) (-1 "Zcaron" 600 790 0 -62 539) (-1 "Scedilla" 600 582 206 -47 553) (-1 "Idot" 600 748 0 -77 523) (-1 "Iacute" 600 784 0 -77 523) (-1 "indent" 600 372 -45 -65 535) (-1 "Ugrave" 600 784 18 -4 596) (-1 "scaron" 600 667 17 -68 535) (-1 "overscore" 600 629 -579 0 600) (-1 "Aring" 600 801 0 9 609) (-1 "Ccedilla" 600 580 206 -22 560) (-1 "Igrave" 600 784 0 -77 523) (-1 "brokenbar" 600 675 175 -255 345) (-1 "Oacute" 600 784 18 -22 578) (-1 "otilde" 600 636 15 -30 570) (-1 "Yacute" 600 784 0 -12 589) (-1 "lira" 600 611 28 -72 558) (-1 "Icircumflex" 600 780 0 -77 523) (-1 "Atilde" 600 759 0 9 609) (-1 "Uacute" 600 784 18 -4 596) (-1 "Ydieresis" 600 748 0 -12 589) (-1 "ydieresis" 600 625 142 4 601) (-1 "idieresis" 600 625 0 -77 523) (-1 "Adieresis" 600 748 0 9 609) (-1 "mu" 600 439 142 1 569) (-1 "trademark" 600 562 -230 9 749) (-1 "oacute" 600 661 15 -30 570) (-1 "acircumflex" 600 657 15 -35 570) (-1 "Agrave" 600 784 0 9 609) (-1 "return" 600 562 0 -19 581) (-1 "atilde" 600 636 15 -35 570) (-1 "square" 600 562 0 -19 581) (-1 "registered" 600 580 18 0 600) (-1 "stop" 600 562 0 -19 581) (-1 "udieresis" 600 625 15 1 569) (-1 "arrowup" 600 626 -3 -144 456) (-1 "igrave" 600 661 0 -77 523) (-1 "Edieresis" 600 748 0 -25 560) (-1 "zcaron" 600 667 0 -81 520) (-1 "arrowboth" 600 455 -143 24 624) (-1 "gcaron" 600 667 146 -30 580) (-1 "arrowleft" 600 455 -143 24 634) (-1 "aacute" 600 661 15 -35 570) (-1 "ocircumflex" 600 657 15 -30 570) (-1 "scedilla" 600 459 206 -68 535) (-1 "ograve" 600 661 15 -30 570) (-1 "onehalf" 600 661 60 47 648) (-1 "ugrave" 600 661 15 1 569) (-1 "Ntilde" 600 759 12 -8 610) (-1 "iacute" 600 661 0 -77 523) (-1 "arrowright" 600 455 -143 34 624) (-1 "Thorn" 600 562 0 -48 557) (-1 "Egrave" 600 784 0 -25 560) (-1 "thorn" 600 626 142 14 570) (-1 "aring" 600 678 15 -35 570) (-1 "yacute" 600 661 142 4 601) (-1 "icircumflex" 600 657 0 -63 523))) (define-font-metrics '"Courier-BoldOblique" '626 '142 '-12 '((32 "space" 600 0 0 0 0) (33 "exclam" 600 572 15 -216 495) (34 "quotedbl" 600 562 -277 -212 584) (35 "numbersign" 600 651 45 -88 640) (36 "dollar" 600 666 126 -87 629) (37 "percent" 600 616 15 -102 624) (38 "ampersand" 600 543 15 -62 594) (39 "quoteright" 600 562 -277 -230 542) (40 "parenleft" 600 616 102 -266 592) (41 "parenright" 600 616 102 -117 444) (42 "asterisk" 600 601 -219 -179 597) (43 "plus" 600 478 -39 -114 596) (44 "comma" 600 174 111 -99 430) (45 "hyphen" 600 313 -203 -143 567) (46 "period" 600 171 15 -207 426) (47 "slash" 600 626 77 -91 626) (48 "zero" 600 616 15 -136 592) (49 "one" 600 616 0 -93 561) (50 "two" 600 616 0 -61 593) (51 "three" 600 616 15 -72 571) (52 "four" 600 616 0 -82 558) (53 "five" 600 601 15 -77 621) (54 "six" 600 616 15 -136 652) (55 "seven" 600 601 0 -147 622) (56 "eight" 600 616 15 -115 604) (57 "nine" 600 616 15 -76 592) (58 "colon" 600 425 15 -206 479) (59 "semicolon" 600 425 111 -99 480) (60 "less" 600 501 -15 -121 612) (61 "equal" 600 398 -118 -96 614) (62 "greater" 600 501 -15 -97 589) (63 "question" 600 580 14 -183 591) (64 "at" 600 616 15 -66 641) (65 "A" 600 562 0 9 631) (66 "B" 600 562 0 -30 629) (67 "C" 600 580 18 -75 674) (68 "D" 600 562 0 -30 664) (69 "E" 600 562 0 -25 669) (70 "F" 600 562 0 -39 683) (71 "G" 600 580 18 -75 674) (72 "H" 600 562 0 -20 699) (73 "I" 600 562 0 -77 642) (74 "J" 600 562 18 -59 720) (75 "K" 600 562 0 -21 691) (76 "L" 600 562 0 -39 635) (77 "M" 600 562 0 2 721) (78 "N" 600 562 12 -8 729) (79 "O" 600 580 18 -74 645) (80 "P" 600 562 0 -48 642) (81 "Q" 600 580 138 -84 636) (82 "R" 600 562 0 -24 617) (83 "S" 600 582 22 -54 672) (84 "T" 600 562 0 -86 678) (85 "U" 600 562 18 -101 715) (86 "V" 600 562 0 -84 732) (87 "W" 600 562 0 -84 737) (88 "X" 600 562 0 -12 689) (89 "Y" 600 562 0 -109 708) (90 "Z" 600 562 0 -62 636) (91 "bracketleft" 600 616 102 -223 606) (92 "backslash" 600 626 77 -223 496) (93 "bracketright" 600 616 102 -103 486) (94 "asciicircum" 600 616 -250 -171 555) (95 "underscore" 600 -75 125 27 584) (96 "quoteleft" 600 562 -277 -297 487) (97 "a" 600 454 15 -62 592) (98 "b" 600 626 15 -13 636) (99 "c" 600 459 15 -81 631) (100 "d" 600 626 15 -61 644) (101 "e" 600 454 15 -81 604) (102 "f" 600 626 0 -83 677) (103 "g" 600 454 146 -41 673) (104 "h" 600 626 0 -18 614) (105 "i" 600 658 0 -77 545) (106 "j" 600 658 146 -37 580) (107 "k" 600 626 0 -33 642) (108 "l" 600 626 0 -77 545) (109 "m" 600 454 0 22 648) (110 "n" 600 454 0 -18 614) (111 "o" 600 454 15 -71 622) (112 "p" 600 454 142 31 622) (113 "q" 600 454 142 -61 684) (114 "r" 600 454 0 -47 654) (115 "s" 600 459 17 -67 607) (116 "t" 600 562 15 -118 566) (117 "u" 600 439 15 -70 591) (118 "v" 600 439 0 -70 694) (119 "w" 600 439 0 -53 711) (120 "x" 600 439 0 -6 670) (121 "y" 600 439 142 20 694) (122 "z" 600 439 0 -81 613) (123 "braceleft" 600 616 102 -204 595) (124 "bar" 600 750 250 -202 504) (125 "braceright" 600 616 102 -114 506) (126 "asciitilde" 600 356 -153 -120 589) (161 "exclamdown" 600 449 146 -197 477) (162 "cent" 600 614 49 -121 604) (163 "sterling" 600 611 28 -107 650) (164 "fraction" 600 661 60 -22 707) (165 "yen" 600 562 0 -98 709) (166 "florin" 600 616 131 56 701) (167 "section" 600 580 70 -74 619) (168 "currency" 600 517 -49 -77 643) (169 "quotesingle" 600 562 -277 -304 492) (170 "quotedblleft" 600 562 -277 -190 594) (171 "guillemotleft" 600 446 -70 -63 638) (172 "guilsinglleft" 600 446 -70 -196 544) (173 "guilsinglright" 600 446 -70 -166 514) (174 "fi" 600 626 0 -12 643) (175 "fl" 600 626 0 -12 643) (177 "endash" 600 313 -203 -108 602) (178 "dagger" 600 580 70 -176 586) (179 "daggerdbl" 600 580 70 -122 586) (180 "periodcentered" 600 351 -165 -249 461) (182 "paragraph" 600 580 70 -61 699) (183 "bullet" 600 430 -132 -197 523) (184 "quotesinglbase" 600 143 142 -145 457) (185 "quotedblbase" 600 143 142 -35 559) (186 "quotedblright" 600 562 -277 -120 644) (187 "guillemotright" 600 446 -70 -72 647) (188 "ellipsis" 600 116 15 -35 586) (189 "perthousand" 600 616 15 44 742) (191 "questiondown" 600 449 146 -101 509) (193 "grave" 600 661 -508 -272 503) (194 "acute" 600 661 -508 -313 608) (195 "circumflex" 600 657 -483 -212 606) (196 "tilde" 600 636 -493 -200 642) (197 "macron" 600 585 -505 -195 636) (198 "breve" 600 631 -468 -217 651) (199 "dotaccent" 600 625 -485 -346 490) (200 "dieresis" 600 625 -485 -244 592) (202 "ring" 600 678 -481 -319 528) (203 "cedilla" 600 0 206 -169 367) (205 "hungarumlaut" 600 661 -488 -172 728) (206 "ogonek" 600 0 199 -144 350) (207 "caron" 600 667 -493 -238 632) (208 "emdash" 600 313 -203 -33 677) (225 "AE" 600 562 0 29 707) (227 "ordfeminine" 600 580 -196 -189 526) (232 "Lslash" 600 562 0 -39 635) (233 "Oslash" 600 584 22 -48 672) (234 "OE" 600 562 0 -26 700) (235 "ordmasculine" 600 580 -196 -189 542) (241 "ae" 600 454 15 -21 651) (245 "dotlessi" 600 439 0 -77 545) (248 "lslash" 600 626 0 -77 578) (249 "oslash" 600 463 24 -55 637) (250 "oe" 600 454 15 -19 661) (251 "germandbls" 600 626 15 -22 628) (-1 "Odieresis" 600 748 18 -74 645) (-1 "logicalnot" 600 413 -103 -135 617) (-1 "minus" 600 313 -203 -114 596) (-1 "merge" 600 487 15 -168 533) (-1 "degree" 600 616 -243 -173 569) (-1 "dectab" 600 320 0 -8 615) (-1 "ll" 600 626 0 -1 653) (-1 "IJ" 600 562 18 8 741) (-1 "Eacute" 600 784 0 -25 669) (-1 "Ocircumflex" 600 780 18 -74 645) (-1 "ucircumflex" 600 657 15 -70 591) (-1 "left" 600 371 -44 -109 589) (-1 "threesuperior" 600 616 -222 -193 525) (-1 "up" 600 447 0 -196 523) (-1 "multiply" 600 478 -39 -105 606) (-1 "Scaron" 600 790 22 -54 672) (-1 "tab" 600 562 0 -19 641) (-1 "Ucircumflex" 600 780 18 -101 715) (-1 "divide" 600 500 -16 -114 596) (-1 "Acircumflex" 600 780 0 9 631) (-1 "eacute" 600 661 15 -81 608) (-1 "uacute" 600 661 15 -70 608) (-1 "Aacute" 600 784 0 9 665) (-1 "copyright" 600 580 18 -53 667) (-1 "twosuperior" 600 616 -230 -192 541) (-1 "Ecircumflex" 600 780 0 -25 669) (-1 "ntilde" 600 636 0 -18 642) (-1 "down" 600 439 15 -168 496) (-1 "center" 600 580 -14 -103 623) (-1 "onesuperior" 600 616 -230 -213 514) (-1 "ij" 600 658 146 -6 714) (-1 "edieresis" 600 625 15 -81 604) (-1 "graybox" 600 599 0 -76 652) (-1 "odieresis" 600 625 15 -71 622) (-1 "Ograve" 600 784 18 -74 645) (-1 "threequarters" 600 661 60 -8 698) (-1 "plusminus" 600 515 -24 -76 614) (-1 "prescription" 600 562 15 -24 632) (-1 "eth" 600 626 27 -93 661) (-1 "largebullet" 600 333 -229 -307 413) (-1 "egrave" 600 661 15 -81 604) (-1 "ccedilla" 600 459 206 -81 631) (-1 "notegraphic" 600 572 15 -91 619) (-1 "Udieresis" 600 748 18 -101 715) (-1 "Gcaron" 600 790 18 -75 674) (-1 "arrowdown" 600 608 15 -174 486) (-1 "format" 600 601 146 26 243) (-1 "Otilde" 600 759 18 -74 668) (-1 "Idieresis" 600 748 0 -77 642) (-1 "adieresis" 600 625 15 -62 592) (-1 "ecircumflex" 600 657 15 -81 606) (-1 "Eth" 600 562 0 -30 664) (-1 "onequarter" 600 661 60 -14 706) (-1 "LL" 600 562 0 45 694) (-1 "agrave" 600 661 15 -62 592) (-1 "Zcaron" 600 790 0 -62 659) (-1 "Scedilla" 600 582 206 -54 672) (-1 "Idot" 600 748 0 -77 642) (-1 "Iacute" 600 784 0 -77 642) (-1 "indent" 600 372 -45 -99 579) (-1 "Ugrave" 600 784 18 -101 715) (-1 "scaron" 600 667 17 -67 632) (-1 "overscore" 600 629 -579 -123 734) (-1 "Aring" 600 801 0 9 631) (-1 "Ccedilla" 600 580 206 -74 674) (-1 "Igrave" 600 784 0 -77 642) (-1 "brokenbar" 600 675 175 -218 488) (-1 "Oacute" 600 784 18 -74 645) (-1 "otilde" 600 636 15 -71 642) (-1 "Yacute" 600 784 0 -109 708) (-1 "lira" 600 611 28 -107 650) (-1 "Icircumflex" 600 780 0 -77 642) (-1 "Atilde" 600 759 0 9 638) (-1 "Uacute" 600 784 18 -101 715) (-1 "Ydieresis" 600 748 0 -109 708) (-1 "ydieresis" 600 625 142 20 694) (-1 "idieresis" 600 625 0 -77 552) (-1 "Adieresis" 600 748 0 9 631) (-1 "mu" 600 439 142 -50 591) (-1 "trademark" 600 562 -230 -86 868) (-1 "oacute" 600 661 15 -71 622) (-1 "acircumflex" 600 657 15 -62 592) (-1 "Agrave" 600 784 0 9 631) (-1 "return" 600 562 0 -79 700) (-1 "atilde" 600 636 15 -62 642) (-1 "square" 600 562 0 -19 700) (-1 "registered" 600 580 18 -53 667) (-1 "stop" 600 562 0 -19 700) (-1 "udieresis" 600 625 15 -70 591) (-1 "arrowup" 600 626 -3 -244 556) (-1 "igrave" 600 661 0 -77 545) (-1 "Edieresis" 600 748 0 -25 669) (-1 "zcaron" 600 667 0 -81 632) (-1 "arrowboth" 600 455 -143 -40 688) (-1 "gcaron" 600 667 146 -41 673) (-1 "arrowleft" 600 455 -143 -40 708) (-1 "aacute" 600 661 15 -62 608) (-1 "ocircumflex" 600 657 15 -71 622) (-1 "scedilla" 600 459 206 -67 607) (-1 "ograve" 600 661 15 -71 622) (-1 "onehalf" 600 661 60 -23 715) (-1 "ugrave" 600 661 15 -70 591) (-1 "Ntilde" 600 759 12 -8 729) (-1 "iacute" 600 661 0 -77 608) (-1 "arrowright" 600 455 -143 -20 688) (-1 "Thorn" 600 562 0 -48 619) (-1 "Egrave" 600 784 0 -25 669) (-1 "thorn" 600 626 142 31 622) (-1 "aring" 600 678 15 -62 592) (-1 "yacute" 600 661 142 20 694) (-1 "icircumflex" 600 657 0 -77 566))) (define-font-metrics '"Helvetica" '718 '207 '0 '((32 "space" 278 0 0 0 0) (33 "exclam" 278 718 0 -90 187) (34 "quotedbl" 355 718 -463 -70 285) (35 "numbersign" 556 688 0 -28 529) (36 "dollar" 556 775 115 -32 520) (37 "percent" 889 703 19 -39 850) (38 "ampersand" 667 718 15 -44 645) (39 "quoteright" 222 718 -463 -53 157) (40 "parenleft" 333 733 207 -68 299) (41 "parenright" 333 733 207 -34 265) (42 "asterisk" 389 718 -431 -39 349) (43 "plus" 584 505 0 -39 545) (44 "comma" 278 106 147 -87 191) (45 "hyphen" 333 322 -232 -44 289) (46 "period" 278 106 0 -87 191) (47 "slash" 278 737 19 17 295) (48 "zero" 556 703 19 -37 519) (49 "one" 556 703 0 -101 359) (50 "two" 556 703 0 -26 507) (51 "three" 556 703 19 -34 522) (52 "four" 556 703 0 -25 523) (53 "five" 556 688 19 -32 514) (54 "six" 556 703 19 -38 518) (55 "seven" 556 688 0 -37 523) (56 "eight" 556 703 19 -38 517) (57 "nine" 556 703 19 -42 514) (58 "colon" 278 516 0 -87 191) (59 "semicolon" 278 516 147 -87 191) (60 "less" 584 495 -11 -48 536) (61 "equal" 584 390 -115 -39 545) (62 "greater" 584 495 -11 -48 536) (63 "question" 556 727 0 -56 492) (64 "at" 1015 737 19 -147 868) (65 "A" 667 718 0 -14 654) (66 "B" 667 718 0 -74 627) (67 "C" 722 737 19 -44 681) (68 "D" 722 718 0 -81 674) (69 "E" 667 718 0 -86 616) (70 "F" 611 718 0 -86 583) (71 "G" 778 737 19 -48 704) (72 "H" 722 718 0 -77 646) (73 "I" 278 718 0 -91 188) (74 "J" 500 718 19 -17 428) (75 "K" 667 718 0 -76 663) (76 "L" 556 718 0 -76 537) (77 "M" 833 718 0 -73 761) (78 "N" 722 718 0 -76 646) (79 "O" 778 737 19 -39 739) (80 "P" 667 718 0 -86 622) (81 "Q" 778 737 56 -39 739) (82 "R" 722 718 0 -88 684) (83 "S" 667 737 19 -49 620) (84 "T" 611 718 0 -14 597) (85 "U" 722 718 19 -79 644) (86 "V" 667 718 0 -20 647) (87 "W" 944 718 0 -16 928) (88 "X" 667 718 0 -19 648) (89 "Y" 667 718 0 -14 653) (90 "Z" 611 718 0 -23 588) (91 "bracketleft" 278 722 196 -63 250) (92 "backslash" 278 737 19 17 295) (93 "bracketright" 278 722 196 -28 215) (94 "asciicircum" 469 688 -264 14 483) (95 "underscore" 556 -75 125 0 556) (96 "quoteleft" 222 725 -470 -65 169) (97 "a" 556 538 15 -36 530) (98 "b" 556 718 15 -58 517) (99 "c" 500 538 15 -30 477) (100 "d" 556 718 15 -35 499) (101 "e" 556 538 15 -40 516) (102 "f" 278 728 0 -14 262) (103 "g" 556 538 220 -40 499) (104 "h" 556 718 0 -65 491) (105 "i" 222 718 0 -67 155) (106 "j" 222 718 210 16 155) (107 "k" 500 718 0 -67 501) (108 "l" 222 718 0 -67 155) (109 "m" 833 538 0 -65 769) (110 "n" 556 538 0 -65 491) (111 "o" 556 538 14 -35 521) (112 "p" 556 538 207 -58 517) (113 "q" 556 538 207 -35 494) (114 "r" 333 538 0 -77 332) (115 "s" 500 538 15 -32 464) (116 "t" 278 669 7 -14 257) (117 "u" 556 523 15 -68 489) (118 "v" 500 523 0 -8 492) (119 "w" 722 523 0 -14 709) (120 "x" 500 523 0 -11 490) (121 "y" 500 523 214 -11 489) (122 "z" 500 523 0 -31 469) (123 "braceleft" 334 722 196 -42 292) (124 "bar" 260 737 19 -94 167) (125 "braceright" 334 722 196 -42 292) (126 "asciitilde" 584 326 -180 -61 523) (161 "exclamdown" 333 523 195 -118 215) (162 "cent" 556 623 115 -51 513) (163 "sterling" 556 718 16 -33 539) (164 "fraction" 167 703 19 166 333) (165 "yen" 556 688 0 -3 553) (166 "florin" 556 737 207 11 501) (167 "section" 556 737 191 -43 512) (168 "currency" 556 603 -99 -28 528) (169 "quotesingle" 191 718 -463 -59 132) (170 "quotedblleft" 333 725 -470 -38 307) (171 "guillemotleft" 556 446 -108 -97 459) (172 "guilsinglleft" 333 446 -108 -88 245) (173 "guilsinglright" 333 446 -108 -88 245) (174 "fi" 500 728 0 -14 434) (175 "fl" 500 728 0 -14 432) (177 "endash" 556 313 -240 0 556) (178 "dagger" 556 718 159 -43 514) (179 "daggerdbl" 556 718 159 -43 514) (180 "periodcentered" 278 315 -190 -77 202) (182 "paragraph" 537 718 173 -18 497) (183 "bullet" 350 517 -202 -18 333) (184 "quotesinglbase" 222 106 149 -53 157) (185 "quotedblbase" 333 106 149 -26 295) (186 "quotedblright" 333 718 -463 -26 295) (187 "guillemotright" 556 446 -108 -97 459) (188 "ellipsis" 1000 106 0 -115 885) (189 "perthousand" 1000 703 19 -7 994) (191 "questiondown" 611 525 201 -91 527) (193 "grave" 333 734 -593 -14 211) (194 "acute" 333 734 -593 -122 319) (195 "circumflex" 333 734 -593 -21 312) (196 "tilde" 333 722 -606 4 337) (197 "macron" 333 684 -627 -10 323) (198 "breve" 333 731 -595 -13 321) (199 "dotaccent" 333 706 -604 -121 212) (200 "dieresis" 333 706 -604 -40 293) (202 "ring" 333 756 -572 -75 259) (203 "cedilla" 333 0 225 -45 259) (205 "hungarumlaut" 333 734 -593 -31 409) (206 "ogonek" 333 0 225 -73 287) (207 "caron" 333 734 -593 -21 312) (208 "emdash" 1000 313 -240 0 1000) (225 "AE" 1000 718 0 -8 951) (227 "ordfeminine" 370 737 -304 -24 346) (232 "Lslash" 556 718 0 20 537) (233 "Oslash" 778 737 19 -39 740) (234 "OE" 1000 737 19 -36 965) (235 "ordmasculine" 365 737 -304 -25 341) (241 "ae" 889 538 15 -36 847) (245 "dotlessi" 278 523 0 -95 183) (248 "lslash" 222 718 0 20 242) (249 "oslash" 611 545 22 -28 537) (250 "oe" 944 538 15 -35 902) (251 "germandbls" 611 728 15 -67 571) (-1 "Zcaron" 611 929 0 -23 588) (-1 "ccedilla" 500 538 225 -30 477) (-1 "ydieresis" 500 706 214 -11 489) (-1 "atilde" 556 722 15 -36 530) (-1 "icircumflex" 278 734 0 6 285) (-1 "threesuperior" 333 703 -270 -5 325) (-1 "ecircumflex" 556 734 15 -40 516) (-1 "thorn" 556 718 207 -58 517) (-1 "egrave" 556 734 15 -40 516) (-1 "twosuperior" 333 703 -281 -4 323) (-1 "eacute" 556 734 15 -40 516) (-1 "otilde" 556 722 14 -35 521) (-1 "Aacute" 667 929 0 -14 654) (-1 "ocircumflex" 556 734 14 -35 521) (-1 "yacute" 500 734 214 -11 489) (-1 "udieresis" 556 706 15 -68 489) (-1 "threequarters" 834 703 19 -45 810) (-1 "acircumflex" 556 734 15 -36 530) (-1 "Eth" 722 718 0 0 674) (-1 "edieresis" 556 706 15 -40 516) (-1 "ugrave" 556 734 15 -68 489) (-1 "trademark" 1000 718 -306 -46 903) (-1 "ograve" 556 734 14 -35 521) (-1 "scaron" 500 734 15 -32 464) (-1 "Idieresis" 278 901 0 -13 266) (-1 "uacute" 556 734 15 -68 489) (-1 "agrave" 556 734 15 -36 530) (-1 "ntilde" 556 722 0 -65 491) (-1 "aring" 556 756 15 -36 530) (-1 "zcaron" 500 734 0 -31 469) (-1 "Icircumflex" 278 929 0 6 285) (-1 "Ntilde" 722 917 0 -76 646) (-1 "ucircumflex" 556 734 15 -68 489) (-1 "Ecircumflex" 667 929 0 -86 616) (-1 "Iacute" 278 929 0 -91 292) (-1 "Ccedilla" 722 737 225 -44 681) (-1 "Odieresis" 778 901 19 -39 739) (-1 "Scaron" 667 929 19 -49 620) (-1 "Edieresis" 667 901 0 -86 616) (-1 "Igrave" 278 929 0 13 188) (-1 "adieresis" 556 706 15 -36 530) (-1 "Ograve" 778 929 19 -39 739) (-1 "Egrave" 667 929 0 -86 616) (-1 "Ydieresis" 667 901 0 -14 653) (-1 "registered" 737 737 19 14 752) (-1 "Otilde" 778 917 19 -39 739) (-1 "onequarter" 834 703 19 -73 756) (-1 "Ugrave" 722 929 19 -79 644) (-1 "Ucircumflex" 722 929 19 -79 644) (-1 "Thorn" 667 718 0 -86 622) (-1 "divide" 584 524 19 -39 545) (-1 "Atilde" 667 917 0 -14 654) (-1 "Uacute" 722 929 19 -79 644) (-1 "Ocircumflex" 778 929 19 -39 739) (-1 "logicalnot" 584 390 -108 -39 545) (-1 "Aring" 667 931 0 -14 654) (-1 "idieresis" 278 706 0 -13 266) (-1 "iacute" 278 734 0 -95 292) (-1 "aacute" 556 734 15 -36 530) (-1 "plusminus" 584 506 0 -39 545) (-1 "multiply" 584 506 0 -39 545) (-1 "Udieresis" 722 901 19 -79 644) (-1 "minus" 584 289 -216 -39 545) (-1 "onesuperior" 333 703 -281 -43 222) (-1 "Eacute" 667 929 0 -86 616) (-1 "Acircumflex" 667 929 0 -14 654) (-1 "copyright" 737 737 19 14 752) (-1 "Agrave" 667 929 0 -14 654) (-1 "odieresis" 556 706 14 -35 521) (-1 "oacute" 556 734 14 -35 521) (-1 "degree" 400 703 -411 -54 346) (-1 "igrave" 278 734 0 13 184) (-1 "mu" 556 523 207 -68 489) (-1 "Oacute" 778 929 19 -39 739) (-1 "eth" 556 737 15 -35 522) (-1 "Adieresis" 667 901 0 -14 654) (-1 "Yacute" 667 929 0 -14 653) (-1 "brokenbar" 260 737 19 -94 167) (-1 "onehalf" 834 703 19 -43 773))) (define-font-metrics '"Helvetica-Oblique" '718 '207 '-12 '((32 "space" 278 0 0 0 0) (33 "exclam" 278 718 0 -90 340) (34 "quotedbl" 355 718 -463 -168 438) (35 "numbersign" 556 688 0 -73 631) (36 "dollar" 556 775 115 -69 617) (37 "percent" 889 703 19 -147 889) (38 "ampersand" 667 718 15 -77 647) (39 "quoteright" 222 718 -463 -151 310) (40 "parenleft" 333 733 207 -108 454) (41 "parenright" 333 733 207 9 337) (42 "asterisk" 389 718 -431 -165 475) (43 "plus" 584 505 0 -85 606) (44 "comma" 278 106 147 -56 214) (45 "hyphen" 333 322 -232 -93 357) (46 "period" 278 106 0 -87 214) (47 "slash" 278 737 19 21 452) (48 "zero" 556 703 19 -93 608) (49 "one" 556 703 0 -207 508) (50 "two" 556 703 0 -26 617) (51 "three" 556 703 19 -75 610) (52 "four" 556 703 0 -61 576) (53 "five" 556 688 19 -68 621) (54 "six" 556 703 19 -91 615) (55 "seven" 556 688 0 -137 669) (56 "eight" 556 703 19 -74 607) (57 "nine" 556 703 19 -82 609) (58 "colon" 278 516 0 -87 301) (59 "semicolon" 278 516 147 -56 301) (60 "less" 584 495 -11 -94 641) (61 "equal" 584 390 -115 -63 628) (62 "greater" 584 495 -11 -50 597) (63 "question" 556 727 0 -161 610) (64 "at" 1015 737 19 -215 965) (65 "A" 667 718 0 -14 654) (66 "B" 667 718 0 -74 712) (67 "C" 722 737 19 -108 782) (68 "D" 722 718 0 -81 764) (69 "E" 667 718 0 -86 762) (70 "F" 611 718 0 -86 736) (71 "G" 778 737 19 -111 799) (72 "H" 722 718 0 -77 799) (73 "I" 278 718 0 -91 341) (74 "J" 500 718 19 -47 581) (75 "K" 667 718 0 -76 808) (76 "L" 556 718 0 -76 555) (77 "M" 833 718 0 -73 914) (78 "N" 722 718 0 -76 799) (79 "O" 778 737 19 -105 826) (80 "P" 667 718 0 -86 737) (81 "Q" 778 737 56 -105 826) (82 "R" 722 718 0 -88 773) (83 "S" 667 737 19 -90 713) (84 "T" 611 718 0 -148 750) (85 "U" 722 718 19 -123 797) (86 "V" 667 718 0 -173 800) (87 "W" 944 718 0 -169 1081) (88 "X" 667 718 0 -19 790) (89 "Y" 667 718 0 -167 806) (90 "Z" 611 718 0 -23 741) (91 "bracketleft" 278 722 196 -21 403) (92 "backslash" 278 737 19 -140 291) (93 "bracketright" 278 722 196 14 368) (94 "asciicircum" 469 688 -264 -42 539) (95 "underscore" 556 -75 125 27 540) (96 "quoteleft" 222 725 -470 -165 323) (97 "a" 556 538 15 -61 559) (98 "b" 556 718 15 -58 584) (99 "c" 500 538 15 -74 553) (100 "d" 556 718 15 -84 652) (101 "e" 556 538 15 -84 578) (102 "f" 278 728 0 -86 416) (103 "g" 556 538 220 -42 610) (104 "h" 556 718 0 -65 573) (105 "i" 222 718 0 -67 308) (106 "j" 222 718 210 60 308) (107 "k" 500 718 0 -67 600) (108 "l" 222 718 0 -67 308) (109 "m" 833 538 0 -65 852) (110 "n" 556 538 0 -65 573) (111 "o" 556 538 14 -83 585) (112 "p" 556 538 207 -14 584) (113 "q" 556 538 207 -84 605) (114 "r" 333 538 0 -77 446) (115 "s" 500 538 15 -63 529) (116 "t" 278 669 7 -102 368) (117 "u" 556 523 15 -94 600) (118 "v" 500 523 0 -119 603) (119 "w" 722 523 0 -125 820) (120 "x" 500 523 0 -11 594) (121 "y" 500 523 214 -15 600) (122 "z" 500 523 0 -31 571) (123 "braceleft" 334 722 196 -92 445) (124 "bar" 260 737 19 -90 324) (125 "braceright" 334 722 196 0 354) (126 "asciitilde" 584 326 -180 -111 580) (161 "exclamdown" 333 523 195 -77 326) (162 "cent" 556 623 115 -95 584) (163 "sterling" 556 718 16 -49 634) (164 "fraction" 167 703 19 170 482) (165 "yen" 556 688 0 -81 699) (166 "florin" 556 737 207 52 654) (167 "section" 556 737 191 -76 584) (168 "currency" 556 603 -99 -60 646) (169 "quotesingle" 191 718 -463 -157 285) (170 "quotedblleft" 333 725 -470 -138 461) (171 "guillemotleft" 556 446 -108 -146 554) (172 "guilsinglleft" 333 446 -108 -137 340) (173 "guilsinglright" 333 446 -108 -111 314) (174 "fi" 500 728 0 -86 587) (175 "fl" 500 728 0 -86 585) (177 "endash" 556 313 -240 -51 623) (178 "dagger" 556 718 159 -135 622) (179 "daggerdbl" 556 718 159 -52 623) (180 "periodcentered" 278 315 -190 -129 257) (182 "paragraph" 537 718 173 -126 650) (183 "bullet" 350 517 -202 -91 413) (184 "quotesinglbase" 222 106 149 -21 180) (185 "quotedblbase" 333 106 149 6 318) (186 "quotedblright" 333 718 -463 -124 448) (187 "guillemotright" 556 446 -108 -120 528) (188 "ellipsis" 1000 106 0 -115 908) (189 "perthousand" 1000 703 19 -88 1029) (191 "questiondown" 611 525 201 -85 534) (193 "grave" 333 734 -593 -170 337) (194 "acute" 333 734 -593 -248 475) (195 "circumflex" 333 734 -593 -147 438) (196 "tilde" 333 722 -606 -125 490) (197 "macron" 333 684 -627 -143 468) (198 "breve" 333 731 -595 -167 476) (199 "dotaccent" 333 706 -604 -249 362) (200 "dieresis" 333 706 -604 -168 443) (202 "ring" 333 756 -572 -214 402) (203 "cedilla" 333 0 225 -2 232) (205 "hungarumlaut" 333 734 -593 -157 565) (206 "ogonek" 333 0 225 -43 249) (207 "caron" 333 734 -593 -177 468) (208 "emdash" 1000 313 -240 -51 1067) (225 "AE" 1000 718 0 -8 1097) (227 "ordfeminine" 370 737 -304 -100 449) (232 "Lslash" 556 718 0 -41 555) (233 "Oslash" 778 737 19 -43 890) (234 "OE" 1000 737 19 -98 1116) (235 "ordmasculine" 365 737 -304 -100 468) (241 "ae" 889 538 15 -61 909) (245 "dotlessi" 278 523 0 -95 294) (248 "lslash" 222 718 0 -41 347) (249 "oslash" 611 545 22 -29 647) (250 "oe" 944 538 15 -83 964) (251 "germandbls" 611 728 15 -67 658) (-1 "Zcaron" 611 929 0 -23 741) (-1 "ccedilla" 500 538 225 -74 553) (-1 "ydieresis" 500 706 214 -15 600) (-1 "atilde" 556 722 15 -61 592) (-1 "icircumflex" 278 734 0 -95 411) (-1 "threesuperior" 333 703 -270 -90 436) (-1 "ecircumflex" 556 734 15 -84 578) (-1 "thorn" 556 718 207 -14 584) (-1 "egrave" 556 734 15 -84 578) (-1 "twosuperior" 333 703 -281 -64 449) (-1 "eacute" 556 734 15 -84 587) (-1 "otilde" 556 722 14 -83 602) (-1 "Aacute" 667 929 0 -14 683) (-1 "ocircumflex" 556 734 14 -83 585) (-1 "yacute" 500 734 214 -15 600) (-1 "udieresis" 556 706 15 -94 600) (-1 "threequarters" 834 703 19 -130 861) (-1 "acircumflex" 556 734 15 -61 559) (-1 "Eth" 722 718 0 -69 764) (-1 "edieresis" 556 706 15 -84 578) (-1 "ugrave" 556 734 15 -94 600) (-1 "trademark" 1000 718 -306 -186 1056) (-1 "ograve" 556 734 14 -83 585) (-1 "scaron" 500 734 15 -63 552) (-1 "Idieresis" 278 901 0 -91 458) (-1 "uacute" 556 734 15 -94 600) (-1 "agrave" 556 734 15 -61 559) (-1 "ntilde" 556 722 0 -65 592) (-1 "aring" 556 756 15 -61 559) (-1 "zcaron" 500 734 0 -31 571) (-1 "Icircumflex" 278 929 0 -91 452) (-1 "Ntilde" 722 917 0 -76 799) (-1 "ucircumflex" 556 734 15 -94 600) (-1 "Ecircumflex" 667 929 0 -86 762) (-1 "Iacute" 278 929 0 -91 489) (-1 "Ccedilla" 722 737 225 -108 782) (-1 "Odieresis" 778 901 19 -105 826) (-1 "Scaron" 667 929 19 -90 713) (-1 "Edieresis" 667 901 0 -86 762) (-1 "Igrave" 278 929 0 -91 351) (-1 "adieresis" 556 706 15 -61 559) (-1 "Ograve" 778 929 19 -105 826) (-1 "Egrave" 667 929 0 -86 762) (-1 "Ydieresis" 667 901 0 -167 806) (-1 "registered" 737 737 19 -54 837) (-1 "Otilde" 778 917 19 -105 826) (-1 "onequarter" 834 703 19 -150 802) (-1 "Ugrave" 722 929 19 -123 797) (-1 "Ucircumflex" 722 929 19 -123 797) (-1 "Thorn" 667 718 0 -86 712) (-1 "divide" 584 524 19 -85 606) (-1 "Atilde" 667 917 0 -14 699) (-1 "Uacute" 722 929 19 -123 797) (-1 "Ocircumflex" 778 929 19 -105 826) (-1 "logicalnot" 584 390 -108 -106 628) (-1 "Aring" 667 931 0 -14 654) (-1 "idieresis" 278 706 0 -95 416) (-1 "iacute" 278 734 0 -95 448) (-1 "aacute" 556 734 15 -61 587) (-1 "plusminus" 584 506 0 -39 618) (-1 "multiply" 584 506 0 -50 642) (-1 "Udieresis" 722 901 19 -123 797) (-1 "minus" 584 289 -216 -85 606) (-1 "onesuperior" 333 703 -281 -166 371) (-1 "Eacute" 667 929 0 -86 762) (-1 "Acircumflex" 667 929 0 -14 654) (-1 "copyright" 737 737 19 -54 837) (-1 "Agrave" 667 929 0 -14 654) (-1 "odieresis" 556 706 14 -83 585) (-1 "oacute" 556 734 14 -83 587) (-1 "degree" 400 703 -411 -169 468) (-1 "igrave" 278 734 0 -95 310) (-1 "mu" 556 523 207 -24 600) (-1 "Oacute" 778 929 19 -105 826) (-1 "eth" 556 737 15 -81 617) (-1 "Adieresis" 667 901 0 -14 654) (-1 "Yacute" 667 929 0 -167 806) (-1 "brokenbar" 260 737 19 -90 324) (-1 "onehalf" 834 703 19 -114 839))) (define-font-metrics '"Helvetica-Bold" '718 '207 '0 '((32 "space" 278 0 0 0 0) (33 "exclam" 333 718 0 -90 244) (34 "quotedbl" 474 718 -447 -98 376) (35 "numbersign" 556 698 0 -18 538) (36 "dollar" 556 775 115 -30 523) (37 "percent" 889 710 19 -28 861) (38 "ampersand" 722 718 19 -54 701) (39 "quoteright" 278 718 -445 -69 209) (40 "parenleft" 333 734 208 -35 314) (41 "parenright" 333 734 208 -19 298) (42 "asterisk" 389 718 -387 -27 362) (43 "plus" 584 506 0 -40 544) (44 "comma" 278 146 168 -64 214) (45 "hyphen" 333 345 -215 -27 306) (46 "period" 278 146 0 -64 214) (47 "slash" 278 737 19 33 311) (48 "zero" 556 710 19 -32 524) (49 "one" 556 710 0 -69 378) (50 "two" 556 710 0 -26 511) (51 "three" 556 710 19 -27 516) (52 "four" 556 710 0 -27 526) (53 "five" 556 698 19 -27 516) (54 "six" 556 710 19 -31 520) (55 "seven" 556 698 0 -25 528) (56 "eight" 556 710 19 -32 524) (57 "nine" 556 710 19 -30 522) (58 "colon" 333 512 0 -92 242) (59 "semicolon" 333 512 168 -92 242) (60 "less" 584 514 8 -38 546) (61 "equal" 584 419 -87 -40 544) (62 "greater" 584 514 8 -38 546) (63 "question" 611 727 0 -60 556) (64 "at" 975 737 19 -118 856) (65 "A" 722 718 0 -20 702) (66 "B" 722 718 0 -76 669) (67 "C" 722 737 19 -44 684) (68 "D" 722 718 0 -76 685) (69 "E" 667 718 0 -76 621) (70 "F" 611 718 0 -76 587) (71 "G" 778 737 19 -44 713) (72 "H" 722 718 0 -71 651) (73 "I" 278 718 0 -64 214) (74 "J" 556 718 18 -22 484) (75 "K" 722 718 0 -87 722) (76 "L" 611 718 0 -76 583) (77 "M" 833 718 0 -69 765) (78 "N" 722 718 0 -69 654) (79 "O" 778 737 19 -44 734) (80 "P" 667 718 0 -76 627) (81 "Q" 778 737 52 -44 737) (82 "R" 722 718 0 -76 677) (83 "S" 667 737 19 -39 629) (84 "T" 611 718 0 -14 598) (85 "U" 722 718 19 -72 651) (86 "V" 667 718 0 -19 648) (87 "W" 944 718 0 -16 929) (88 "X" 667 718 0 -14 653) (89 "Y" 667 718 0 -15 653) (90 "Z" 611 718 0 -25 586) (91 "bracketleft" 333 722 196 -63 309) (92 "backslash" 278 737 19 33 311) (93 "bracketright" 333 722 196 -24 270) (94 "asciicircum" 584 698 -323 -62 522) (95 "underscore" 556 -75 125 0 556) (96 "quoteleft" 278 727 -454 -69 209) (97 "a" 556 546 14 -29 527) (98 "b" 611 718 14 -61 578) (99 "c" 556 546 14 -34 524) (100 "d" 611 718 14 -34 551) (101 "e" 556 546 14 -23 528) (102 "f" 333 727 0 -10 318) (103 "g" 611 546 217 -40 553) (104 "h" 611 718 0 -65 546) (105 "i" 278 725 0 -69 209) (106 "j" 278 725 214 -3 209) (107 "k" 556 718 0 -69 562) (108 "l" 278 718 0 -69 209) (109 "m" 889 546 0 -64 826) (110 "n" 611 546 0 -65 546) (111 "o" 611 546 14 -34 578) (112 "p" 611 546 207 -62 578) (113 "q" 611 546 207 -34 552) (114 "r" 389 546 0 -64 373) (115 "s" 556 546 14 -30 519) (116 "t" 333 676 6 -10 309) (117 "u" 611 532 14 -66 545) (118 "v" 556 532 0 -13 543) (119 "w" 778 532 0 -10 769) (120 "x" 556 532 0 -15 541) (121 "y" 556 532 214 -10 539) (122 "z" 500 532 0 -20 480) (123 "braceleft" 389 722 196 -48 365) (124 "bar" 280 737 19 -84 196) (125 "braceright" 389 722 196 -24 341) (126 "asciitilde" 584 343 -163 -61 523) (161 "exclamdown" 333 532 186 -90 244) (162 "cent" 556 628 118 -34 524) (163 "sterling" 556 718 16 -28 541) (164 "fraction" 167 710 19 170 336) (165 "yen" 556 698 0 9 565) (166 "florin" 556 737 210 10 516) (167 "section" 556 727 184 -34 522) (168 "currency" 556 636 -76 3 559) (169 "quotesingle" 238 718 -447 -70 168) (170 "quotedblleft" 500 727 -454 -64 436) (171 "guillemotleft" 556 484 -76 -88 468) (172 "guilsinglleft" 333 484 -76 -83 250) (173 "guilsinglright" 333 484 -76 -83 250) (174 "fi" 611 727 0 -10 542) (175 "fl" 611 727 0 -10 542) (177 "endash" 556 333 -227 0 556) (178 "dagger" 556 718 171 -36 520) (179 "daggerdbl" 556 718 171 -36 520) (180 "periodcentered" 278 334 -172 -58 220) (182 "paragraph" 556 700 191 8 539) (183 "bullet" 350 524 -194 -10 340) (184 "quotesinglbase" 278 127 146 -69 209) (185 "quotedblbase" 500 127 146 -64 436) (186 "quotedblright" 500 718 -445 -64 436) (187 "guillemotright" 556 484 -76 -88 468) (188 "ellipsis" 1000 146 0 -92 908) (189 "perthousand" 1000 710 19 3 1003) (191 "questiondown" 611 532 195 -55 551) (193 "grave" 333 750 -604 23 225) (194 "acute" 333 750 -604 -108 356) (195 "circumflex" 333 750 -604 10 343) (196 "tilde" 333 737 -610 17 350) (197 "macron" 333 678 -604 6 339) (198 "breve" 333 750 -604 2 335) (199 "dotaccent" 333 729 -614 -104 230) (200 "dieresis" 333 729 -614 -6 327) (202 "ring" 333 776 -568 -59 275) (203 "cedilla" 333 0 228 -6 245) (205 "hungarumlaut" 333 750 -604 -9 486) (206 "ogonek" 333 0 228 -71 304) (207 "caron" 333 750 -604 10 343) (208 "emdash" 1000 333 -227 0 1000) (225 "AE" 1000 718 0 -5 954) (227 "ordfeminine" 370 737 -276 -22 347) (232 "Lslash" 611 718 0 20 583) (233 "Oslash" 778 745 27 -33 744) (234 "OE" 1000 737 19 -37 961) (235 "ordmasculine" 365 737 -276 -6 360) (241 "ae" 889 546 14 -29 858) (245 "dotlessi" 278 532 0 -69 209) (248 "lslash" 278 718 0 18 296) (249 "oslash" 611 560 29 -22 589) (250 "oe" 944 546 14 -34 912) (251 "germandbls" 611 731 14 -69 579) (-1 "Zcaron" 611 936 0 -25 586) (-1 "ccedilla" 556 546 228 -34 524) (-1 "ydieresis" 556 729 214 -10 539) (-1 "atilde" 556 737 14 -29 527) (-1 "icircumflex" 278 750 0 37 316) (-1 "threesuperior" 333 710 -271 -8 326) (-1 "ecircumflex" 556 750 14 -23 528) (-1 "thorn" 611 718 208 -62 578) (-1 "egrave" 556 750 14 -23 528) (-1 "twosuperior" 333 710 -283 -9 324) (-1 "eacute" 556 750 14 -23 528) (-1 "otilde" 611 737 14 -34 578) (-1 "Aacute" 722 936 0 -20 702) (-1 "ocircumflex" 611 750 14 -34 578) (-1 "yacute" 556 750 214 -10 539) (-1 "udieresis" 611 729 14 -66 545) (-1 "threequarters" 834 710 19 -16 799) (-1 "acircumflex" 556 750 14 -29 527) (-1 "Eth" 722 718 0 5 685) (-1 "edieresis" 556 729 14 -23 528) (-1 "ugrave" 611 750 14 -66 545) (-1 "trademark" 1000 718 -306 -44 956) (-1 "ograve" 611 750 14 -34 578) (-1 "scaron" 556 750 14 -30 519) (-1 "Idieresis" 278 915 0 21 300) (-1 "uacute" 611 750 14 -66 545) (-1 "agrave" 556 750 14 -29 527) (-1 "ntilde" 611 737 0 -65 546) (-1 "aring" 556 776 14 -29 527) (-1 "zcaron" 500 750 0 -20 480) (-1 "Icircumflex" 278 936 0 37 316) (-1 "Ntilde" 722 923 0 -69 654) (-1 "ucircumflex" 611 750 14 -66 545) (-1 "Ecircumflex" 667 936 0 -76 621) (-1 "Iacute" 278 936 0 -64 329) (-1 "Ccedilla" 722 737 228 -44 684) (-1 "Odieresis" 778 915 19 -44 734) (-1 "Scaron" 667 936 19 -39 629) (-1 "Edieresis" 667 915 0 -76 621) (-1 "Igrave" 278 936 0 50 214) (-1 "adieresis" 556 729 14 -29 527) (-1 "Ograve" 778 936 19 -44 734) (-1 "Egrave" 667 936 0 -76 621) (-1 "Ydieresis" 667 915 0 -15 653) (-1 "registered" 737 737 19 11 748) (-1 "Otilde" 778 923 19 -44 734) (-1 "onequarter" 834 710 19 -26 766) (-1 "Ugrave" 722 936 19 -72 651) (-1 "Ucircumflex" 722 936 19 -72 651) (-1 "Thorn" 667 718 0 -76 627) (-1 "divide" 584 548 42 -40 544) (-1 "Atilde" 722 923 0 -20 702) (-1 "Uacute" 722 936 19 -72 651) (-1 "Ocircumflex" 778 936 19 -44 734) (-1 "logicalnot" 584 419 -108 -40 544) (-1 "Aring" 722 962 0 -20 702) (-1 "idieresis" 278 729 0 21 300) (-1 "iacute" 278 750 0 -69 329) (-1 "aacute" 556 750 14 -29 527) (-1 "plusminus" 584 506 0 -40 544) (-1 "multiply" 584 505 -1 -40 545) (-1 "Udieresis" 722 915 19 -72 651) (-1 "minus" 584 309 -197 -40 544) (-1 "onesuperior" 333 710 -283 -26 237) (-1 "Eacute" 667 936 0 -76 621) (-1 "Acircumflex" 722 936 0 -20 702) (-1 "copyright" 737 737 19 11 749) (-1 "Agrave" 722 936 0 -20 702) (-1 "odieresis" 611 729 14 -34 578) (-1 "oacute" 611 750 14 -34 578) (-1 "degree" 400 712 -426 -57 343) (-1 "igrave" 278 750 0 50 209) (-1 "mu" 611 532 207 -66 545) (-1 "Oacute" 778 936 19 -44 734) (-1 "eth" 611 737 14 -34 578) (-1 "Adieresis" 722 915 0 -20 702) (-1 "Yacute" 667 936 0 -15 653) (-1 "brokenbar" 280 737 19 -84 196) (-1 "onehalf" 834 710 19 -26 794))) (define-font-metrics '"Helvetica-BoldOblique" '718 '207 '-12 '((32 "space" 278 0 0 0 0) (33 "exclam" 333 718 0 -94 397) (34 "quotedbl" 474 718 -447 -193 529) (35 "numbersign" 556 698 0 -60 644) (36 "dollar" 556 775 115 -67 622) (37 "percent" 889 710 19 -136 901) (38 "ampersand" 722 718 19 -89 732) (39 "quoteright" 278 718 -445 -167 362) (40 "parenleft" 333 734 208 -76 470) (41 "parenright" 333 734 208 25 369) (42 "asterisk" 389 718 -387 -146 481) (43 "plus" 584 506 0 -82 610) (44 "comma" 278 146 168 -28 245) (45 "hyphen" 333 345 -215 -73 379) (46 "period" 278 146 0 -64 245) (47 "slash" 278 737 19 37 468) (48 "zero" 556 710 19 -86 617) (49 "one" 556 710 0 -173 529) (50 "two" 556 710 0 -26 619) (51 "three" 556 710 19 -65 608) (52 "four" 556 710 0 -60 598) (53 "five" 556 698 19 -64 636) (54 "six" 556 710 19 -85 619) (55 "seven" 556 698 0 -125 676) (56 "eight" 556 710 19 -69 616) (57 "nine" 556 710 19 -78 615) (58 "colon" 333 512 0 -92 351) (59 "semicolon" 333 512 168 -56 351) (60 "less" 584 514 8 -82 655) (61 "equal" 584 419 -87 -58 633) (62 "greater" 584 514 8 -36 609) (63 "question" 611 727 0 -165 671) (64 "at" 975 737 19 -186 954) (65 "A" 722 718 0 -20 702) (66 "B" 722 718 0 -76 764) (67 "C" 722 737 19 -107 789) (68 "D" 722 718 0 -76 777) (69 "E" 667 718 0 -76 757) (70 "F" 611 718 0 -76 740) (71 "G" 778 737 19 -108 817) (72 "H" 722 718 0 -71 804) (73 "I" 278 718 0 -64 367) (74 "J" 556 718 18 -60 637) (75 "K" 722 718 0 -87 858) (76 "L" 611 718 0 -76 611) (77 "M" 833 718 0 -69 918) (78 "N" 722 718 0 -69 807) (79 "O" 778 737 19 -107 823) (80 "P" 667 718 0 -76 738) (81 "Q" 778 737 52 -107 823) (82 "R" 722 718 0 -76 778) (83 "S" 667 737 19 -81 718) (84 "T" 611 718 0 -140 751) (85 "U" 722 718 19 -116 804) (86 "V" 667 718 0 -172 801) (87 "W" 944 718 0 -169 1082) (88 "X" 667 718 0 -14 791) (89 "Y" 667 718 0 -168 806) (90 "Z" 611 718 0 -25 737) (91 "bracketleft" 333 722 196 -21 462) (92 "backslash" 278 737 19 -124 307) (93 "bracketright" 333 722 196 18 423) (94 "asciicircum" 584 698 -323 -131 591) (95 "underscore" 556 -75 125 27 540) (96 "quoteleft" 278 727 -454 -165 361) (97 "a" 556 546 14 -55 583) (98 "b" 611 718 14 -61 645) (99 "c" 556 546 14 -79 599) (100 "d" 611 718 14 -82 704) (101 "e" 556 546 14 -70 593) (102 "f" 333 727 0 -87 469) (103 "g" 611 546 217 -38 666) (104 "h" 611 718 0 -65 629) (105 "i" 278 725 0 -69 363) (106 "j" 278 725 214 42 363) (107 "k" 556 718 0 -69 670) (108 "l" 278 718 0 -69 362) (109 "m" 889 546 0 -64 909) (110 "n" 611 546 0 -65 629) (111 "o" 611 546 14 -82 643) (112 "p" 611 546 207 -18 645) (113 "q" 611 546 207 -80 665) (114 "r" 389 546 0 -64 489) (115 "s" 556 546 14 -63 584) (116 "t" 333 676 6 -100 422) (117 "u" 611 532 14 -98 658) (118 "v" 556 532 0 -126 656) (119 "w" 778 532 0 -123 882) (120 "x" 556 532 0 -15 648) (121 "y" 556 532 214 -42 652) (122 "z" 500 532 0 -20 583) (123 "braceleft" 389 722 196 -94 518) (124 "bar" 280 737 19 -80 353) (125 "braceright" 389 722 196 18 407) (126 "asciitilde" 584 343 -163 -115 577) (161 "exclamdown" 333 532 186 -50 353) (162 "cent" 556 628 118 -79 599) (163 "sterling" 556 718 16 -50 635) (164 "fraction" 167 710 19 174 487) (165 "yen" 556 698 0 -60 713) (166 "florin" 556 737 210 50 669) (167 "section" 556 727 184 -61 598) (168 "currency" 556 636 -76 -27 680) (169 "quotesingle" 238 718 -447 -165 321) (170 "quotedblleft" 500 727 -454 -160 588) (171 "guillemotleft" 556 484 -76 -135 571) (172 "guilsinglleft" 333 484 -76 -130 353) (173 "guilsinglright" 333 484 -76 -99 322) (174 "fi" 611 727 0 -87 696) (175 "fl" 611 727 0 -87 695) (177 "endash" 556 333 -227 -48 627) (178 "dagger" 556 718 171 -118 626) (179 "daggerdbl" 556 718 171 -46 628) (180 "periodcentered" 278 334 -172 -110 276) (182 "paragraph" 556 700 191 -98 688) (183 "bullet" 350 524 -194 -83 420) (184 "quotesinglbase" 278 127 146 -41 236) (185 "quotedblbase" 500 127 146 -36 463) (186 "quotedblright" 500 718 -445 -162 589) (187 "guillemotright" 556 484 -76 -104 540) (188 "ellipsis" 1000 146 0 -92 939) (189 "perthousand" 1000 710 19 -76 1038) (191 "questiondown" 611 532 195 -53 559) (193 "grave" 333 750 -604 -136 353) (194 "acute" 333 750 -604 -236 515) (195 "circumflex" 333 750 -604 -118 471) (196 "tilde" 333 737 -610 -113 507) (197 "macron" 333 678 -604 -122 483) (198 "breve" 333 750 -604 -156 494) (199 "dotaccent" 333 729 -614 -235 385) (200 "dieresis" 333 729 -614 -137 482) (202 "ring" 333 776 -568 -200 420) (203 "cedilla" 333 0 228 37 220) (205 "hungarumlaut" 333 750 -604 -137 645) (206 "ogonek" 333 0 228 -41 264) (207 "caron" 333 750 -604 -149 502) (208 "emdash" 1000 333 -227 -48 1071) (225 "AE" 1000 718 0 -5 1100) (227 "ordfeminine" 370 737 -276 -92 465) (232 "Lslash" 611 718 0 -34 611) (233 "Oslash" 778 745 27 -35 894) (234 "OE" 1000 737 19 -99 1114) (235 "ordmasculine" 365 737 -276 -92 485) (241 "ae" 889 546 14 -56 923) (245 "dotlessi" 278 532 0 -69 322) (248 "lslash" 278 718 0 -40 407) (249 "oslash" 611 560 29 -22 701) (250 "oe" 944 546 14 -82 977) (251 "germandbls" 611 731 14 -69 657) (-1 "Zcaron" 611 936 0 -25 737) (-1 "ccedilla" 556 546 228 -79 599) (-1 "ydieresis" 556 729 214 -42 652) (-1 "atilde" 556 737 14 -55 619) (-1 "icircumflex" 278 750 0 -69 444) (-1 "threesuperior" 333 710 -271 -91 441) (-1 "ecircumflex" 556 750 14 -70 593) (-1 "thorn" 611 718 208 -18 645) (-1 "egrave" 556 750 14 -70 593) (-1 "twosuperior" 333 710 -283 -69 449) (-1 "eacute" 556 750 14 -70 627) (-1 "otilde" 611 737 14 -82 646) (-1 "Aacute" 722 936 0 -20 750) (-1 "ocircumflex" 611 750 14 -82 643) (-1 "yacute" 556 750 214 -42 652) (-1 "udieresis" 611 729 14 -98 658) (-1 "threequarters" 834 710 19 -99 839) (-1 "acircumflex" 556 750 14 -55 583) (-1 "Eth" 722 718 0 -62 777) (-1 "edieresis" 556 729 14 -70 594) (-1 "ugrave" 611 750 14 -98 658) (-1 "trademark" 1000 718 -306 -179 1109) (-1 "ograve" 611 750 14 -82 643) (-1 "scaron" 556 750 14 -63 614) (-1 "Idieresis" 278 915 0 -64 494) (-1 "uacute" 611 750 14 -98 658) (-1 "agrave" 556 750 14 -55 583) (-1 "ntilde" 611 737 0 -65 646) (-1 "aring" 556 776 14 -55 583) (-1 "zcaron" 500 750 0 -20 586) (-1 "Icircumflex" 278 936 0 -64 484) (-1 "Ntilde" 722 923 0 -69 807) (-1 "ucircumflex" 611 750 14 -98 658) (-1 "Ecircumflex" 667 936 0 -76 757) (-1 "Iacute" 278 936 0 -64 528) (-1 "Ccedilla" 722 737 228 -107 789) (-1 "Odieresis" 778 915 19 -107 823) (-1 "Scaron" 667 936 19 -81 718) (-1 "Edieresis" 667 915 0 -76 757) (-1 "Igrave" 278 936 0 -64 367) (-1 "adieresis" 556 729 14 -55 594) (-1 "Ograve" 778 936 19 -107 823) (-1 "Egrave" 667 936 0 -76 757) (-1 "Ydieresis" 667 915 0 -168 806) (-1 "registered" 737 737 19 -55 834) (-1 "Otilde" 778 923 19 -107 823) (-1 "onequarter" 834 710 19 -132 806) (-1 "Ugrave" 722 936 19 -116 804) (-1 "Ucircumflex" 722 936 19 -116 804) (-1 "Thorn" 667 718 0 -76 716) (-1 "divide" 584 548 42 -82 610) (-1 "Atilde" 722 923 0 -20 741) (-1 "Uacute" 722 936 19 -116 804) (-1 "Ocircumflex" 778 936 19 -107 823) (-1 "logicalnot" 584 419 -108 -105 633) (-1 "Aring" 722 962 0 -20 702) (-1 "idieresis" 278 729 0 -69 455) (-1 "iacute" 278 750 0 -69 488) (-1 "aacute" 556 750 14 -55 627) (-1 "plusminus" 584 506 0 -40 625) (-1 "multiply" 584 505 -1 -57 635) (-1 "Udieresis" 722 915 19 -116 804) (-1 "minus" 584 309 -197 -82 610) (-1 "onesuperior" 333 710 -283 -148 388) (-1 "Eacute" 667 936 0 -76 757) (-1 "Acircumflex" 722 936 0 -20 706) (-1 "copyright" 737 737 19 -56 835) (-1 "Agrave" 722 936 0 -20 702) (-1 "odieresis" 611 729 14 -82 643) (-1 "oacute" 611 750 14 -82 654) (-1 "degree" 400 712 -426 -175 467) (-1 "igrave" 278 750 0 -69 326) (-1 "mu" 611 532 207 -22 658) (-1 "Oacute" 778 936 19 -107 823) (-1 "eth" 611 737 14 -82 670) (-1 "Adieresis" 722 915 0 -20 716) (-1 "Yacute" 667 936 0 -168 806) (-1 "brokenbar" 280 737 19 -80 353) (-1 "onehalf" 834 710 19 -132 858))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/PostScript/encoding.lisp0000600000175000017500000001462610423413303023274 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-POSTSCRIPT; -*- ;;; --------------------------------------------------------------------------- ;;; Title: Postscript Font Encodings ;;; Created: 2004-12-03 ;;; Author: Gilbert Baumann ;;; License: LGPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2004 by Gilbert Baumann ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-postscript) (defvar *iso-latin-1-symbolic-names* '#(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL "space" "exclam" "quotedbl" "numbersign" "dollar" "percent" "ampersand" "quoteright" "parenleft" "parenright" "asterisk" "plus" "comma" "hyphen" "period" "slash" "zero" "one" "two" "three" "four" "five" "six" "seven" "eight" "nine" "colon" "semicolon" "less" "equal" "greater" "question" "at" "A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M" "N" "O" "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z" "bracketleft" "backslash" "bracketright" "asciicircum" "underscore" "quoteleft" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m" "n" "o" "p" "q" "r" "s" "t" "u" "v" "w" "x" "y" "z" "braceleft" "bar" "braceright" "asciitilde" NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL "nbspace" "exclamdown" "cent" "sterling" "currency" "yen" "brokenbar" "section" NIL "copyright" "ordfeminine" "guillemotleft" "logicalnot" NIL "registered" NIL "degree" "plusminus" "twosuperior" "threesuperior" "acute" "mu" "paragraph" "periodcentered" "cedilla" "onesuperior" "ordmasculine" "guillemotright" "onequarter" "onehalf" "threequarters" "questiondown" "Agrave" "Aacute" "Acircumflex" "Atilde" "Adieresis" "Aring" "AE" "Ccedilla" "Egrave" "Eacute" "Ecircumflex" "Edieresis" "Igrave" "Iacute" "Icircumflex" "Idieresis" "Eth" "Ntilde" "Ograve" "Oacute" "Ocircumflex" "Otilde" "Odieresis" "multiply" "Oslash" "Ugrave" "Uacute" "Ucircumflex" "Udieresis" "Yacute" "Thorn" "germandbls" "agrave" "aacute" "acircumflex" "atilde" "adieresis" "aring" "ae" "ccedilla" "egrave" "eacute" "ecircumflex" "edieresis" "igrave" "iacute" "icirc" "idieresis" "eth" "ntilde" "ograve" "oacute" "ocircumflex" "otilde" "odieresis" "divide" "oslash" "ugrave" "uacute" "ucircumflex" "udieresis" "yacute" "thorn" "ydieresis") "A mapping of iso-8859-1 code points to adobe glyph names.") (defun dump-reencode (sink) (format sink " % base-font-name new-font-name encoding-vector ReEncode --> /ReEncode { 5 dict begin /newencoding exch def /newfontname exch def /basefontname exch def /basefontdict basefontname findfont def /newfont basefontdict maxlength dict def basefontdict { exch dup dup /FID ne exch /Encoding ne and { exch newfont 3 1 roll put } { pop pop } ifelse } forall newfont /FontName newfontname put newfont /Encoding newencoding put newfontname newfont definefont pop end } def /R { 2 1 roll 0 rmoveto show } def /ISOmapping 256 array def ") (format sink "ISOmapping~%") (dotimes (i 256) (format sink " dup ~3D /~A put~%" i (or (aref *iso-latin-1-symbolic-names* i) ".notdef"))) (format sink "pop~%~%") (dolist (k '("Times-Roman" "Times-Italic" "Times-Bold" "Times-BoldItalic" "Helvetica" "Helvetica-Oblique" "Helvetica-Bold" "Helvetica-BoldOblique" "Courier" "Courier-Oblique" "Courier-Bold" "Courier-BoldOblique")) (format sink "/~A /~A-iso ISOmapping ReEncode~%" k k)) )cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/PostScript/generate-metrics.lisp0000644000175000017500000000417307475332356024775 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-POSTSCRIPT -*- ;;; (c) copyright 2002 by ;;; Alexey Dejneka (adejneka@comail.ru) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-postscript) (defvar *lisp-metrics-file* (merge-pathnames (make-pathname :name "standard-metrics" :type "lisp" :defaults *load-truename*) *load-truename*)) (with-open-file (out *lisp-metrics-file* :direction :output :if-exists :supersede :if-does-not-exist :create) (print '(in-package :clim-postscript) out) (let ((*default-pathname-defaults* (make-pathname :directory '(:absolute "usr" "share" "texmf" "fonts" "afm" "adobe") :type "afm"))) (loop for file in '("times/ptmr8a" "times/ptmb8a" "times/ptmri8a" "times/ptmbi8a" "courier/pcrr8a" "courier/pcrro8a" "courier/pcrb8a" "courier/pcrbo8a" "helvetic/phvr8a" "helvetic/phvro8a" "helvetic/phvb8a" "helvetic/phvbo8a") do (print `(define-font-metrics ,@(mapcar (lambda (arg) (list 'quote arg)) (multiple-value-list (with-open-file (stream (merge-pathnames file)) (read-afm-stream stream))))) out))))cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/PostScript/sheet.lisp0000640000175000017500000002265110741375211022627 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-POSTSCRIPT -*- ;;; (c) copyright 2001 by ;;; Arnaud Rouanet (rouanet@emi.u-bordeaux.fr) ;;; Lionel Salabartan (salabart@emi.u-bordeaux.fr) ;;; (c) copyright 2002 by ;;; Alexey Dejneka (adejneka@comail.ru) ;;; Gilbert Baumann (unk6@rz.uni-karlsruhe.de) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; TODO: ;;; ;;; - do smth with POSTSCRIPT-GRAFT. ;;; Also missing IMO: ;;; ;;; - WITH-OUTPUT-TO-POSTSCRIPT-STREAM should offer a :PAPER-SIZE option. ;;; - NEW-PAGE should also offer to specify the page name. ;;; - device fonts are missing ;;; - font metrics are missing ;;; ;;;--GB (in-package :clim-postscript) (defmacro with-output-to-postscript-stream ((stream-var file-stream &rest options) &body body) (let ((cont (gensym))) `(flet ((,cont (,stream-var) ,@body)) (declare (dynamic-extent #',cont)) (invoke-with-output-to-postscript-stream #',cont ,file-stream ,@options)))) (defun invoke-with-output-to-postscript-stream (continuation file-stream &key device-type multi-page scale-to-fit (orientation :portrait) header-comments) (let* ((port (find-port :server-path `(:ps :stream ,file-stream))) (stream (make-postscript-stream file-stream port device-type multi-page scale-to-fit orientation header-comments)) translate-x translate-y) (unwind-protect (progn (with-output-recording-options (stream :record t :draw nil) (with-graphics-state (stream) ;; we need at least one level of saving -- APD, 2002-02-11 (funcall continuation stream) (unless (eql (slot-value stream 'paper) :eps) (new-page stream)))) ; Close final page. (with-slots (file-stream title for orientation paper) stream (format file-stream "%!PS-Adobe-3.0~@[ EPSF-3.0~*~]~%" (eq device-type :eps)) (format file-stream "%%Creator: McCLIM~%") (format file-stream "%%Title: ~A~%" title) (format file-stream "%%For: ~A~%" for) (format file-stream "%%LanguageLevel: 2~%") (case paper ((:eps) (let ((record (stream-output-history stream))) (multiple-value-bind (lx ly ux uy) (bounding-rectangle* record) (setf translate-x (- (floor lx)) translate-y (ceiling uy)) (format file-stream "%%BoundingBox: ~A ~A ~A ~A~%" 0 0 (+ translate-x (ceiling ux)) (- translate-y (floor ly)))))) (t (multiple-value-bind (width height) (paper-size paper) (format file-stream "%%BoundingBox: 0 0 ~A ~A~%" width height) (format file-stream "%%DocumentMedia: ~A ~A ~A 0 () ()~%" paper width height)) (format file-stream "%%Orientation: ~A~%" (ecase orientation (:portrait "Portrait") (:landscape "Landscape"))) (format file-stream "%%Pages: (atend)~%"))) (format file-stream "%%DocumentNeededResources: (atend)~%") (format file-stream "%%EndComments~%~%") (write-postscript-dictionary file-stream) (dolist (text-style (device-fonts (sheet-medium stream))) (write-font-to-postscript-stream (sheet-medium stream) text-style)) (start-page stream) (format file-stream "~@[~A ~]~@[~A translate~%~]" translate-x translate-y) (with-output-recording-options (stream :draw t :record nil) (with-graphics-state (stream) (case paper ((:eps) (replay (stream-output-history stream) stream)) (t (let ((last-page (first (postscript-pages stream)))) (dolist (page (reverse (postscript-pages stream))) (replay page stream) (unless (eql page last-page) (emit-new-page stream)))))))))) (with-slots (file-stream current-page) stream (format file-stream "end~%showpage~%~%") (format file-stream "%%Trailer~%") (format file-stream "%%Pages: ~D~%" current-page) (format file-stream "%%DocumentNeededResources: ~{font ~A~%~^%%+ ~}~%" (reverse (slot-value stream 'document-fonts))) (format file-stream "%%EOF~%") (finish-output file-stream)) (destroy-port port)))) (defun start-page (stream) (with-slots (file-stream current-page transformation) stream (format file-stream "%%Page: ~D ~:*~D~%" (incf current-page)) (format file-stream "~A begin~%" *dictionary-name*))) (defun new-page (stream) (push (stream-output-history stream) (postscript-pages stream)) (let ((history (make-instance 'standard-tree-output-history :stream stream))) (setf (slot-value stream 'climi::output-history) history (stream-current-output-record stream) history)) (setf (stream-cursor-position stream) (values 0 0))) (defun emit-new-page (stream) ;; FIXME: it is necessary to do smth with GS -- APD, 2002-02-11 ;; FIXME^2: what do you mean by that? -- TPD, 2005-12-23 (postscript-restore-graphics-state stream) (format (postscript-stream-file-stream stream) "end~%showpage~%") (start-page stream) (postscript-save-graphics-state stream)) ;;;; Output Protocol (defmethod medium-drawable ((medium postscript-medium)) (postscript-medium-file-stream medium)) (defmethod make-medium ((port postscript-port) (sheet postscript-stream)) (make-instance 'postscript-medium :sheet sheet :port port)) (defmethod medium-miter-limit ((medium postscript-medium)) #.(* pi (/ 11 180))) ; ? (defmethod sheet-direct-mirror ((sheet postscript-stream)) (postscript-stream-file-stream sheet)) (defmethod sheet-mirrored-ancestor ((sheet postscript-stream)) sheet) (defmethod sheet-mirror ((sheet postscript-stream)) (sheet-direct-mirror sheet)) (defmethod realize-mirror ((port postscript-port) (sheet postscript-stream)) (sheet-direct-mirror sheet)) (defmethod destroy-mirror ((port postscript-port) (sheet postscript-stream)) (error "Can't destroy mirror for the postscript stream ~S." sheet)) ;;; Internal methods (defmethod climi::port-mirror-width ((port postscript-port) (stream postscript-stream)) (let ((region (sheet-native-region stream))) (bounding-rectangle-width region))) (defmethod climi::port-mirror-height ((port postscript-port) (stream postscript-stream)) (let ((region (sheet-native-region stream))) (bounding-rectangle-height region))) ;;; Some strange functions (defmethod pane-viewport ((pane postscript-stream)) nil) (defmethod scroll-extent ((pane postscript-stream) x y) (declare (ignore x y)) (values)) ;;;; ;;;; POSTSCRIPT-GRAFT ;;;; (defclass postscript-graft (basic-sheet sheet-leaf-mixin) ((width :initform 210 :reader postscript-graft-width) (height :initform 297 :reader postscript-graft-height))) (defmethod graft-orientation ((graft postscript-graft)) :graphics) (defmethod graft-units ((graft postscript-graft)) :device) (defmethod graft-width ((graft postscript-graft) &key (units :device)) (* (postscript-graft-width graft) (ecase units (:device (/ 720 254)) (:inches (/ 10 254)) (:millimeters 1) (:screen-sized (/ (postscript-graft-width graft)))))) (defmethod graft-height ((graft postscript-graft) &key (units :device)) (* (postscript-graft-height graft) (ecase units (:device (/ 720 254)) (:inches (/ 10 254)) (:millimeters 1) (:screen-sized (/ (postscript-graft-height graft)))))) (defun make-postscript-graft () (make-instance 'postscript-graft)) (defmethod sheet-region ((sheet postscript-graft)) (make-rectangle* 0 0 (graft-width sheet :units (graft-units sheet)) (graft-height sheet :units (graft-units sheet)))) (defmethod graft ((sheet postscript-graft)) sheet) ;;; Port (setf (get :ps :port-type) 'postscript-port) (setf (get :ps :server-path-parser) 'parse-postscript-server-path) (defun parse-postscript-server-path (path) path) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/PostScript/package.lisp0000600000175000017500000000255010423413303023072 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-POSTSCRIPT -*- ;;; (c) copyright 2002 by ;;; Alexey Dejneka (adejneka@comail.ru) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :cl-user) (defpackage #:clim-postscript (:use #:clim #:clim-extensions #:clim-lisp) (:export #:load-afm-file) (:import-from #:clim-internals #:get-environment-variable #:map-repeated-sequence #:atan* #:ellipse-normal-radii* #:get-transformation #:untransform-angle #:with-transformed-position #:maxf #:port-text-style-mappings)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/PostScript/paper.lisp0000600000175000017500000000454210423413303022611 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-POSTSCRIPT -*- ;;; (c) copyright 2002 by ;;; Alexey Dejneka (adejneka@comail.ru) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-postscript) (defparameter *paper-sizes* '((:letter 612 . 792) (:legal 612 . 1008) (:a0 2380 . 3368) (:a1 1684 . 2380) (:a2 1190 . 1684) (:a3 842 . 1190) (:a4 595 . 842) (:a5 421 . 595) (:a6 297 . 421) (:a7 210 . 297) (:a8 148 . 210) (:a9 105 . 148) (:a10 74 . 105) (:b0 2836 . 4008) (:b1 2004 . 2836) (:b2 1418 . 2004) (:b3 1002 . 1418) (:b4 709 . 1002) (:b5 501 . 709) (:11x17 792 . 1224))) (defun paper-size (name) (let ((size (cdr (assoc name *paper-sizes*)))) (unless size (error "Unknown paper size: ~S." name)) (values (car size) (cdr size)))) (defun paper-region (paper-size-name orientation) (multiple-value-bind (width height) (paper-size paper-size-name) (when (eq orientation :landscape) (rotatef width height)) (make-rectangle* 0 0 width height))) (defun make-postscript-transformation (paper-size-name orientation) (when (eq paper-size-name :eps) (return-from make-postscript-transformation (make-reflection-transformation* 0 0 1 0))) (multiple-value-bind (width height) (paper-size paper-size-name) (case orientation (:portrait (make-3-point-transformation* 0 0 0 height width 0 0 height 0 0 width height)) (:landscape (make-3-point-transformation* 0 0 0 width height 0 width height 0 height width 0)) (t (error "Unknown orientation"))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/PostScript/afm.lisp0000600000175000017500000001230510423413302022240 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-POSTSCRIPT -*- ;;; (c) copyright 2002 by ;;; Alexey Dejneka (adejneka@comail.ru) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; TODO: ;;; ;;; - It is ugly. Rewrite. ;;; ;;; - Kerning, ligatures. ;;; - Full AFM/AMFM/ACFM support. (in-package :clim-postscript) (defun space-char-p (char) (member char '(#\Space #\Tab))) (defvar *stream*) (defvar *line*) (defvar *line-length*) (defvar *position*) (defun skip-whitespaces () (let ((pos (position-if-not #'space-char-p *line* :start *position*))) (if pos (setq *position* pos) (setq *position* *line-length*)))) (defun assert-whitespace () (or (= *line-length* *position*) (space-char-p (aref *line* *position*)))) (defun end-of-line-p () (skip-whitespaces) (= *line-length* *position*)) (defun take-line () (loop (setq *line* (read-line *stream*)) (setq *line-length* (length *line*)) (setq *position* 0) (skip-whitespaces) (unless (= *position* *line-length*) (return-from take-line)))) (defun take-name () (skip-whitespaces) (let ((start *position*) (end (or (position-if #'space-char-p *line* :start *position*) *line-length*))) (setq *position* end) (subseq *line* start end))) (defun take-integer () (skip-whitespaces) (let ((start *position*) (end (or (position-if #'space-char-p *line* :start *position*) *line-length*))) (setq *position* end) (parse-integer *line* :start start :end end))) (defun take-number () (skip-whitespaces) ;; FIXME (let ((string (take-name))) (assert (every #'(lambda (char) (or (digit-char-p char) (member char '(#\- #\.)))) string)) (let ((number (read-from-string string))) (assert (numberp number)) number))) (defun take-string () (skip-whitespaces) (prog1 (subseq *line* *position* *line-length*) (setq *position* *line-length*))) (defun take-delimiter () (assert (string= (take-name) ";"))) (defun skip-until-delimiter () (let ((pos (position #\; *line* :start *position*))) (assert pos) (setq *position* pos))) ;;; (defparameter *font-metrics-keywords* '(("EndFontMetrics" . :end-font-metrics) ("FontName" . :font-name) ("Ascender" . :ascender) ("Descender" . :descender) ("ItalicAngle" . :italic-angle) ("StartCharMetrics" . :start-char-metrics))) (defparameter *char-metrics-keywords* '(("C" . :c) ("WX" . :wx) ("N" . :n) ("B" . :b) ("EndCharMetrics" . :end-char-metrics))) (defun take-keyword (table) (let ((name (take-name))) (cdr (assoc name table :test #'equal)))) (defun read-char-metrics () (loop for code = nil and name = nil and width = nil and ascent = nil and descent = nil and xmin = nil and xmax = nil do (take-line) (loop for keyword = (and (not (end-of-line-p)) (take-keyword *char-metrics-keywords*)) while keyword do (ecase keyword ((nil) (skip-until-delimiter)) (:end-char-metrics (return-from read-char-metrics metrics)) (:c (setq code (take-number))) (:wx (setq width (take-number))) (:n (setq name (take-name))) (:b (setq xmin (take-number)) (setq descent (- (take-number))) (setq xmax (take-number)) (setq ascent (take-number)))) (take-delimiter)) collect (list code name width ascent descent xmin xmax) into metrics)) (defun read-afm-stream (stream) (let (name ascent descent italic-angle char-infos) (let ((*stream* stream)) (loop (take-line) (let ((keyword (take-keyword *font-metrics-keywords*))) (ecase keyword ((nil)) (:end-font-metrics (return)) (:font-name (setq name (take-string))) ; FIXME: repeated definition (:ascender (setq ascent (take-number))) ; FIXME: extra tokens (:descender (setq descent (- (take-number)))) (:italic-angle (setq italic-angle (take-number))) (:start-char-metrics (setq char-infos (read-char-metrics))))))) (values name ascent descent italic-angle char-infos))) ;;;; ;;; FIXME: This function should be given a right name, exported from ;;; CLIM-POSTSCRIPT and documented in the manual. (defun load-afm-file (afm-filename) "Loads font information from the specified AFM file." (multiple-value-call #'define-font-metrics (with-open-file (stream afm-filename) (read-afm-stream stream))))cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/PostScript/font.lisp0000640000175000017500000003447510705412615022474 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-POSTSCRIPT -*- ;;; (c) copyright 2002 by ;;; Alexey Dejneka (adejneka@comail.ru) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; TODO: ;;; ;;; - Kerning, ligatures. ;;; - device fonts (in-package :clim-postscript) (defclass font-info () ((name :type string :initarg :name :reader font-info-name) (ascent :initarg :ascent :reader font-info-ascent) (descent :initarg :descent :reader font-info-descent) (italic-angle :initarg :italic-angle :reader font-info-italic-angle) (char-names :initform (make-array 256 :initial-element nil) :reader font-info-char-names) (char-infos :initform (make-hash-table :test 'equal) :reader font-info-char-infos))) (defclass char-metrics () ((width :initarg :width :reader char-width) (ascent :initarg :ascent :reader char-ascent) (descent :initarg :descent :reader char-descent) (xmin :initarg :xmin :reader char-xmin) (xmax :initarg :xmax :reader char-xmax))) (defvar *font-metrics* (make-hash-table :test 'equal)) (defstruct postscript-device-font-name (font-file (error "missing argument")) (metrics-file (error "missing argument")) (size (error "missing argument"))) (defun %font-name-size (font-name) (etypecase font-name (postscript-device-font-name (postscript-device-font-name-size font-name)) (cons (cdr font-name)))) (defun %font-name-metrics-key (font-name) (etypecase font-name (postscript-device-font-name font-name) (cons (car font-name)))) (defun %font-name-postscript-name (font-name) (etypecase font-name (postscript-device-font-name (let ((font-info (gethash font-name *font-metrics*))) (unless font-info (error "Unknown font: ~S" font-info)) (font-info-name font-info))) (cons (concatenate 'string (car font-name) "-iso")))) (defun define-font-metrics (name ascent descent angle char-infos &optional (font-name nil)) (let ((font-info (make-instance 'font-info :name name :ascent ascent :descent descent :italic-angle angle))) (setf (gethash (or font-name name) *font-metrics*) font-info) (loop for (code name width ascent descent xmin xmax) in char-infos do (when (>= code 0) (setf (aref (font-info-char-names font-info) code) name)) (setf (gethash name (font-info-char-infos font-info)) (make-instance 'char-metrics :width width :ascent ascent :descent descent :xmin xmin :xmax xmax))))) ;;; (defun text-size-in-font (font-name size string start end) (declare (string string)) (unless end (setq end (length string))) (let* ((font-info (or (gethash font-name *font-metrics*) (error "Unknown font ~S." font-name))) (char-metrics (font-info-char-infos font-info)) (scale (/ size 1000)) (width 0) (upper-width 0) (upper-height 0) (descent 0) (ascent 0) (upper-baseline 0)) (loop for i from start below end for char = (aref string i) do (cond ((char= char #\Newline) (maxf upper-width width) (setf width 0) (incf upper-baseline (+ ascent descent)) (maxf upper-height (+ ascent descent)) (setf descent 0) (setf ascent 0)) (t (let ((metrics (gethash (aref *iso-latin-1-symbolic-names* (char-code char)) char-metrics))) (incf width (char-width metrics)) (maxf ascent (char-ascent metrics)) (maxf descent (char-descent metrics)))))) (values (* scale (max width upper-width)) (* scale (+ ascent descent upper-height)) (* scale width) (* scale upper-height) (* scale (+ upper-height ascent))))) ;? ;;; (defconstant +postscript-fonts+ '(:fix ((:roman . "Courier") (:bold . "Courier-Bold") (:italic . "Courier-Oblique") ((:bold :italic) . "Courier-BoldOblique")) :serif ((:roman . "Times-Roman") (:bold . "Times-Bold") (:italic . "Times-Italic") ((:bold :italic) . "Times-BoldItalic")) :sans-serif ((:roman . "Helvetica") (:bold . "Helvetica-Bold") (:italic . "Helvetica-Oblique") ((:bold :italic) . "Helvetica-BoldOblique")))) (defconstant +postscript-font-sizes+ '(:normal 14 :tiny 8 :very-small 10 :small 12 :large 18 :very-large 20 :huge 24)) (defmethod text-style-mapping ((port postscript-port) text-style &optional character-set) (declare (ignore character-set)) (or (gethash text-style (port-text-style-mappings port)) (multiple-value-bind (family face size) (text-style-components text-style) (let* ((family-fonts (or (getf +postscript-fonts+ family) (getf +postscript-fonts+ :fix))) (font-name (cdr (or (assoc face family-fonts :test #'equal) (assoc :roman family-fonts)))) (size-number (if (numberp size) (round size) (or (getf +postscript-font-sizes+ size) (getf +postscript-font-sizes+ :normal))))) (cons font-name size-number))))) (defmethod (setf text-style-mapping) (mapping (port postscript-port) (text-style text-style) &optional character-set) (declare (ignore character-set)) (cond ((and (consp mapping) (stringp (car mapping)) (numberp (cdr mapping))) (when (not (gethash (car mapping) *font-metrics*)) (cerror "Ignore." "Mapping text style ~S to an unknown font ~S." text-style (car mapping))) (setf (gethash text-style (port-text-style-mappings port)) mapping)) (t (when (not (gethash mapping *font-metrics*)) (cerror "Ignore." "Mapping text style ~S to an unknown font ~S." text-style mapping)) (setf (gethash text-style (port-text-style-mappings port)) mapping)))) ;; The following four functions should be rewritten: AFM contains all ;; needed information (defmethod text-style-ascent (text-style (medium postscript-medium)) (let* ((font-name (text-style-mapping (port medium) (merge-text-styles text-style (medium-merged-text-style medium)))) (font-info (or (gethash (%font-name-metrics-key font-name) *font-metrics*) (error "Unknown font ~S." font-name))) (size (%font-name-size font-name))) (* (/ size 1000) (font-info-ascent font-info)))) (defmethod text-style-descent (text-style (medium postscript-medium)) (let* ((font-name (text-style-mapping (port medium) (merge-text-styles text-style (medium-merged-text-style medium)))) (font-info (or (gethash (%font-name-metrics-key font-name) *font-metrics*) (error "Unknown font ~S." font-name))) (size (%font-name-size font-name))) (* (/ size 1000) (font-info-descent font-info)))) (defmethod text-style-height (text-style (medium postscript-medium)) (multiple-value-bind (width height final-x final-y baseline) (text-size medium "Iq" :text-style text-style) (declare (ignore width final-x final-y baseline)) height)) (defmethod text-style-width (text-style (medium postscript-medium)) (multiple-value-bind (width height final-x final-y baseline) (text-size medium "M" :text-style text-style) (declare (ignore height final-x final-y baseline)) width)) (defmethod climi::text-bounding-rectangle* ((medium postscript-medium) string &key text-style (start 0) end) (when (characterp string) (setf string (make-string 1 :initial-element string))) (unless end (setf end (length string))) (unless text-style (setf text-style (medium-text-style medium))) (let* ((font-name (text-style-mapping (port medium) (merge-text-styles text-style (medium-merged-text-style medium)))) (metrics-key (%font-name-metrics-key font-name)) (size (%font-name-size font-name))) (let ((scale (/ size 1000))) (cond ((= start end) (values 0 0 0 0)) (t (let ((position-newline (position #\newline string :start start))) (cond ((not (null position-newline)) (multiple-value-bind (width ascent descent left right font-ascent font-descent direction first-not-done) (psfont-text-extents metrics-key string :start start :end position-newline) (declare (ignore width font-ascent font-descent direction first-not-done)) (multiple-value-bind (minx miny maxx maxy) (climi::text-bounding-rectangle* medium string :text-style text-style :start (1+ position-newline) :end end) (declare (ignore miny)) (values (* scale (min minx left)) (* scale (- ascent)) (* scale (max maxx right)) (* scale (+ descent maxy)))))) (t (multiple-value-bind (width ascent descent left right font-ascent font-descent direction first-not-done) (psfont-text-extents metrics-key string :start start :end end) (declare (ignore width font-ascent font-descent direction first-not-done)) (values (* scale left) (* scale (- ascent)) (* scale right) (* scale descent))))))))))) (defun psfont-text-extents (metrics-key string &key (start 0) (end (length string))) (let* ((font-info (or (gethash metrics-key *font-metrics*) (error "Unknown font ~S." metrics-key))) (char-metrics (font-info-char-infos font-info)) (width (loop for i from start below end sum (char-width (gethash (aref *iso-latin-1-symbolic-names* (char-code (char string i))) char-metrics)))) (ascent (loop for i from start below end maximize (char-ascent (gethash (aref *iso-latin-1-symbolic-names* (char-code (char string i))) char-metrics)))) (descent (loop for i from start below end maximize (char-descent (gethash (aref *iso-latin-1-symbolic-names* (char-code (char string i))) char-metrics))))) (values width ascent descent (char-xmin (gethash (aref *iso-latin-1-symbolic-names* (char-code (char string start))) char-metrics)) (- width (- (char-width (gethash (aref *iso-latin-1-symbolic-names* (char-code (char string (1- end)))) char-metrics)) (char-xmax (gethash (aref *iso-latin-1-symbolic-names* (char-code (char string (1- end)))) char-metrics)))) (font-info-ascent font-info) (font-info-descent font-info) 0 end))) (defmethod text-size ((medium postscript-medium) string &key text-style (start 0) end) (when (characterp string) (setq string (string string))) (unless end (setq end (length string))) (let* ((font-name (text-style-mapping (port medium) (merge-text-styles text-style (medium-merged-text-style medium)))) (size (%font-name-size font-name)) (metrics-key (%font-name-metrics-key font-name))) (text-size-in-font metrics-key size string start (or end (length string))))) (defmethod invoke-with-text-style :around ((medium postscript-medium) continuation (text-style clim-internals::device-font-text-style)) (unless (member text-style (device-fonts medium)) (push text-style (device-fonts medium))) (call-next-method)) (defun write-font-to-postscript-stream (stream text-style) (with-open-file (font-stream (postscript-device-font-name-font-file (clim-internals::device-font-name text-style)) :direction :input :external-format :latin-1) (let ((font (make-string (file-length font-stream)))) (read-sequence font font-stream) (write-string font (postscript-medium-file-stream stream))))) (defmethod make-device-font-text-style ((port postscript-port) font-name) (check-type font-name postscript-device-font-name) (let ((text-style (make-instance 'clim-internals::device-font-text-style :display-device port :device-font-name font-name))) (multiple-value-bind (dict-name ascent descent angle char-infos) (with-open-file (stream (postscript-device-font-name-metrics-file font-name) :direction :input :external-format :latin-1) (clim-postscript::read-afm-stream stream)) (clim-postscript::define-font-metrics dict-name ascent descent angle char-infos font-name)) (setf (text-style-mapping port text-style) font-name) text-style)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/PostScript/graphics.lisp0000640000175000017500000005677010705412615023330 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-POSTSCRIPT -*- ;;; (c) copyright 2001 by ;;; Arnaud Rouanet (rouanet@emi.u-bordeaux.fr) ;;; Lionel Salabartan (salabart@emi.u-bordeaux.fr) ;;; (c) copyright 2002 by ;;; Alexey Dejneka (adejneka@comail.ru) ;;; Gilbert Baumann (unk6@rz.uni-karlsruhe.de) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; TODO: ;;; ;;; - clipping ;;; - - more regions to draw ;;; - (?) blending ;;; - MEDIUM-DRAW-TEXT* ;;; - - :towards-(x,y) ;;; - - landscape orientation ;;; - - (?) :transform-glyphs ;;; - POSTSCRIPT-ACTUALIZE-GRAPHICS-STATE: fix CLIPPING-REGION reusing logic ;;; - MEDIUM-DRAW-... should not duplicate code from POSTSCRIPT-ADD-PATH ;;; - structure this file ;;; - set miter limit? (in-package :clim-postscript) ;;; Postscript output utilities (defun write-number (stream number) (format stream "~,3F " (coerce number 'single-float))) (defun write-angle (stream angle) (write-number stream (* angle (/ 180 pi)))) (defun write-coordinates (stream x y) (with-transformed-position (*transformation* x y) (write-number stream x) (write-number stream y))) (defun write-transformation* (stream mxx mxy myx myy tx ty) (write-char #\[ stream) (dolist (c (list mxx myx mxy myy tx ty)) (write-number stream c)) (write-string "] " stream)) ;;; Low level functions (defstruct postscript-procedure (name nil :type (or symbol string)) (body "" :type string)) (defvar *dictionary-name* "McCLIMDict") (defvar *procedures* (make-hash-table)) (defvar *extra-entries* 0) (defun write-postscript-dictionary (stream) ;;; FIXME: DSC (format stream "~&%%BeginProlog~%") (format stream "/~A ~D dict def ~2:*~A begin~%" *dictionary-name* (+ (hash-table-count *procedures*) *extra-entries*)) (loop for proc being each hash-value in *procedures* for name = (postscript-procedure-name proc) and body = (postscript-procedure-body proc) do (format stream "/~A { ~A } def~%" name body)) (format stream "end~%") (dump-reencode stream) (format stream "%%EndProlog~%")) (defmacro define-postscript-procedure ((name &key postscript-name postscript-body (extra-entries 0)) args &body body) (check-type name symbol) (check-type postscript-name (or symbol string)) (check-type postscript-body string) (check-type extra-entries unsigned-byte) `(progn (setf (gethash ',name *procedures*) (make-postscript-procedure :name ,postscript-name :body ,postscript-body)) (maxf *extra-entries* ,extra-entries) (defun ,name ,args ,@body))) ;;; (define-postscript-procedure (moveto* :postscript-name "m" :postscript-body "moveto") (stream x y) (write-coordinates stream x y) (format stream "m~%")) (define-postscript-procedure (lineto* :postscript-name "l" :postscript-body "lineto") (stream x y) (write-coordinates stream x y) (format stream "l~%")) (define-postscript-procedure (put-rectangle* :postscript-name "pr" :postscript-body "/y2 exch def /x2 exch def /y1 exch def /x1 exch def x1 y1 moveto x1 y2 lineto x2 y2 lineto x2 y1 lineto x1 y1 lineto" :extra-entries 4) (stream x1 y1 x2 y2) (write-coordinates stream x1 y1) (write-coordinates stream x2 y2) (format stream "pr~%")) (define-postscript-procedure (put-line* :postscript-name "pl" :postscript-body "moveto lineto") (stream x1 y1 x2 y2) (write-coordinates stream x2 y2) (write-coordinates stream x1 y1) (format stream "pl~%")) (define-postscript-procedure (put-ellipse :postscript-name "pe" :postscript-body ;; filled end-angle start-angle trans "matrix currentmatrix 5 1 roll concat dup rotate sub 1 0 moveto 0 0 1 0 5 -1 roll arc { 0 0 lineto 1 0 lineto } {} ifelse setmatrix") (stream ellipse filled) (multiple-value-bind (ndx1 ndy1 ndx2 ndy2) (ellipse-normal-radii* ellipse) (let* ((center (ellipse-center-point ellipse)) (cx (point-x center)) (cy (point-y center)) (tr (make-transformation ndx2 ndx1 ndy2 ndy1 cx cy)) (circle (untransform-region tr ellipse)) ;; we need an extra minus sign because the rotation ;; convention for Postscript differs in chirality from the ;; abstract CLIM convention; we do a reflection ;; transformation to move the coordinates to the right ;; handedness, but then the sense of positive rotation is ;; backwards, so we need this reflection for angles. -- ;; CSR, 2005-08-01 (start-angle (- (or (ellipse-end-angle circle) 0))) (end-angle (- (or (ellipse-start-angle circle) (* -2 pi))))) (write-string (if filled "true " "false ") stream) (write-angle stream (if (< end-angle start-angle) (+ end-angle (* 2 pi)) end-angle)) (write-angle stream start-angle) (write-transformation* stream ndx2 ndx1 ndy2 ndy1 cx cy) (format stream "pe~%")))) ;;;; (defvar *transformation* nil "Native transformation") ;;; Postscript output utilities (defmacro with-graphics-state ((stream) &body body) `(invoke-with-graphics-state ,stream (lambda () ,@body))) (defun postscript-save-graphics-state (stream) (push (copy-list (first (slot-value stream 'graphics-state-stack))) (slot-value stream 'graphics-state-stack)) (when (stream-drawing-p stream) (format (postscript-stream-file-stream stream) "gsave~%"))) (defun postscript-restore-graphics-state (stream) (pop (slot-value stream 'graphics-state-stack)) (when (stream-drawing-p stream) (format (postscript-stream-file-stream stream) "grestore~%"))) (defun invoke-with-graphics-state (stream continuation) (postscript-save-graphics-state stream) (funcall continuation) (postscript-restore-graphics-state stream)) ;;; Postscript path functions (defgeneric postscript-add-path (stream region) (:documentation "Adds REGION (if it is a path) or its boundary (if it is an area) to the current path of STREAM.")) (defmethod postscript-add-path (stream (region (eql +nowhere+))) (declare (ignore stream))) (defmethod postscript-add-path (stream (region standard-region-union)) (map-over-region-set-regions (lambda (region) (postscript-add-path stream region)) region)) (defmethod postscript-add-path (stream (region standard-region-intersection)) (format stream "gsave~%") #+nil (format stream "initclip~%") (loop for subregion in (region-set-regions region) do (format stream "newpath~%") (postscript-add-path stream subregion) (format stream "clip~%")) (format stream "clippath false upath~%") (format stream "grestore~%") (format stream "uappend~%")) ;;; Primitive paths (defmethod postscript-add-path (stream (polygon polygon)) (let ((points (polygon-points polygon))) (moveto* stream (point-x (first points)) (point-y (first points))) (loop for point in (rest points) do (lineto* stream (point-x point) (point-y point))) (format stream "closepath~%"))) (defmethod postscript-add-path (stream (ellipse ellipse)) (let ((ellipse (transform-region *transformation* ellipse))) (put-ellipse stream ellipse t))) (defmethod postscript-add-path (stream (rs climi::standard-rectangle-set)) (map-over-region-set-regions (lambda (r) (postscript-add-path stream r)) rs)) ;;; Graphics state (defgeneric postscript-set-graphics-state (stream medium kind)) (defvar *postscript-graphics-states* '((:line-style . medium-line-style) (:color . medium-ink) (:clipping-region . medium-clipping-region) (:text-style . medium-text-style))) (defun postscript-current-state (medium kind) (funcall (cdr (assoc kind *postscript-graphics-states*)) medium)) (defmacro postscript-saved-state (medium kind) `(getf (postscript-medium-graphics-state ,medium) ,kind)) (defun postscript-actualize-graphics-state (stream medium &rest kinds) "Sets graphics parameters named in STATES." (loop for kind in (cons :clipping-region kinds) ;; every drawing function depends on clipping region ;; ;; KLUDGE: clipping-region MUST be actualized first due to its ;; dirty dealing with graphics state. -- APD, 2002-02-11 unless (eql (postscript-current-state medium kind) (postscript-saved-state medium kind)) do (postscript-set-graphics-state stream medium kind) (setf (postscript-saved-state medium kind) (postscript-current-state medium kind)))) ;;; Line style (defconstant +postscript-line-joints+ '(:miter 0 :round 1 :bevel 2 :none 0)) (defconstant +postscript-line-caps+ '(:butt 0 :round 1 :square 2 ; extended butt caps :no-end-point 0)) (defconstant +postscript-default-line-dashes+ '(30 30)) (defconstant +normal-line-width+ (/ 2.0 3.0)) (defun line-style-scale (line-style) (let ((unit (line-style-unit line-style))) (ecase unit (:normal +normal-line-width+) (:point 1) (:coordinate (error ":COORDINATE line unit is not implemented."))))) (defmethod line-style-effective-thickness (line-style (medium postscript-medium)) (* (line-style-thickness line-style) (line-style-scale line-style))) (defun medium-line-thickness (medium) (line-style-effective-thickness (medium-line-style medium) medium)) (defmethod postscript-set-graphics-state (stream medium (kind (eql :line-style))) (let* ((line-style (medium-line-style medium)) (scale (line-style-scale line-style))) (write-number stream (* scale (line-style-thickness line-style))) (format stream "setlinewidth ~A setlinejoin ~A setlinecap~%" (getf +postscript-line-joints+ (line-style-joint-shape line-style)) (getf +postscript-line-caps+ (line-style-cap-shape line-style))) (let ((dashes (line-style-dashes line-style))) (format stream "[") (mapc (lambda (l) (write-number stream (* scale l))) (if (eq dashes 't) +postscript-default-line-dashes+ dashes)) (format stream "] 0 setdash~%")))) ;;; Color (defgeneric medium-color-rgb (medium ink)) (defmethod medium-color-rgb (medium (ink (eql +foreground-ink+))) (medium-color-rgb medium (medium-foreground medium))) (defmethod medium-color-rgb (medium (ink (eql +background-ink+))) (medium-color-rgb medium (medium-background medium))) (defmethod medium-color-rgb (medium (ink color)) (declare (ignore medium)) (color-rgb ink)) (defmethod postscript-set-graphics-state (stream medium (kind (eql :color))) (multiple-value-bind (r g b) (medium-color-rgb medium (medium-ink medium)) (write-number stream r) (write-number stream g) (write-number stream b) (format stream "setrgbcolor~%"))) ;;; Clipping region (defgeneric postscript-set-clipping-region (stream region)) (defmethod postscript-set-clipping-region (stream region) (format stream "newpath~%") (postscript-add-path stream region) (format stream "clip~%")) (defmethod postscript-set-clipping-region (stream (region (eql +everywhere+))) (declare (ignore stream))) (defmethod postscript-set-clipping-region (stream (region (eql +nowhere+))) (format stream "newpath 0 0 moveto closepath clip~%")) (defmethod postscript-set-graphics-state (stream medium (kind (eql :clipping-region))) ;; FIXME: There is no way to enlarge clipping path. Current code ;; does only one level of saving graphics state, so we can restore ;; and save again GS to obtain an initial CP. It is ugly, but I see ;; no other way now. -- APD, 2002-02-11 (postscript-restore-graphics-state (medium-sheet medium)) (postscript-save-graphics-state (medium-sheet medium)) (postscript-set-clipping-region stream (medium-clipping-region medium))) ;;; Medium drawing functions ;;; FIXME: the following methods should share code with POSTSCRIPT-ADD-PATH (defmethod medium-draw-point* ((medium postscript-medium) x y) (let ((stream (postscript-medium-file-stream medium)) (*transformation* (sheet-native-transformation (medium-sheet medium))) (radius (/ (medium-line-thickness medium) 2))) (postscript-actualize-graphics-state stream medium :color) (format stream "newpath~%") (write-coordinates stream x y) (write-number stream radius) (format stream "0 360 arc~%") (format stream "fill~%"))) (defmethod medium-draw-points* ((medium postscript-medium) coord-seq) (let ((stream (postscript-medium-file-stream medium)) (*transformation* (sheet-native-transformation (medium-sheet medium))) (radius (/ (medium-line-thickness medium) 2))) (postscript-actualize-graphics-state stream medium :color) (map-repeated-sequence 'nil 2 (lambda (x y) (format stream "newpath~%") (write-coordinates stream x y) (write-number stream radius) (format stream "0 360 arc~%") (format stream "fill~%")) coord-seq))) (defmethod medium-draw-line* ((medium postscript-medium) x1 y1 x2 y2) (let ((stream (postscript-medium-file-stream medium)) (*transformation* (sheet-native-transformation (medium-sheet medium)))) (postscript-actualize-graphics-state stream medium :line-style :color) (format stream "newpath ") (put-line* stream x1 y1 x2 y2) (format stream "stroke~%"))) (defmethod medium-draw-lines* ((medium postscript-medium) coord-seq) (let ((stream (postscript-medium-file-stream medium)) (*transformation* (sheet-native-transformation (medium-sheet medium)))) (postscript-actualize-graphics-state stream medium :line-style :color) (format stream "newpath~%") (map-repeated-sequence 'nil 4 (lambda (x1 y1 x2 y2) (put-line* stream x1 y1 x2 y2)) coord-seq) (format stream "stroke~%"))) (defmethod medium-draw-polygon* ((medium postscript-medium) coord-seq closed filled) (assert (evenp (length coord-seq))) (let ((stream (postscript-medium-file-stream medium)) (*transformation* (sheet-native-transformation (medium-sheet medium)))) (postscript-actualize-graphics-state stream medium :line-style :color) (format stream "newpath~%") (let ((command "moveto")) (map-repeated-sequence 'nil 2 (lambda (x y) (write-coordinates stream x y) (format stream "~A~%" command) (setq command "lineto")) coord-seq)) (when closed (format stream "closepath~%")) (format stream (if filled "fill~%" "stroke~%")))) (defmethod medium-draw-rectangle* ((medium postscript-medium) x1 y1 x2 y2 filled) (let ((stream (postscript-medium-file-stream medium)) (*transformation* (sheet-native-transformation (medium-sheet medium)))) (postscript-actualize-graphics-state stream medium :line-style :color) (format stream "newpath~%") (put-rectangle* stream x1 y1 x2 y2) (format stream (if filled "fill~%" "stroke~%")))) (defmethod medium-draw-rectangles* ((medium postscript-medium) position-seq filled) (assert (evenp (length position-seq))) (let ((stream (postscript-medium-file-stream medium)) (*transformation* (sheet-native-transformation (medium-sheet medium)))) (postscript-actualize-graphics-state stream medium :line-style :color) (format stream "newpath~%") (map-repeated-sequence 'nil 4 (lambda (x1 y1 x2 y2) (put-rectangle* stream x1 y1 x2 y2)) position-seq) (format stream (if filled "fill~%" "stroke~%")))) (defmethod medium-draw-ellipse* ((medium postscript-medium) center-x center-y radius1-dx radius1-dy radius2-dx radius2-dy start-angle end-angle filled) (let* ((stream (postscript-medium-file-stream medium)) (*transformation* (sheet-native-transformation (medium-sheet medium))) (ellipse (transform-region *transformation* (make-ellipse* center-x center-y radius1-dx radius1-dy radius2-dx radius2-dy :start-angle start-angle :end-angle end-angle)))) (postscript-actualize-graphics-state stream medium :line-style :color) (format stream "newpath~%") (put-ellipse stream ellipse filled) (format stream (if filled "fill~%" "stroke~%")))) (defun medium-font (medium) (text-style-mapping (port medium) (medium-merged-text-style medium))) (defmethod postscript-set-graphics-state (stream medium (kind (eql :text-style))) (let* ((font-name (medium-font medium)) (font (%font-name-postscript-name font-name)) (size (%font-name-size font-name))) (pushnew font (slot-value (medium-sheet medium) 'document-fonts) :test #'string=) (format stream "/~A findfont ~D scalefont setfont~%" font size))) ;### evil hack. (defun postscript-escape-char (char) (case char (#\Linefeed "\\n") (#\Return "\\r") (#\Tab "\\t") (#\Backspace "\\b") (#\Page "\\f") (#\\ "\\\\") (#\( "\\(") (#\) "\\)") (t (if (standard-char-p char) (string char) (format nil "\\~3,'0O" (char-code char)))))) (defun postscript-escape-string (string) (apply #'concatenate 'string (map 'list #'postscript-escape-char string))) (defmethod medium-draw-text* ((medium postscript-medium) string x y start end align-x align-y toward-x toward-y transform-glyphs) (setq string (if (characterp string) (make-string 1 :initial-element string) (subseq string start end))) (let ((*transformation* (sheet-native-transformation (medium-sheet medium)))) (let ((file-stream (postscript-medium-file-stream medium))) (postscript-actualize-graphics-state file-stream medium :color :text-style) (with-graphics-state ((medium-sheet medium)) #+ignore (when transform-glyphs ;; ;; Now the harder part is that we also want to transform the glyphs, ;; which is rather painless in Postscript. BUT: the x/y coordinates ;; we get are already transformed coordinates, so what I do is ;; untransform them again and simply tell the postscript interpreter ;; our transformation matrix. --GB ;; ;; This code changes both the form of glyphs and the ;; direction of the text, which does not conform to the ;; specification. So I've disabled it. -- APD, 2002-06-03. (multiple-value-setq (x y) (untransform-position (medium-transformation medium) x y)) (multiple-value-bind (mxx mxy myx myy tx ty) (get-transformation (medium-transformation medium)) (format file-stream "initmatrix [~A ~A ~A ~A ~A ~A] concat~%" (format-postscript-number mxx) (format-postscript-number mxy) (format-postscript-number myx) (format-postscript-number myy) (format-postscript-number tx) (format-postscript-number ty)))) (multiple-value-bind (total-width total-height final-x final-y baseline) (let* ((font-name (medium-font medium)) (font (%font-name-metrics-key font-name)) (size (%font-name-size font-name))) (text-size-in-font font size string 0 nil)) (declare (ignore final-x final-y)) ;; Only one line? (setq x (ecase align-x (:left x) (:center (- x (/ total-width 2))) (:right (- x total-width)))) (setq y (ecase align-y (:baseline y) (:top (+ y baseline)) (:center (- y (- (/ total-height 2) baseline))) (:bottom (- y (- total-height baseline))))) (moveto* file-stream x y)) (format file-stream "(~A) show~%" (postscript-escape-string string)))))) ;;; Bezier support (defun %draw-bezier-area (stream area) (format stream "newpath~%") (let ((segments (climi::segments area))) (let ((p0 (slot-value (car segments) 'climi::p0))) (write-coordinates stream (point-x p0) (point-y p0)) (format stream "moveto~%")) (loop for segment in segments do (with-slots (climi::p1 climi::p2 climi::p3) segment (write-coordinates stream (point-x climi::p1) (point-y climi::p1)) (write-coordinates stream (point-x climi::p2) (point-y climi::p2)) (write-coordinates stream (point-x climi::p3) (point-y climi::p3)) (format stream "curveto~%"))) (format stream "fill~%"))) (defmethod climi::medium-draw-bezier-design* ((medium postscript-medium) (design climi::bezier-area)) (let ((stream (postscript-medium-file-stream medium)) (*transformation* (sheet-native-transformation (medium-sheet medium)))) (postscript-actualize-graphics-state stream medium :color) (%draw-bezier-area stream design))) (defmethod climi::medium-draw-bezier-design* ((medium postscript-medium) (design climi::bezier-union)) (let ((stream (postscript-medium-file-stream medium)) (*transformation* (sheet-native-transformation (medium-sheet medium)))) (postscript-actualize-graphics-state stream medium :color) (let ((tr (climi::transformation design))) (dolist (area (climi::areas design)) (%draw-bezier-area stream (transform-region tr area)))))) (defmethod climi::medium-draw-bezier-design* ((medium postscript-medium) (design climi::bezier-difference)) (let ((stream (postscript-medium-file-stream medium)) (*transformation* (sheet-native-transformation (medium-sheet medium)))) (postscript-actualize-graphics-state stream medium :color) (dolist (area (climi::positive-areas design)) (%draw-bezier-area stream area)) (with-drawing-options (medium :ink +background-ink+) (postscript-actualize-graphics-state stream medium :color) (dolist (area (climi::negative-areas design)) (%draw-bezier-area stream area))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Backends/PostScript/class.lisp0000644000175000017500000001105511345155772022635 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-POSTSCRIPT -*- ;;; (c) copyright 2001 by ;;; Arnaud Rouanet (rouanet@emi.u-bordeaux.fr) ;;; Lionel Salabartan (salabart@emi.u-bordeaux.fr) ;;; (c) copyright 2002 by ;;; Alexey Dejneka (adejneka@comail.ru) ;;; Gilbert Baumann (unk6@rz.uni-karlsruhe.de) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; TODO: ;;; Also missing IMO: ;;; ;;; - WITH-OUTPUT-TO-POSTSCRIPT-STREAM should offer a :PAPER-SIZE option. ;;; - NEW-PAGE should also offer to specify the page name. ;;; - device fonts are missing ;;; ;;;--GB (in-package :clim-postscript) ;;;; Medium (defclass postscript-medium (basic-medium) ((device-fonts :initform nil :accessor device-fonts))) (defmacro postscript-medium-graphics-state (medium) `(first (slot-value (medium-sheet ,medium) 'graphics-state-stack))) (defun postscript-medium-file-stream (medium) (postscript-stream-file-stream (medium-sheet medium))) ;;;; Stream (defvar *default-postscript-title* "") (defvar *default-postscript-for* #+unix (or (get-environment-variable "USER") "Unknown") #-unix "") (defclass postscript-stream (basic-sheet sheet-leaf-mixin sheet-mute-input-mixin permanent-medium-sheet-output-mixin sheet-mute-repainting-mixin ;; ? mirrored-sheet-mixin ;; FIXME: Tim Moore suggested (2006-02-06, mcclim-devel) that ;; this might better be a superclass of ;; STANDARD-OUTPUT-RECORDING-STREAM. This should be revisited ;; when we grow another non-interactive backend (maybe a cl-pdf ;; backend?). -- CSR. climi::updating-output-stream-mixin standard-extended-output-stream standard-output-recording-stream) ((file-stream :initarg :file-stream :reader postscript-stream-file-stream) (title :initarg :title) (for :initarg :for) (orientation :initarg :orientation) (paper :initarg :paper) (transformation :initarg :transformation :reader sheet-native-transformation) (current-page :initform 0) (document-fonts :initform '()) (graphics-state-stack :initform '()) (pages :initform nil :accessor postscript-pages))) (defun make-postscript-stream (file-stream port device-type multi-page scale-to-fit orientation header-comments) (declare (ignore multi-page scale-to-fit)) (unless device-type (setq device-type :a4)) (let ((title (or (getf header-comments :title) *default-postscript-title*)) (for (or (getf header-comments :for) *default-postscript-for*)) (region (case device-type ((:eps) +everywhere+) (t (paper-region device-type orientation)))) (transform (make-postscript-transformation device-type orientation))) (make-instance 'postscript-stream :file-stream file-stream :port port :title title :for for :orientation orientation :paper device-type :native-region region :region region :transformation transform))) ;;;; Port (defclass postscript-port (basic-port) ((stream #| :initarg :stream |# #| :initform (error "Unspecified stream.") |# ;; I think this is right, but BASIC-PORT accepts only ;; :SERVER-PATH initarg. -- APD, 2002-06-06 :reader postscript-port-stream))) ;;; FIXME!!! The following method should be removed. -- APD, 2002-06-06 (defmethod initialize-instance :after ((port postscript-port) &rest initargs &key server-path) (declare (ignore initargs)) (destructuring-bind (ps &key stream) server-path (assert (eq ps :ps)) (check-type stream stream) (setf (slot-value port 'stream) stream)))cl-mcclim-0.9.6.dfsg.cvs20100315.orig/views.lisp0000644000175000017500000000567611345155772017055 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2001 by Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) ;;; Views are defined here and not in presentations.lisp so that they ;;; can be referenced in the streams code. (defclass textual-view (view) ()) (defclass textual-menu-view (textual-view) ()) (defclass textual-dialog-view (textual-view) ()) (defclass gadget-view (view) ()) (defclass gadget-menu-view (gadget-view) ()) (defclass gadget-dialog-view (gadget-view) ()) (defclass pointer-documentation-view (textual-view) ()) ;;; Views described in the Franz User manual (CLIM 2.2)... (defclass toggle-button-view (gadget-view) ()) (defclass push-button-view (gadget-view) ()) (defclass radio-box-view (gadget-view) ()) (defclass check-box-view (gadget-view) ()) (defclass slider-view (gadget-view) ()) (defclass text-field-view (gadget-dialog-view) ((width :accessor width :initarg :width :initform nil))) (defclass text-editor-view (gadget-view) ()) (defclass list-pane-view (gadget-view) ()) (defclass option-pane-view (gadget-view) ()) (defparameter +textual-view+ (make-instance 'textual-view)) (defparameter +textual-menu-view+ (make-instance 'textual-menu-view)) (defparameter +textual-dialog-view+ (make-instance 'textual-dialog-view)) (defparameter +gadget-view+ (make-instance 'gadget-view)) (defparameter +gadget-menu-view+ (make-instance 'gadget-menu-view)) (defparameter +gadget-dialog-view+ (make-instance 'gadget-dialog-view)) (defparameter +pointer-documentation-view+ (make-instance 'pointer-documentation-view)) (defparameter +toggle-button-view+ (make-instance 'toggle-button-view)) (defparameter +push-button-view+ (make-instance 'push-button-view)) (defparameter +radio-box-view+ (make-instance 'radio-box-view)) (defparameter +slider-view+ (make-instance 'slider-view)) (defparameter +text-field-view+ (make-instance 'text-field-view)) (defparameter +text-editor-view+ (make-instance 'text-editor-view)) (defparameter +list-pane-view+ (make-instance 'list-pane-view)) (defparameter +option-pane-view+ (make-instance 'option-pane-view)) (defmethod stream-default-view (stream) (declare (ignore stream)) +textual-view+) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/sheets.lisp0000644000175000017500000013236511345155772017207 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com), ;;; (c) copyright 2000 by ;;; Iban Hatchondo (hatchond@emi.u-bordeaux.fr) ;;; Julien Boninfante (boninfan@emi.u-bordeaux.fr) ;;; Robert Strandh (strandh@labri.u-bordeaux.fr) ;;; (c) copyright 2001 by ;;; Arnaud Rouanet (rouanet@emi.u-bordeaux.fr) ;;; Lionel Salabartan (salabart@emi.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; The sheet protocol (in-package :clim-internals) (defgeneric raise-sheet-internal (sheet parent)) (defgeneric bury-sheet-internal (sheet parent)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; input protocol (defgeneric dispatch-event (client event)) (defgeneric queue-event (client event)) (defgeneric schedule-event (client event delay)) (defgeneric handle-event (client event)) (defgeneric event-read (client)) (defgeneric event-read-no-hang (client)) (defgeneric event-peek (client &optional event-type)) (defgeneric event-unread (client event)) (defgeneric event-listen (client)) ;(defgeneric sheet-direct-mirror (sheet)) ;(defgeneric sheet-mirrored-ancestor (sheet)) ;(defgeneric sheet-mirror (sheet)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; repaint protocol (defgeneric dispatch-repaint (sheet region)) ;(defgeneric queue-repaint (sheet region)) ;(defgeneric handle-repaint (sheet region)) ;(defgeneric repaint-sheet (sheet region)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; notification protocol (defgeneric note-sheet-grafted (sheet)) (defgeneric note-sheet-degrafted (sheet)) (defgeneric note-sheet-adopted (sheet)) (defgeneric note-sheet-disowned (sheet)) (defgeneric note-sheet-enabled (sheet)) (defgeneric note-sheet-disabled (sheet)) (defgeneric note-sheet-region-changed (sheet)) (defgeneric note-sheet-transformation-changed (sheet)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; sheet protocol class (defclass basic-sheet (sheet) ((region :type region :initarg :region :initform (make-bounding-rectangle 0 0 100 100) :accessor sheet-region) (native-transformation :type (or null transformation) ;:initform nil :initform +identity-transformation+ :writer %%set-sheet-native-transformation :reader %%sheet-native-transformation) (native-region :type (or null region) :initform nil) (device-transformation :type (or null transformation) :initform nil) (device-region :type (or null region) :initform nil) (pointer-cursor :accessor sheet-pointer-cursor :initarg :pointer-cursor :initform :default) (enabled-p :type boolean :initarg :enabled-p :initform t :accessor sheet-enabled-p))) ; Native region is volatile, and is only computed at the first request when it's equal to nil. ; Invalidate-cached-region method sets the native-region to nil. (defmethod sheet-parent ((sheet basic-sheet)) nil) (defmethod sheet-children ((sheet basic-sheet)) nil) (defmethod sheet-adopt-child ((sheet basic-sheet) (child sheet)) (error "~S attempting to adopt ~S" sheet child)) (defmethod sheet-adopt-child :after ((sheet basic-sheet) (child sheet)) (note-sheet-adopted child) (when (sheet-grafted-p sheet) (note-sheet-grafted child))) (define-condition sheet-is-not-child (error) ()) (defmethod sheet-disown-child :before ((sheet basic-sheet) (child sheet) &key (errorp t)) (when (and (not (member child (sheet-children sheet))) errorp) (error 'sheet-is-not-child))) (defmethod sheet-disown-child :after ((sheet basic-sheet) (child sheet) &key (errorp t)) (declare (ignore errorp)) (note-sheet-disowned child) (when (sheet-grafted-p sheet) (note-sheet-degrafted child))) (defmethod sheet-siblings ((sheet basic-sheet)) (when (not (sheet-parent sheet)) (error 'sheet-is-not-child)) (remove sheet (sheet-children (sheet-parent sheet)))) (defmethod sheet-enabled-children ((sheet basic-sheet)) (delete-if-not #'sheet-enabled-p (copy-list (sheet-children sheet)))) (defmethod sheet-ancestor-p ((sheet basic-sheet) (putative-ancestor sheet)) (or (eq sheet putative-ancestor) (and (sheet-parent sheet) (sheet-ancestor-p (sheet-parent sheet) putative-ancestor)))) (defmethod raise-sheet ((sheet basic-sheet)) (error 'sheet-is-not-child)) (defmethod bury-sheet ((sheet basic-sheet)) (error 'sheet-is-not-child)) (define-condition sheet-ordering-underspecified (error) ()) (defmethod reorder-sheets ((sheet basic-sheet) new-ordering) (when (set-difference (sheet-children sheet) new-ordering) (error 'sheet-ordering-underspecified)) (when (set-difference new-ordering (sheet-children sheet)) (error 'sheet-is-not-child)) (setf (sheet-children sheet) new-ordering) sheet) (defmethod sheet-viewable-p ((sheet basic-sheet)) (and (sheet-parent sheet) (sheet-viewable-p (sheet-parent sheet)) (sheet-enabled-p sheet))) (defmethod sheet-occluding-sheets ((sheet basic-sheet) (child sheet)) (labels ((fun (l) (cond ((eq (car l) child) '()) ((and (sheet-enabled-p (car l)) (region-intersects-region-p (sheet-region (car l)) (sheet-region child))) (cons (car l) (fun (cdr l)))) (t (fun (cdr l)))))) (fun (sheet-children sheet)))) (defmethod map-over-sheets (function (sheet basic-sheet)) (funcall function sheet) (mapc #'(lambda (child) (map-over-sheets function child)) (sheet-children sheet)) nil) (defmethod (setf sheet-enabled-p) :after (enabled-p (sheet basic-sheet)) (if enabled-p (note-sheet-enabled sheet) (note-sheet-disabled sheet))) (defmethod sheet-transformation ((sheet basic-sheet)) (error "Attempting to get the TRANSFORMATION of a SHEET that doesn't contain one")) (defmethod (setf sheet-transformation) (transformation (sheet basic-sheet)) (declare (ignore transformation)) (error "Attempting to set the TRANSFORMATION of a SHEET that doesn't contain one")) (defmethod move-sheet ((sheet basic-sheet) x y) (let ((transform (sheet-transformation sheet))) (multiple-value-bind (old-x old-y) (transform-position transform 0 0) (setf (sheet-transformation sheet) (compose-translation-with-transformation transform (- x old-x) (- y old-y)))))) (defmethod resize-sheet ((sheet basic-sheet) width height) (setf (sheet-region sheet) (make-bounding-rectangle 0 0 width height))) (defmethod move-and-resize-sheet ((sheet basic-sheet) x y width height) (move-sheet sheet x y) (resize-sheet sheet width height)) (defmethod map-sheet-position-to-parent ((sheet basic-sheet) x y) (declare (ignore x y)) (error "Sheet has no parent")) (defmethod map-sheet-position-to-child ((sheet basic-sheet) x y) (declare (ignore x y)) (error "Sheet has no parent")) (defmethod map-sheet-rectangle*-to-parent ((sheet basic-sheet) x1 y1 x2 y2) (declare (ignore x1 y1 x2 y2)) (error "Sheet has no parent")) (defmethod map-sheet-rectangle*-to-child ((sheet basic-sheet) x1 y1 x2 y2) (declare (ignore x1 y1 x2 y2)) (error "Sheet has no parent")) (defmethod map-over-sheets-containing-position (function (sheet basic-sheet) x y) (map-over-sheets #'(lambda (child) (multiple-value-bind (tx ty) (map-sheet-position-to-child child x y) (when (region-contains-position-p (sheet-region child) tx ty) (funcall function child)))) sheet)) (defmethod map-over-sheets-overlapping-region (function (sheet basic-sheet) region) (map-over-sheets #'(lambda (child) (when (region-intersects-region-p region (transform-region (if (eq child sheet) +identity-transformation+ (sheet-transformation child)) (sheet-region child))) (funcall function child))) sheet)) (defmethod child-containing-position ((sheet basic-sheet) x y) (loop for child in (sheet-children sheet) do (multiple-value-bind (tx ty) (map-sheet-position-to-child child x y) (if (and (sheet-enabled-p child) (region-contains-position-p (sheet-region child) tx ty)) (return child))))) (defmethod children-overlapping-region ((sheet basic-sheet) (region region)) (loop for child in (sheet-children sheet) if (and (sheet-enabled-p child) (region-intersects-region-p region (transform-region (sheet-transformation child) (sheet-region child)))) collect child)) (defmethod children-overlapping-rectangle* ((sheet basic-sheet) x1 y1 x2 y2) (children-overlapping-region sheet (make-rectangle* x1 y1 x2 y2))) (defmethod sheet-delta-transformation ((sheet basic-sheet) (ancestor (eql nil))) (cond ((sheet-parent sheet) (compose-transformations (sheet-transformation sheet) (sheet-delta-transformation (sheet-parent sheet) ancestor))) (t +identity-transformation+))) (define-condition sheet-is-not-ancestor (error) ()) (defmethod sheet-delta-transformation ((sheet basic-sheet) (ancestor sheet)) (cond ((eq sheet ancestor) +identity-transformation+) ((sheet-parent sheet) (compose-transformations (sheet-transformation sheet) (sheet-delta-transformation (sheet-parent sheet) ancestor))) (t (error 'sheet-is-not-ancestor)))) (defmethod sheet-allocated-region ((sheet basic-sheet) (child sheet)) (reduce #'region-difference (mapcar #'(lambda (child) (transform-region (sheet-transformation child) (sheet-region child))) (cons child (sheet-occluding-sheets sheet child))))) (defmethod sheet-direct-mirror ((sheet basic-sheet)) nil) (defmethod sheet-mirrored-ancestor ((sheet basic-sheet)) (if (sheet-parent sheet) (sheet-mirrored-ancestor (sheet-parent sheet)))) (defmethod sheet-mirror ((sheet basic-sheet)) (let ((mirrored-ancestor (sheet-mirrored-ancestor sheet))) (if mirrored-ancestor (sheet-direct-mirror mirrored-ancestor)))) (defmethod graft ((sheet basic-sheet)) nil) (defmethod note-sheet-grafted ((sheet basic-sheet)) (mapc #'note-sheet-grafted (sheet-children sheet))) (defmethod note-sheet-degrafted ((sheet basic-sheet)) (mapc #'note-sheet-degrafted (sheet-children sheet))) (defmethod note-sheet-adopted ((sheet basic-sheet)) (declare (ignorable sheet)) nil) (defmethod note-sheet-disowned ((sheet basic-sheet)) (declare (ignorable sheet)) nil) (defmethod note-sheet-enabled ((sheet basic-sheet)) (declare (ignorable sheet)) nil) (defmethod note-sheet-disabled ((sheet basic-sheet)) (declare (ignorable sheet)) nil) (defmethod note-sheet-region-changed ((sheet basic-sheet)) nil) ;have to change (defmethod note-sheet-transformation-changed ((sheet basic-sheet)) nil) (defmethod sheet-native-transformation ((sheet basic-sheet)) (with-slots (native-transformation) sheet (unless native-transformation (setf native-transformation (let ((parent (sheet-parent sheet))) (if parent (compose-transformations (sheet-native-transformation parent) (sheet-transformation sheet)) +identity-transformation+)))) native-transformation)) (defmethod sheet-native-region ((sheet basic-sheet)) (with-slots (native-region) sheet (unless native-region (let ((this-native-region (transform-region (sheet-native-transformation sheet) (sheet-region sheet))) (parent (sheet-parent sheet))) (setf native-region (if parent (region-intersection this-native-region (sheet-native-region parent)) this-native-region)))) native-region)) (defmethod sheet-device-transformation ((sheet basic-sheet)) (with-slots (device-transformation) sheet (unless device-transformation (setf device-transformation (let ((medium (sheet-medium sheet))) (compose-transformations (sheet-native-transformation sheet) (if medium (medium-transformation medium) +identity-transformation+))))) device-transformation)) (defmethod sheet-device-region ((sheet basic-sheet)) (with-slots (device-region) sheet (unless device-region (setf device-region (let ((medium (sheet-medium sheet))) (region-intersection (sheet-native-region sheet) (if medium (transform-region (sheet-device-transformation sheet) (medium-clipping-region medium)) +everywhere+))))) device-region)) (defmethod invalidate-cached-transformations ((sheet basic-sheet)) (with-slots (native-transformation device-transformation) sheet (setf native-transformation nil device-transformation nil)) (loop for child in (sheet-children sheet) do (invalidate-cached-transformations child))) (defmethod invalidate-cached-regions ((sheet basic-sheet)) (with-slots (native-region device-region) sheet (setf native-region nil device-region nil)) (loop for child in (sheet-children sheet) do (invalidate-cached-regions child))) (defmethod (setf sheet-transformation) :after (transformation (sheet basic-sheet)) (declare (ignore transformation)) (note-sheet-transformation-changed sheet) (invalidate-cached-transformations sheet) (invalidate-cached-regions sheet)) (defmethod (setf sheet-region) :after (region (sheet basic-sheet)) (declare (ignore region)) (note-sheet-region-changed sheet) (invalidate-cached-regions sheet)) (defmethod (setf sheet-pointer-cursor) :after (cursor (sheet basic-sheet)) (set-sheet-pointer-cursor (port sheet) sheet cursor)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; sheet parent mixin (defclass sheet-parent-mixin () ((parent :initform nil :accessor sheet-parent))) (define-condition sheet-already-has-parent (error) ()) (define-condition sheet-is-ancestor (error) ()) (defmethod sheet-adopt-child :before (sheet (child sheet-parent-mixin)) (when (sheet-parent child) (error 'sheet-already-has-parent)) (when (sheet-ancestor-p sheet child) (error 'sheet-is-ancestor))) (defmethod sheet-adopt-child :after (sheet (child sheet-parent-mixin)) (setf (sheet-parent child) sheet)) (defmethod sheet-disown-child :after (sheet (child sheet-parent-mixin) &key (errorp t)) (declare (ignore sheet errorp)) (setf (sheet-parent child) nil)) (defmethod raise-sheet ((sheet sheet-parent-mixin)) (when (sheet-parent sheet) (raise-sheet-internal sheet (sheet-parent sheet))) (when (sheet-direct-mirror sheet) (raise-mirror (port sheet) sheet))) (defmethod bury-sheet ((sheet sheet-parent-mixin)) (when (sheet-parent sheet) (bury-sheet-internal sheet (sheet-parent sheet))) (when (sheet-direct-mirror sheet) (bury-mirror (port sheet) sheet))) (defmethod graft ((sheet sheet-parent-mixin)) (and (sheet-parent sheet) (graft (sheet-parent sheet)))) (defmethod (setf sheet-transformation) :after (newvalue (sheet sheet-parent-mixin)) (declare (ignore newvalue)) #+nil(note-sheet-transformation-changed sheet)) (defmethod map-sheet-position-to-parent ((sheet sheet-parent-mixin) x y) (transform-position (sheet-transformation sheet) x y)) (defmethod map-sheet-position-to-child ((sheet sheet-parent-mixin) x y) (untransform-position (sheet-transformation sheet) x y)) (defmethod map-sheet-rectangle*-to-parent ((sheet sheet-parent-mixin) x1 y1 x2 y2) (transform-rectangle* (sheet-transformation sheet) x1 y1 x2 y2)) (defmethod map-sheet-rectangle*-to-child ((sheet sheet-parent-mixin) x1 y1 x2 y2) (untransform-rectangle* (sheet-transformation sheet) x1 y1 x2 y2)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; sheet leaf mixin (defclass sheet-leaf-mixin () ()) (defmethod sheet-children ((sheet sheet-leaf-mixin)) nil) (defmethod sheet-adopt-child ((sheet sheet-leaf-mixin) (child sheet)) (error "Leaf sheet attempting to adopt a child")) (defmethod sheet-disown-child ((sheet sheet-leaf-mixin) (child sheet) &key (errorp t)) (declare (ignorable errorp)) (error "Leaf sheet attempting to disown a child")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; sheet single child mixin (defclass sheet-single-child-mixin () ((child :initform nil :accessor sheet-child))) (defmethod sheet-children ((sheet sheet-single-child-mixin)) (and (sheet-child sheet) (list (sheet-child sheet)))) (define-condition sheet-supports-only-one-child (error) ()) (defmethod sheet-adopt-child :before ((sheet sheet-single-child-mixin) (child sheet-parent-mixin)) (when (sheet-child sheet) (error 'sheet-supports-only-one-child))) (defmethod sheet-adopt-child ((sheet sheet-single-child-mixin) (child sheet-parent-mixin)) (setf (sheet-child sheet) child)) (defmethod sheet-disown-child ((sheet sheet-single-child-mixin) (child sheet-parent-mixin) &key (errorp t)) (declare (ignore errorp)) (setf (sheet-child sheet) nil)) (defmethod raise-sheet-internal (sheet (parent sheet-single-child-mixin)) (declare (ignorable sheet parent)) (values)) (defmethod bury-sheet-internal (sheet (parent sheet-single-child-mixin)) (declare (ignorable sheet parent)) (values)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; sheet multiple child mixin (defclass sheet-multiple-child-mixin () ((children :initform nil :initarg :children :accessor sheet-children))) (defmethod sheet-adopt-child ((sheet sheet-multiple-child-mixin) (child sheet-parent-mixin)) (push child (sheet-children sheet))) (defmethod sheet-disown-child ((sheet sheet-multiple-child-mixin) (child sheet-parent-mixin) &key (errorp t)) (declare (ignore errorp)) (setf (sheet-children sheet) (delete child (sheet-children sheet)))) (defmethod raise-sheet-internal (sheet (parent sheet-multiple-child-mixin)) (setf (sheet-children parent) (cons sheet (delete sheet (sheet-children parent))))) (defmethod bury-sheet-internal (sheet (parent sheet-multiple-child-mixin)) (setf (sheet-children parent) (append (delete sheet (sheet-children parent)) (list sheet)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; sheet geometry classes (defclass sheet-identity-transformation-mixin () ()) (defmethod sheet-transformation ((sheet sheet-identity-transformation-mixin)) +identity-transformation+) (defclass sheet-transformation-mixin () ((transformation :initform +identity-transformation+ :initarg :transformation :accessor sheet-transformation))) (defclass sheet-translation-transformation-mixin (sheet-transformation-mixin) ()) (defmethod (setf sheet-transformation) :before ((transformation transformation) (sheet sheet-translation-transformation-mixin)) (if (not (translation-transformation-p transformation)) (error "Attempting to set the SHEET-TRANSFORMATION of a SHEET-TRANSLATION-TRANSFORMATION-MIXIN to a non translation transformation"))) (defclass sheet-y-inverting-transformation-mixin (sheet-transformation-mixin) () (:default-initargs :transformation (make-transformation 1 0 0 -1 0 0))) (defmethod (setf sheet-transformation) :before ((transformation transformation) (sheet sheet-y-inverting-transformation-mixin)) (if (not (y-inverting-transformation-p transformation)) (error "Attempting to set the SHEET-TRANSFORMATION of a SHEET-Y-INVERTING-TRANSFORMATION-MIXIN to a non Y inverting transformation"))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; mirrored sheet ;; We assume the following limitations of the host window systems: ;; ;; mirror transformations: ;; . can only be translations ;; . are limited to 16-bit signed integer deltas ;; ;; mirror regions: ;; . can only be axis-aligend rectangles ;; . min-x = min-y = 0 ;; . max-x, max-y < 2^16 ;; ;; These are the limitations of the X Window System. ;; (defclass mirrored-sheet-mixin () ((port :initform nil :initarg :port :accessor port) (mirror-transformation :documentation "Our idea of the current mirror transformation. Might not be correct if a foreign application changes our mirror's geometry." :initform +identity-transformation+ :accessor %sheet-mirror-transformation) (mirror-region :documentation "Our idea of the current mirror region. Might not be correct if a foreign application changes our mirror's geometry. Also note that this might be different from the sheet's native region." :initform nil :accessor %sheet-mirror-region))) (defmethod sheet-direct-mirror ((sheet mirrored-sheet-mixin)) (port-lookup-mirror (port sheet) sheet)) (defmethod (setf sheet-direct-mirror) (mirror (sheet mirrored-sheet-mixin)) (port-register-mirror (port sheet) sheet mirror)) (defmethod sheet-mirrored-ancestor ((sheet mirrored-sheet-mixin)) sheet) (defmethod sheet-mirror ((sheet mirrored-sheet-mixin)) (sheet-direct-mirror sheet)) (defmethod note-sheet-grafted :before ((sheet mirrored-sheet-mixin)) (unless (port sheet) (error "~S called on sheet ~S, which has no port?!" 'note-sheet-grafted sheet)) (realize-mirror (port sheet) sheet)) (defmethod note-sheet-degrafted :after ((sheet mirrored-sheet-mixin)) (destroy-mirror (port sheet) sheet)) (defmethod (setf sheet-region) :after (region (sheet mirrored-sheet-mixin)) (declare (ignore region)) #+nil(port-set-sheet-region (port sheet) sheet region) (update-mirror-geometry sheet) ) (defmethod note-sheet-transformation-changed ((sheet mirrored-sheet-mixin)) (update-mirror-geometry sheet)) (defmethod sheet-native-region ((sheet mirrored-sheet-mixin)) (with-slots (native-region) sheet (unless native-region (let ((this-region (transform-region (sheet-native-transformation sheet) (sheet-region sheet))) (parent (sheet-parent sheet))) (setf native-region (if parent (region-intersection this-region (transform-region (invert-transformation (%sheet-mirror-transformation sheet)) (sheet-native-region parent))) this-region)))) native-region)) (defmethod (setf sheet-enabled-p) :after (new-value (sheet mirrored-sheet-mixin)) (when (sheet-direct-mirror sheet) ;only do this if the sheet actually has a mirror (if new-value (port-enable-sheet (port sheet) sheet) (port-disable-sheet (port sheet) sheet)))) ;;; Reflecting a Sheet's Geometry to the Mirror (defmethod sheet-mirror-region ((sheet mirrored-sheet-mixin)) (cond ;; for grafts or top-level-sheet's always read the mirror region from ;; the server, since it is not under our control. ((or (null (sheet-parent sheet)) (null (sheet-parent (sheet-parent sheet)))) (make-rectangle* 0 0 #x10000 #x10000) #+nil (make-rectangle* 0 0 (port-mirror-width (port sheet) sheet) (port-mirror-height (port sheet) sheet))) (t ;; For other sheets just use the calculated value, saves a round trip. (or (%sheet-mirror-region sheet) ;; XXX what to do if the sheet has no idea about its region? ;; XXX can we consider calling sheet-mirror-region then an error? (make-rectangle* 0 0 #x10000 #x10000) )))) (defmethod sheet-native-transformation ((sheet mirrored-sheet-mixin)) ;; XXX hm... (with-slots (native-transformation) sheet (unless native-transformation (setf native-transformation (compose-transformations (invert-transformation (%sheet-mirror-transformation sheet)) (compose-transformations (sheet-native-transformation (sheet-parent sheet)) (sheet-transformation sheet))))) native-transformation)) (defmethod invalidate-cached-transformations ((sheet mirrored-sheet-mixin)) (with-slots (native-transformation device-transformation) sheet (setf ;; native-transformation nil XXX hm... device-transformation nil)) (loop for child in (sheet-children sheet) do (invalidate-cached-transformations child))) (defmethod effective-mirror-region ((sheet mirrored-sheet-mixin)) ;; XXX is this really needed, can't we deduce this information more easily? (let* ((parent (sheet-parent sheet)) (ancestor (and parent (sheet-mirrored-ancestor parent)))) (if ancestor (region-intersection (sheet-mirror-region sheet) (untransform-region (%sheet-mirror-transformation sheet) (effective-mirror-region ancestor))) (sheet-mirror-region sheet)))) ;;; Internal interface for enabling/disabling motion hints (defgeneric sheet-motion-hints (sheet) (:documentation "Returns t if motion hints are enabled for this sheet")) (defmethod sheet-motion-hints ((sheet mirrored-sheet-mixin)) (when (sheet-direct-mirror sheet) (port-motion-hints (port sheet) sheet))) (defgeneric (setf sheet-motion-hints) (val sheet)) (defmethod (setf sheet-motion-hints) (val (sheet mirrored-sheet-mixin)) (when (sheet-direct-mirror sheet) (setf (port-motion-hints (port sheet) sheet) val))) ;;;; Coordinate Swizzling ;; This implements what I call "coordinate swizzling", the illusion that ;; sheets can be arbitrary large. The key idea here is that there is a ;; certain kind freedom in choosing the native transformation. A little ;; diagram to illustrate the involved transformations: ;; ;; NT NT = native transformation ;; sheet ----------------> mirror PNT = parent's NT ;; | | MT = mirror transformation ;; | | T = sheet transformation ;; | | ;; T | | MT ;; | | ;; | | ;; | | ;; v PNT v ;; parent ----------------> parent ;; mirror ;; ;; To setup both the mirror transformation (MR) and the mirror region (MR), ;; we start with the mirror region. The window systems limitations are here: ;; We can only have a certain size and its upper-left corner must be at the ;; origin. ;; Now the parent already has a mirror region (PMR) assigned, which obeys to ;; the very same size restrictions. Since every part of MR outside of (PMR o ;; MT^1) is not visible, the first idea is to just clip it by the visible ;; part: ;; MR_1 = intersection (SR o NT, PMR o MT^-1) [mirror space] ;; Since both NT and MT^-1 are not yet known let us reformulate that region ;; in the parent mirror space: ;; MR_2 = MR_1 o MT [parent mirror space] ;; = intersection (SR o NT, PMR o MT^-1) o MT ;; = intersection (SR o NT o MT, PMR o MT^-1 o MT) ;; = intersection (SR o (T o PNT o MT^-1) o MT, PMR) ;; = intersection (SR o T o PNT, PMR) ;; MR_2 now is a good candidate for a mirror region. Unfortunately it is ;; still in parent mirror space, so we transform it back, yielding MR_3: ;; MR_3 = MR_2 o MT^-1 ;; = intersection (SR o T o PNT, PMR) o MT^-1 ;; Here the only unknown is the mirror transformation MT, we can still ;; choose any as long as the window system limitations are met for both MR ;; and MT. ;; 1. MT should be a translation, whose delta x and y components are within ;; limits. ;; 2. The size limitation of MR is already met, since MR_3's size is no ;; larger than PMR's size (which mets the limitations). [Remember that MT ;; was defined to be some translation]. ;; 3. MR_3's upper left corner should also be at the origin which nicely ;; defines MT^-1: Just choose this upper left corner coordinates as MT's x ;; and y deltas. ;; So we can meet all criteria. The NT can easily be set up by the identity: ;; NT = T o PNT o MT^-1 ;;; Notes ;; . when the native transformation changes, we need to: ;; a. Redraw the mirror's contents since the mapping from the sheet space ;; to the mirror space (that is the native transformation) just changed. ;; Translational changes in the native transformation can be catered by ;; blittering, but then have a nice synchronization problem: Suppose ;; a repaint event is underway as we blitter from some region R_1 to ;; region R_2. Say the repaint event's region intersects with R_1. In ;; this case we just blittered pixels which were considered dirty into ;; R_2. Redrawing R_1 now does not repair the defect, since R_2 now also ;; contains dirty pixels. => oops, redraw error. ;; ;; b. Since the above above calculation took the parent's native ;; transformation into account, (and even the naively wanted mirror ;; region depends on the parent's native transformation), we need to ;; redo mirror geometry calculation for any child. ;; ;; c. I imagine more aggressive output records which remember the actual ;; octets which need to be send to the X server. These would contain ;; mirror coordinates and will need to be recalculated, when the native ;; transformation changes. ;; => Changing the native transformation can be expensive, so we want a way ;; to minimize changes to the native transformation. ;; ;; What did we do? We clipped the wanted mirror region, SR o NT, inside the ;; parent's mirror region to meet the window system limitations. We can make ;; this clip region larger as long as we still come up with an mirror ;; region, which meets the limits. (defun update-mirror-geometry (sheet &key) "This function reflects the current sheet region and sheet transformation to the mirror. It also sets up the native transformation. This function is supposed to be called whenever one of the following happens: - the sheet's transformation changed - the sheet's region changed - the parent's native transformation changed - the parent's transformation changed - the parent's mirror region changed Also if the sheet's native transformation changes the mirror's contents need to be redrawn, which is achieved by calling PORT-DIRTY-MIRROR-REGION. Since changing the sheet's native transformation might thus be expensive, this function tries to minimize changes to it. (although it does not try very hard)." (let ((old-native-transformation (%%sheet-native-transformation sheet))) (cond ((null (sheet-parent sheet)) ;; Ugh, we have no parent, this must be the graft, we cannot resize it can we? nil) ;; ;; Otherwise, the native transformation has to changed or needs to be computed initially ;; (t (let* ((parent (sheet-parent sheet)) (sheet-region-in-native-parent ;; this now is the wanted sheet mirror region (transform-region (sheet-native-transformation parent) (transform-region (sheet-transformation sheet) (sheet-region sheet))))) (when (region-equal sheet-region-in-native-parent +nowhere+) ;; hmm (setf (%sheet-mirror-transformation sheet) (make-translation-transformation -5 -5)) (setf (%sheet-mirror-region sheet) (make-rectangle* 0 0 1 1)) (when (sheet-direct-mirror sheet) (port-set-mirror-region (port sheet) (sheet-direct-mirror sheet) (%sheet-mirror-region sheet)) (port-set-mirror-transformation (port sheet) (sheet-direct-mirror sheet) (%sheet-mirror-transformation sheet))) (return-from update-mirror-geometry)) ;; mx1 .. my2 are is now the wanted mirror region in the parent ;; coordinate system. (with-bounding-rectangle* (mx1 my1 mx2 my2) sheet-region-in-native-parent (let (;; pw, ph is the width/height of the parent (pw (bounding-rectangle-width (sheet-mirror-region parent))) (ph (bounding-rectangle-height (sheet-mirror-region parent)))) (labels ((choose (MT) ;; -> fits-p mirror-region (multiple-value-bind (x1 y1) (transform-position MT 0 0) (let ((x2 (if (<= mx2 pw) mx2 (floor (+ pw (min mx2 (+ #x8000 x1) #x8000)) 2))) (y2 (if (<= my2 ph) my2 (floor (+ ph (min my2 (+ #x8000 y1) #x8000)) 2)))) (when (and (< (- x2 x1) #x8000) (or (<= (max (- pw #x8000) mx1) x1 0) (coordinate= x1 mx1)) (< (- y2 y1) #x8000) (or (<= (max (- pw #x8000) my1) y1 0) (coordinate= y1 my1)) (> (round (- x2 x1)) 0) (> (round (- y2 y1)) 0)) (values t (make-rectangle* 0 0 (round (- x2 x1)) (round (- y2 y1))))))))) ;; ;; Try reusing the native transformation: ;; (when old-native-transformation (let ((MT (compose-transformations (compose-transformations (sheet-native-transformation (sheet-parent sheet)) (sheet-transformation sheet)) (invert-transformation old-native-transformation)))) (multiple-value-bind (fits-p MR) (choose MT) (when fits-p (setf (%sheet-mirror-region sheet) MR) (setf (%sheet-mirror-transformation sheet) MT) (when (sheet-direct-mirror sheet) (let ((port (port sheet)) (mirror (sheet-direct-mirror sheet))) (port-set-mirror-region port mirror MR) (port-set-mirror-transformation port mirror MT))) (return-from update-mirror-geometry nil) )))) ;; ;; Try reusing the mirror transformation: ;; ' (let ((MT (%sheet-mirror-transformation sheet))) (when MT (multiple-value-bind (fits-p MR) (choose MT) (when fits-p (let ((native-transformation ;; NT = T o PNT o -MT (compose-transformations (invert-transformation MT) (compose-transformations (sheet-native-transformation (sheet-parent sheet)) (sheet-transformation sheet))))) ;; finally reflect the change to the host window system (setf (%sheet-mirror-region sheet) MR) (setf (%sheet-mirror-transformation sheet) MT) (when (sheet-direct-mirror sheet) (let ((port (port sheet)) (mirror (sheet-direct-mirror sheet))) (port-set-mirror-region port mirror MR) (port-set-mirror-transformation port mirror MT))) ;; update the native transformation if neccessary. (unless (and old-native-transformation (transformation-equal native-transformation old-native-transformation)) (invalidate-cached-transformations sheet) (%%set-sheet-native-transformation native-transformation sheet) (when old-native-transformation (care-for-new-native-transformation sheet old-native-transformation native-transformation)))) (return-from update-mirror-geometry nil) )))) ;; Otherwise just choose ;; Conditions to be met: ;; x2 < #x8000 + x1 ;; x1 in [max(pw - #x8000, mx1), 0] u {mx1} ;; x2 in [pw, min (#x8000, mx2)] u {mx2} ;; ;; It can still happend, that we cannot meet the ;; window system limitations => the sheet is ;; unvisible. (let* ((x1 (if (>= mx1 0) (round mx1) (floor (max (- pw #x8000) mx1) 2))) (y1 (if (>= my1 0) (round my1) (floor (max (- ph #x8000) my1) 2))) (x2 (if (<= mx2 pw) mx2 (floor (+ pw (min mx2 (- #x8000 x1))) 2))) (y2 (if (<= my2 ph) my2 (floor (+ ph (min my2 (- #x8000 y1))) 2))) (MT (make-translation-transformation x1 y1)) (MR (make-rectangle* 0 0 (round (- x2 x1)) (round (- y2 y1)))) (native-transformation ;; NT = T o PNT o -MT (compose-transformations (invert-transformation MT) (compose-transformations (sheet-native-transformation (sheet-parent sheet)) (sheet-transformation sheet)))) (old-native-transformation (%%sheet-native-transformation sheet))) (cond ((and (> (round (- x2 x1)) 0) (> (round (- y2 y1)) 0)) ;; finally reflect the change to the host window system (setf (%sheet-mirror-region sheet) MR) (setf (%sheet-mirror-transformation sheet) MT) (when (sheet-direct-mirror sheet) (let ((port (port sheet)) (mirror (sheet-direct-mirror sheet))) (port-set-mirror-region port mirror MR) (port-set-mirror-transformation port mirror MT))) ;; update the native transformation if neccessary. (unless (and old-native-transformation (transformation-equal native-transformation old-native-transformation)) (invalidate-cached-transformations sheet) (%%set-sheet-native-transformation native-transformation sheet) (when old-native-transformation (care-for-new-native-transformation sheet old-native-transformation native-transformation)))) (t (setf (%sheet-mirror-transformation sheet) (make-translation-transformation -5 -5)) (setf (%sheet-mirror-region sheet) (make-rectangle* 0 0 1 1)) (when (sheet-direct-mirror sheet) (port-set-mirror-region (port sheet) (sheet-direct-mirror sheet) (%sheet-mirror-region sheet)) (port-set-mirror-transformation (port sheet) (sheet-direct-mirror sheet) (%sheet-mirror-transformation sheet)))) )))))))))) (defun care-for-new-native-transformation (sheet old-native-transformation native-transformation) "Internal and helper for UPDATE-MIRROR-GEOMETRY. This is called in case the native transformation changed and takes care that the sheet contents get redrawn as appropriate. It also attempts to save some redraws by blittering." ;; ;; compute D := -NT_old o NT_new ;; ;; if D is a translation then ;; blitter from: (MR o -D) ^ MR to: (MR o D) ^ MR ;; clear MR \ (MR o -D) ;; else ;; clear MR ;; (let* (;; Compute the transformation to get from an old coordinate in ;; the mirror coordinate system to its new location. (delta (compose-transformations native-transformation (invert-transformation old-native-transformation))) ;; (MR (effective-mirror-region sheet))) (declare (ignorable delta)) ;; When this delta transformation is a translation, we can ;; possibly blitter the pixels. Otherwise not, since blittering ;; cannot account for say scaling or rotation. (cond ;;; <-- please leave this code commented out for now --> ;;; ;; Blittering will never work reliable soon. ;;; ;; --GB ;;; ((translation-transformation-p delta) ;;; ;; We want to bitter. So compute, dMR, the region in mirror ;;; ;; coordinate space where MR should end up. Clip it to the actual ;;; ;; mirror, which gives us the destination rectangle. Transform this ;;; ;; destination back to the old space to get the source rectangle. ;;; ;; Finally compute the region, which is not occupied by the ;;; ;; destination and thus must be redrawn. ;;; ;; ;;; ;; Note that by using region operations, we automatically take care ;;; ;; for the case that the window was scrolled too far to reuse any ;;; ;; pixels. ;;; (let* ((dMR (transform-region delta MR)) ;;; (dest (region-intersection dMR MR)) ;;; (src (untransform-region delta dest)) ;;; (lack (region-difference MR dMR))) ;;; ;; Now actually blitter, take care for empty regions. ;;; (unless (or (region-equal src +nowhere+) ;;; (region-equal dest +nowhere+)) ;;; (let ((gc (xlib:create-gcontext :drawable (sheet-direct-mirror sheet)))) ;;; (xlib:copy-area (sheet-direct-mirror sheet) gc ;;; (floor (bounding-rectangle-min-x src)) ;;; (floor (bounding-rectangle-min-y src)) ;;; (floor (bounding-rectangle-width src)) ;;; (floor (bounding-rectangle-height src)) ;;; (sheet-direct-mirror sheet) ;;; (floor (bounding-rectangle-min-x dest)) ;;; (floor (bounding-rectangle-min-y dest)))) ) ;;; ;; And handle the exposure ;;; (unless (region-equal lack +nowhere+) ;;; (xlib:clear-area (sheet-direct-mirror sheet) ;;; :x (floor (bounding-rectangle-min-x lack)) ;;; :y (floor (bounding-rectangle-min-y lack)) ;;; :width (floor (bounding-rectangle-width lack)) ;;; :height (floor (bounding-rectangle-height lack)) ;;; :exposures-p nil) ;;; (handle-repaint sheet (untransform-region native-transformation lack))))) (t ;; Full sheet contents need to be redrawn, since transformation is no ;; translation. (dispatch-repaint sheet (untransform-region native-transformation MR)) )))) ;;; Sheets as bounding rectangles ;; Somewhat hidden in the spec, we read (section 4.1.1 "The Bounding ;; Rectangle Protocol") ;; ;; | bounding-rectangle* region [Generic Function] ;; | ;; | [...] The argument region must be either a bounded region [...] or ;; | some other object that obeys the bounding rectangle protocol, such ;; | as a sheet or an output record. [...] (defmethod bounding-rectangle* ((sheet sheet)) (bounding-rectangle* (sheet-region sheet))) ;;; The null sheet (defclass null-sheet (basic-sheet) ()) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/events.lisp0000640000175000017500000002543210705412611017173 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com) ;;; (c) copyright 2000 by ;;; Iban Hatchondo (hatchond@emi.u-bordeaux.fr) ;;; Julien Boninfante (boninfan@emi.u-bordeaux.fr) ;;; Robert Strandh (strandh@labri.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) ;;; ------------------------------------------------------------------------------------------ ;;; Events ;;; ;; The event objects are defined similar to the CLIM event hierarchy. ;; ;; Class hierarchy as in CLIM: ;; ;; event ;; device-event ;; keyboard-event ;; key-press-event ;; key-release-event ;; pointer-event ;; pointer-button-event ;; pointer-button-press-event ;; pointer-button-release-event ;; pointer-button-hold-event ;; pointer-motion-event ;; pointer-boundary-event ;; pointer-enter-event ;; pointer-exit-event ;; window-event ;; window-configuration-event ;; window-repaint-event ;; window-manager-event ;; window-manager-delete-event ;; timer-event ;; (defvar *last-timestamp* 0) (defvar *last-timestamp-lock* (make-lock)) (defclass standard-event (event) ((timestamp :initarg :timestamp :initform nil :reader event-timestamp) ;; This slot is pretty much required in order to call handle-event. Some ;; events have something other than a sheet in this slot, which is gross. (sheet :initarg :sheet :reader event-sheet))) (defmethod initialize-instance :after ((event standard-event) &rest initargs) (declare (ignore initargs)) (let ((timestamp (event-timestamp event))) (with-lock-held (*last-timestamp-lock*) (if timestamp (maxf *last-timestamp* timestamp) (setf (slot-value event 'timestamp) (incf *last-timestamp*)))))) ;; ### method deleted, since it is defined below in a less obfuscated ;; way. ;; --GB 2002-11-20 ;(defmethod event-type ((event event)) ; (let* ((type (string (type-of event))) ; (position (search "-EVENT" type))) ; (if (null position) ; :event ; (intern (subseq type 0 position) :keyword)))) ;;; Reintroduce something like that definition, with defmethod goodness. ;;; -- moore (defmacro define-event-class (name supers slots &rest options) (let* ((event-tag (string '#:-event)) (name-string (string name)) (pos (search event-tag name-string :from-end t))) (when (or (null pos) (not (eql (+ pos (length event-tag)) (length name-string)))) (error "~S does not end in ~A and is not a valid event name for ~ define-event-class." name event-tag)) (let ((type (intern (subseq name-string 0 pos) :keyword))) `(progn (defclass ,name ,supers ,slots ,@options) (defmethod event-type ((event ,name)) ',type))))) (define-event-class device-event (standard-event) ((modifier-state :initarg :modifier-state :reader event-modifier-state) (x :initarg :x :reader device-event-native-x) (y :initarg :y :reader device-event-native-y) (graft-x :initarg :graft-x :reader device-event-native-graft-x) (graft-y :initarg :graft-y :reader device-event-native-graft-y))) (define-event-class keyboard-event (device-event) ((key-name :initarg :key-name :reader keyboard-event-key-name) (key-character :initarg :key-character :reader keyboard-event-character :initform nil))) (define-event-class key-press-event (keyboard-event) ()) (define-event-class key-release-event (keyboard-event) ()) (define-event-class pointer-event (device-event) ((pointer :initarg :pointer :reader pointer-event-pointer) (button :initarg :button :reader pointer-event-button) (x :reader pointer-event-native-x) (y :reader pointer-event-native-y) (graft-x :reader pointer-event-native-graft-x) (graft-y :reader pointer-event-native-graft-y) )) (defmacro get-pointer-position ((sheet event) &body body) (with-gensyms (event-var sheet-var x-var y-var) `(let* ((,sheet-var ,sheet) (,event-var ,event) (,x-var (device-event-native-x ,event-var)) (,y-var (device-event-native-y ,event-var))) (multiple-value-bind (x y) (if ,sheet-var (untransform-position (sheet-native-transformation ,sheet-var) ,x-var ,y-var) (values ,x-var ,y-var)) (declare (ignorable x y)) ,@body)))) (defmethod pointer-event-x ((event pointer-event)) (get-pointer-position ((event-sheet event) event) x)) (defmethod pointer-event-y ((event pointer-event)) (get-pointer-position ((event-sheet event) event) y)) (defgeneric pointer-event-position* (pointer-event)) (defmethod pointer-event-position* ((event pointer-event)) (get-pointer-position ((event-sheet event) event) (values x y))) (defgeneric device-event-x (device-event)) (defmethod device-event-x ((event device-event)) (get-pointer-position ((event-sheet event) event) x)) (defgeneric device-event-y (device-event)) (defmethod device-event-y ((event device-event)) (get-pointer-position ((event-sheet event) event) y)) (define-event-class pointer-button-event (pointer-event) ()) (define-event-class pointer-button-press-event (pointer-button-event) ()) (define-event-class pointer-button-release-event (pointer-button-event) ()) (define-event-class pointer-button-hold-event (pointer-button-event) ()) (define-event-class pointer-button-click-event (pointer-button-event) ()) (define-event-class pointer-button-double-click-event (pointer-button-event) ()) (define-event-class pointer-button-click-and-hold-event (pointer-button-event) ()) (define-event-class pointer-motion-event (pointer-event) ()) (defclass motion-hint-mixin () () (:documentation "A mixin class for events that are a motion hint; pointer location coordinates need to be fetched explicitly.")) (defclass pointer-motion-hint-event (pointer-motion-event motion-hint-mixin) ()) (define-event-class pointer-boundary-event (pointer-motion-event) ()) (define-event-class pointer-enter-event (pointer-boundary-event) ()) (define-event-class pointer-exit-event (pointer-boundary-event) ()) (define-event-class pointer-ungrab-event (pointer-exit-event) ()) (define-event-class window-event (standard-event) ((region :initarg :region :reader window-event-native-region))) (defmethod window-event-region ((event window-event)) (untransform-region (sheet-native-transformation (event-sheet event)) (window-event-native-region event))) (defmethod window-event-mirrored-sheet ((event window-event)) (sheet-mirror (event-sheet event))) (define-event-class window-configuration-event (window-event) ((x :initarg :x :reader window-configuration-event-native-x) (y :initarg :y :reader window-configuration-event-native-y) (width :initarg :width :reader window-configuration-event-width) (height :initarg :height :reader window-configuration-event-height))) (defmacro get-window-position ((sheet event) &body body) `(multiple-value-bind (x y) (transform-position (sheet-native-transformation ,sheet) (window-configuration-event-native-x ,event) (window-configuration-event-native-y ,event)) (declare (ignorable x y)) ,@body)) (defgeneric window-configuration-event-x (window-configuration-event)) (defmethod window-configuration-event-x ((event window-configuration-event)) (get-window-position ((event-sheet event) event) x)) (defgeneric window-configuration-event-y (window-configuration-event)) (defmethod window-configuration-event-y ((event window-configuration-event)) (get-window-position ((event-sheet event) event) y)) (define-event-class window-unmap-event (window-event) ()) (define-event-class window-destroy-event (window-event) ()) (define-event-class window-repaint-event (window-event) ()) (define-event-class window-manager-event (standard-event) ()) (define-event-class window-manager-delete-event (window-manager-event) ;; sheet (inherited from standard-event) is not required by the spec but we ;; need to know which window to delete - mikemac ()) (define-event-class timer-event (standard-event) ((token :initarg :token :reader event-token))) ;;; Constants dealing with events (defconstant +pointer-left-button+ #x01) (defconstant +pointer-middle-button+ #x02) (defconstant +pointer-right-button+ #x04) (defconstant +pointer-wheel-up+ #x08) (defconstant +pointer-wheel-down+ #x10) (defconstant +pointer-wheel-left+ #x20) (defconstant +pointer-wheel-right+ #x40) (defconstant +shift-key+ #x0100) (defconstant +control-key+ #x0200) (defconstant +meta-key+ #x0400) (defconstant +super-key+ #x0800) (defconstant +hyper-key+ #x1000) (defconstant +alt-key+ #x2000) (defmacro key-modifier-state-match-p (button modifier-state &body clauses) (let ((button-names '((:left . +pointer-left-button+) (:middle . +pointer-middle-button+) (:right . +pointer-right-button+) (:wheel-up . +pointer-wheel-up+) (:wheel-down . +pointer-wheel-down+))) (modifier-names '((:shift . +shift-key+) (:control . +control-key+) (:meta . +meta-key+) (:super . +super-key+) (:hyper . +hyper-key+))) (b (gensym)) (m (gensym))) (labels ((do-substitutes (c) (cond ((null c) nil) ((consp c) (cons (do-substitutes (car c)) (do-substitutes (cdr c)))) ((assoc c button-names) (list 'check-button (cdr (assoc c button-names)))) ((assoc c modifier-names) (list 'check-modifier (cdr (assoc c modifier-names)))) (t c)))) `(flet ((check-button (,b) (= ,button ,b)) (check-modifier (,m) (not (zerop (logand ,m ,modifier-state))))) (and ,@(do-substitutes clauses)))))) ;; Key names are a symbol whose value is port-specific. Key names ;; corresponding to the set of standard characters (such as the ;; alphanumerics) will be a symbol in the keyword package. ;; ???! cl-mcclim-0.9.6.dfsg.cvs20100315.orig/table-formatting.lisp0000644000175000017500000007423111345155772021150 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2001 by Alexey Dejneka (adejneka@comail.ru) ;;; (c) copyright 2003 by Gilbert Baumann ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; TODO: ;;; ;;; - Check types: RATIONAL, COORDINATE, REAL? ;;; - Check default values of unsupplied arguments. ;;; - Better error detection. ;;; - ;;; - Multiple columns: ;;; - - all columns are assumed to have the same width; ;;; - - all columns have the same number of rows; they should have the ;;; same height. ;;; - :MOVE-CURSOR T support. ;;; - All types of widths, heights. ;;; width, height too? ;;; - Item list formatting: what is :EQUALIZE-COLUMN-WIDTHS?! ;;; ;;; - We should think about inserting actual gutter into the output ;;; records so that the bounding box of a row or a cell it its ;;; logical dimension. ;;; - I would prefer if the INITIALIZE-INSTANCE would grok spacing and ;;; all. Hmm, is that correct? ;;; The question araise if we need to support something like: ;;; (formatting-row () ;;; (with-output-as-presentation () ;;; (formatting-cell ()) ;;; (formatting-cell ()))) ;;; Further: Should this table be somehow dynamic? That is when cell ;;; contents change also rerun the layout protocol? Or is that somehow ;;; covered by the incremental redisplay? ;;; Guess, we just do, it couldn't hurt. (in-package :clim-internals) (defvar *table-suppress-update* nil "Used to control whether changes to table cells propagate upwards.") ;;; Cell formatting ;;; STANDARD-CELL-OUTPUT-RECORD class (defclass standard-cell-output-record (cell-output-record standard-sequence-output-record) ((align-x :initarg :align-x :reader cell-align-x) (align-y :initarg :align-y :reader cell-align-y) (min-width :initarg :min-width :reader cell-min-width) (min-height :initarg :min-height :reader cell-min-height)) (:default-initargs :align-x :left :align-y :baseline :min-width 0 :min-height 0)) ;;; If this were a primary method it wouldn't override the default ;;; behavior for the parent being a compound-output-record because of ;;; the order of the argument list. (defmethod recompute-extent-for-changed-child :around (record (changed-child standard-cell-output-record) old-min-x old-min-y old-max-x old-max-y) (unless *table-suppress-update* (call-next-method)) record) (defun table-cell-allowed-as-child-of (record) "Internal. A predicate which decides whether 'record' can take a table cell as argument." ;; We allow a cell output record here if any ancestor is a ;; table-row, column or list-item. Note: This is probably not 100% ;; correct, as I have no idea what happens when you nest graphs and ;; tables ... (or (row-output-record-p record) (column-output-record-p record) (item-list-output-record-p record) (and (output-record-parent record) (table-cell-allowed-as-child-of (output-record-parent record))))) (defun assert-table-cell-allowed (record) "Internal. Assert that the a table cell is allowed here and if not barf." (unless (table-cell-allowed-as-child-of record) (error "Sorry ~S not within ~S, ~S or ~S." 'formatting-cell 'formatting-row 'formatting-column 'formatting-item-list))) (defmethod invoke-formatting-cell (stream cont &key (align-x :left) (align-y :baseline) (min-width 0) (min-height 0) (record-type 'standard-cell-output-record) &allow-other-keys) (invoke-with-new-output-record stream (lambda (stream record) (declare (ignore record)) (letf (((stream-cursor-position stream) (values 0 0))) (funcall cont stream))) record-type nil :align-x align-x :align-y align-y :min-width (parse-space stream min-width :horizontal) :min-height (parse-space stream min-height :vertical))) (defgeneric invoke-formatting-cell (stream cont &key align-x align-y min-width min-height record-type &allow-other-keys)) (defmacro formatting-cell ((&optional (stream t) &rest more &key align-x align-y (min-width 0) (min-height 0) (record-type ''standard-cell-output-record)) &body body) (declare (ignorable align-x align-y)) (setq stream (stream-designator-symbol stream '*standard-output*)) (with-keywords-removed (more (:record-type :min-width :min-height)) (with-gensyms (record) ;; Blow off order-of-evaluation issues for the moment... `(with-new-output-record (,stream ,record-type ,record ,@more :min-width (parse-space ,stream ,min-width :horizontal) :min-height (parse-space ,stream ,min-height :vertical)) (letf (((stream-cursor-position ,stream) (values 0 0))) ,@body))))) ;;; Generic block formatting (defclass block-output-record-mixn () () (:documentation "The class representing one-dimensional blocks of cells.")) (defgeneric map-over-block-cells (function block) (:documentation "Applies the FUNCTION to all cells in the BLOCK.")) (defmethod map-over-block-cells (function (block block-output-record-mixn)) ;; ### we need to do better (labels ((foo (row-record) (map-over-output-records (lambda (record) (if (cell-output-record-p record) (funcall function record) (foo record))) row-record))) (declare (dynamic-extent #'foo)) (foo block))) ;;; Row formatting (defgeneric map-over-row-cells (function row-record) (:documentation "Applies FUNCTION to all the cells in the row ROW-RECORD, skipping intervening non-table output record structures. FUNCTION is a function of one argument, an output record corresponding to a table cell within the row.")) ;;; STANDARD-ROW-OUTPUT-RECORD class (defclass standard-row-output-record (row-output-record block-output-record-mixn standard-sequence-output-record) ()) (defmethod map-over-row-cells (function (row-record standard-row-output-record)) (map-over-block-cells function row-record)) (defmacro formatting-row ((&optional (stream t) &rest more &key (record-type ''standard-row-output-record)) &body body) (setf stream (stream-designator-symbol stream '*standard-output*)) (with-gensyms (record) (with-keywords-removed (more (:record-type)) `(with-new-output-record (,stream ,record-type ,record ,@more) ,@body)))) (defgeneric invoke-formatting-row (stream cont record-type &rest initargs)) (defmethod invoke-formatting-row (stream cont record-type &rest initargs) (apply #'invoke-with-new-output-record stream (lambda (s r) (declare (ignore r)) (funcall cont s)) record-type initargs)) ;;; Column formatting (defgeneric map-over-column-cells (function column-record) (:documentation "Applies FUNCTION to all the cells in the column COLUMN-RECORD, skipping intervening non-table output record structures. FUNCTION is a function of one argument, an output record corresponding to a table cell within the column.")) ;;; STANDARD-COLUMN-OUTPUT-RECORD class (defclass standard-column-output-record (column-output-record block-output-record-mixn standard-sequence-output-record) ()) (defmethod map-over-column-cells (function (column-record standard-column-output-record)) (map-over-block-cells function column-record)) (defmacro formatting-column ((&optional (stream t) &rest more &key (record-type ''standard-column-output-record)) &body body) (setf stream (stream-designator-symbol stream '*standard-output*)) (with-gensyms (record) (with-keywords-removed (more (:record-type)) `(with-new-output-record (,stream ,record-type ,record ,@more) ,@body)))) (defgeneric invoke-formatting-column (stream cont record-type &rest initargs)) (defmethod invoke-formatting-column (stream cont record-type &rest initargs) (apply #'invoke-with-new-output-record stream (lambda (s r) r (funcall cont s)) record-type initargs)) ;;; Table formatting (defgeneric map-over-table-elements (function table-record type) (:documentation "Applies FUNCTION to all the rows or columns of TABLE-RECORD that are of type TYPE. TYPE is one of :ROW, :COLUMN or :ROW-OR-COLUMN. FUNCTION is a function of one argument. The function skips intervening non-table output record structures.")) (defgeneric adjust-table-cells (table-record stream)) (defgeneric adjust-multiple-columns (table-record stream)) ;;; STANDARD-TABLE-OUTPUT-RECORD class (defclass standard-table-output-record (table-output-record standard-sequence-output-record) (;; standard slots (x-spacing :initarg :x-spacing) (y-spacing :initarg :y-spacing) (multiple-columns :initarg :multiple-columns) (multiple-columns-x-spacing :initarg :multiple-columns-x-spacing) (equalize-column-widths :initarg :equalize-column-widths) ;; book keeping -- communication from adjust-table-cells to ;; adjust-multiple-columns (widths) (heights) ;needed? (rows))) (defmethod initialize-instance :after ((table standard-table-output-record) &rest initargs) (declare (ignore initargs)) (unless (slot-boundp table 'multiple-columns-x-spacing) (setf (slot-value table 'multiple-columns-x-spacing) (slot-value table 'x-spacing)))) (defmacro formatting-table ((&optional (stream t) &rest args &key x-spacing y-spacing multiple-columns multiple-columns-x-spacing equalize-column-widths (move-cursor t) (record-type ''standard-table-output-record) &allow-other-keys) &body body) (declare (ignore x-spacing y-spacing multiple-columns multiple-columns-x-spacing equalize-column-widths move-cursor record-type)) (gen-invoke-trampoline 'invoke-formatting-table (list (stream-designator-symbol stream '*standard-output*)) args body)) (defun invoke-formatting-table (stream continuation &key x-spacing y-spacing multiple-columns multiple-columns-x-spacing equalize-column-widths (move-cursor t) (record-type 'standard-table-output-record) &allow-other-keys) (setq x-spacing (parse-space stream (or x-spacing #\Space) :horizontal)) (setq y-spacing (parse-space stream (or y-spacing (stream-vertical-spacing stream)) :vertical)) (setq multiple-columns-x-spacing (if multiple-columns-x-spacing (parse-space stream multiple-columns-x-spacing :horizontal) x-spacing)) (with-new-output-record (stream record-type table :x-spacing x-spacing :y-spacing y-spacing :multiple-columns multiple-columns :multiple-columns-x-spacing multiple-columns-x-spacing :equalize-column-widths equalize-column-widths) (multiple-value-bind (cursor-old-x cursor-old-y) (stream-cursor-position stream) (let ((*table-suppress-update* t)) (with-output-recording-options (stream :record t :draw nil) (funcall continuation stream) (force-output stream)) (with-output-recording-options (stream :record nil :draw nil) (adjust-table-cells table stream) (when multiple-columns (adjust-multiple-columns table stream)) (setq *table-suppress-update* nil) (tree-recompute-extent table))) #+NIL (setf (output-record-position table) (values cursor-old-x cursor-old-y)) (replay table stream) (if move-cursor ;; FIXME!!! ;; Yeah, fix me -- what is wrong with that? (setf (stream-cursor-position stream) (values (bounding-rectangle-max-x table) (bounding-rectangle-max-y table))) (setf (stream-cursor-position stream) (values cursor-old-x cursor-old-y))))) (fit-pane-to-output stream)) ;;; Think about rewriting this using a common superclass for row and ;;; column records. (defmethod map-over-table-elements (function (table-record standard-table-output-record) (type (eql :row))) (labels ((row-mapper (table-record) (map-over-output-records (lambda (record) (if (row-output-record-p record) (funcall function record) (row-mapper record))) table-record))) (declare (dynamic-extent #'row-mapper)) (row-mapper table-record))) (defmethod map-over-table-elements (function (table-record standard-table-output-record) (type (eql :column))) (labels ((col-mapper (table-record) (map-over-output-records (lambda (record) (if (column-output-record-p record) (funcall function record) (col-mapper record))) table-record))) (declare (dynamic-extent #'col-mapper)) (col-mapper table-record))) (defmethod map-over-table-elements (function (table-record standard-table-output-record) (type (eql :row-or-column))) (labels ((row-and-col-mapper (table-record) (map-over-output-records (lambda (record) (if (or (row-output-record-p record) (column-output-record-p record)) (funcall function record) (row-and-col-mapper record))) table-record))) (declare (dynamic-extent #'row-and-col-mapper)) (row-and-col-mapper table-record))) ;;; Item list formatting (defgeneric map-over-item-cells (function item-list-record) ) (defgeneric adjust-item-list-cells (item-list-record stream)) (defclass standard-item-list-output-record (item-list-output-record block-output-record-mixn standard-sequence-output-record) ((x-spacing :initarg :x-spacing) (y-spacing :initarg :y-spacing) (initial-spacing :initarg :initial-spacing) (row-wise :initarg :row-wise) (n-rows :initarg :n-rows) (n-columns :initarg :n-columns) (max-width :initarg :max-width) (max-height :initarg :max-height))) (defmethod map-over-item-cells (function (item-list-record standard-item-list-output-record)) (map-over-block-cells function item-list-record)) (defun invoke-format-item-list (stream continuation &key x-spacing y-spacing n-columns n-rows max-width max-height initial-spacing (row-wise t) (move-cursor t) (record-type 'standard-item-list-output-record)) (setq x-spacing (parse-space stream (or x-spacing #\Space) :horizontal)) (setq y-spacing (parse-space stream (or y-spacing (stream-vertical-spacing stream)) :vertical)) (with-new-output-record (stream record-type item-list :x-spacing x-spacing :y-spacing y-spacing :initial-spacing initial-spacing :row-wise row-wise :n-rows n-rows :n-columns n-columns :max-width max-width :max-height max-height) (multiple-value-bind (cursor-old-x cursor-old-y) (stream-cursor-position stream) (with-output-recording-options (stream :record t :draw nil) (funcall continuation stream) (force-output stream)) (adjust-item-list-cells item-list stream) (setf (output-record-position item-list) (stream-cursor-position stream)) (if move-cursor (setf (stream-cursor-position stream) (values (bounding-rectangle-max-x item-list) (bounding-rectangle-max-y item-list))) (setf (stream-cursor-position stream) (values cursor-old-x cursor-old-y))) (replay item-list stream) item-list))) (defun format-items (items &rest args &key (stream *standard-output*) printer presentation-type cell-align-x cell-align-y &allow-other-keys) (let ((printer (if printer (if presentation-type #'(lambda (item stream) (with-output-as-presentation (stream item presentation-type) (funcall printer item stream))) printer) (if presentation-type #'(lambda (item stream) (present item presentation-type :stream stream)) #'prin1)))) (with-keywords-removed (args (:stream :printer :presentation-type :cell-align-x :cell-align-y)) (apply #'invoke-format-item-list stream #'(lambda (stream) (map nil #'(lambda (item) (formatting-cell (stream :align-x cell-align-x :align-y cell-align-y) (funcall printer item stream))) items)) args)))) (defmacro formatting-item-list ((&optional (stream t) &rest args &key x-spacing y-spacing n-columns n-rows stream-width stream-height max-width max-height initial-spacing (row-wise t) (move-cursor t) record-type &allow-other-keys) &body body) (declare (ignore x-spacing y-spacing n-columns n-rows stream-width stream-height max-width max-height initial-spacing row-wise move-cursor record-type)) (setf stream (stream-designator-symbol stream '*standard-output*)) (gen-invoke-trampoline 'invoke-format-item-list (list stream) args body)) ;;; Helper function (defun make-table-array (table-record) "Given a table record, creates an array of arrays of cells in row major order. Returns (array-of-cells number-of-rows number-of-columns)" (let* ((row-based (block find-table-type (map-over-table-elements (lambda (thing) (cond ((row-output-record-p thing) (return-from find-table-type t)) ((column-output-record-p thing) (return-from find-table-type nil)) (t (error "Something is wrong.")))) table-record :row-or-column) ;; It's empty (return-from make-table-array (values nil 0 0)))) (rows (make-array 1 :adjustable t :fill-pointer (if row-based 0 nil) :initial-element nil)) (number-of-columns 0)) (if row-based (map-over-table-elements (lambda (row) (let ((row-array (make-array 4 :adjustable t :fill-pointer 0))) (map-over-row-cells (lambda (cell) (vector-push-extend cell row-array)) row) (vector-push-extend row-array rows) (maxf number-of-columns (length row-array)))) table-record :row) (let ((col-index 0)) (map-over-table-elements (lambda (col) (let ((row-index 0)) (map-over-column-cells (lambda (cell) (when (>= row-index (length rows)) (adjust-array rows (1+ row-index) :initial-element nil)) (let ((row-array (aref rows row-index))) (cond ((null row-array) (setf row-array (make-array (1+ col-index) :adjustable t :initial-element nil)) (setf (aref rows row-index) row-array)) ((>= col-index (length row-array)) (adjust-array row-array (1+ col-index) :initial-element nil)) (t nil)) (setf (aref row-array col-index) cell)) (incf row-index)) col)) (incf col-index)) table-record :column) (setq number-of-columns col-index))) (values rows (length rows) number-of-columns))) (defmethod adjust-table-cells ((table-record standard-table-output-record) stream) (with-slots (x-spacing y-spacing equalize-column-widths) table-record ;; Note: for the purpose of layout it is pretty much irrelevant if ;; this is a table by rows or a table by columns ;; ;; Since we have :baseline vertical alignment (and no :char ;; horizontal alignment like in HTML), we always work from rows. (multiple-value-bind (rows nrows ncols) (make-table-array table-record) (unless rows (return-from adjust-table-cells nil)) (let ((widthen (make-array ncols :initial-element 0)) (heights (make-array nrows :initial-element 0)) (ascents (make-array nrows :initial-element 0)) (descents (make-array nrows :initial-element 0))) ;; collect widthen, heights (loop for row across rows for i from 0 do (loop for cell across row for j from 0 do ;; we have cell at row i col j at hand. ;; width: (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* cell) (maxf (aref widthen j) (max (- x2 x1) (cell-min-width cell))) (maxf (aref heights i) (max (- y2 y1) (cell-min-height cell))) (when (eq (cell-align-y cell) :baseline) (multiple-value-bind (baseline) (output-record-baseline cell) (maxf (aref ascents i) baseline) (maxf (aref descents i) (- y2 y1 baseline))))))) ;; baseline aligned cells can force the row to be taller. (loop for i from 0 below nrows do (maxf (aref heights i) (+ (aref ascents i) (aref descents i)))) (when (slot-value table-record 'equalize-column-widths) (setf widthen (make-array ncols :initial-element (reduce #'max widthen :initial-value 0)))) (setf (slot-value table-record 'widths) widthen (slot-value table-record 'heights) heights (slot-value table-record 'rows) rows) ;; Finally just put the cells where they belong. (multiple-value-bind (cx cy) (stream-cursor-position stream) (loop for row across rows for y = cy then (+ y h y-spacing) for h across heights for ascent across ascents do (loop for cell across row for x = cx then (+ x w x-spacing) for w across widthen do (adjust-cell* cell x y w h ascent)))))))) (defmethod adjust-multiple-columns ((table standard-table-output-record) stream) (with-slots (widths heights rows multiple-columns multiple-columns-x-spacing x-spacing y-spacing) table (let* ((mcolumn-width ;; total width of a column of the "meta" table. (+ (reduce #'+ widths) (* (1- (length widths)) x-spacing) multiple-columns-x-spacing)) (n-columns (max 1 (if (eq multiple-columns t) (floor (+ (- (stream-text-margin stream) (stream-cursor-position stream)) multiple-columns-x-spacing) (+ mcolumn-width multiple-columns-x-spacing)) multiple-columns))) (column-size (ceiling (length rows) n-columns)) ) (let ((y 0) (dy 0)) (loop for row across rows for h across heights for i from 0 do (multiple-value-bind (ci ri) (floor i column-size) (when (zerop ri) (setf dy (- y))) (let ((dx (* ci mcolumn-width))) (loop for cell across row do (multiple-value-bind (x y) (output-record-position cell) (setf (output-record-position cell) (values (+ x dx) (+ y dy)))))) (incf y h) (incf y y-spacing)))) ))) (defmethod adjust-item-list-cells ((item-list standard-item-list-output-record) stream) (with-slots (x-spacing y-spacing initial-spacing row-wise) item-list ;; ;; What we do: ;; ;; First we collect the items, then we figure out the width of the ;; single initial column. While doing so we collect the heights. (let ((items nil) (width 0) (heights nil)) ;; (map-over-item-cells (lambda (item) (push item items)) item-list) (setf items (reverse items)) (setf heights (make-array (length items))) ;; (loop for item in items for i from 0 do (with-bounding-rectangle* (x1 y1 x2 y2) item (maxf width (- x2 x1)) (setf (aref heights i) (- y2 y1)))) ;; ;; Now figure out the number of rows and the number of columns to ;; layout to. ;; (let ((stream-width (- (stream-text-margin stream) (stream-cursor-position stream) (if initial-spacing x-spacing 0))) (N (length items)) (column-width (+ width x-spacing))) ;; ### note that the floors below are still not correct (multiple-value-bind (n-columns n-rows) (with-slots (n-columns n-rows max-width max-height) item-list (cond (n-columns (values n-columns (ceiling N n-columns))) (n-rows (values (ceiling N n-rows) n-rows)) (max-width (let ((n-columns (max 1 (floor (+ max-width x-spacing) (+ column-width x-spacing))))) (values n-columns (ceiling N n-columns)))) (max-height ;; difficult ;; ### (let ((n-rows (max 1 (floor (+ max-height y-spacing) (+ (reduce #'max heights :initial-value 0) (* (1- (length heights)) y-spacing) y-spacing))))) (values (ceiling N n-rows) n-rows))) (t (let ((n-columns (max 1 (floor (+ stream-width x-spacing) (+ column-width x-spacing))))) (values n-columns (ceiling N n-columns)))))) ;; (cond (row-wise ;; Here is the catch: When this is row-wise, this not ;; not so different from a table. ;; ### do the cells put alongside expose baseline adjust? (let ((y 0)) (loop for yi below n-rows while items do (let ((h 0)) (loop for xi below n-columns for x = (if initial-spacing (floor x-spacing 2) 0) then (+ x width x-spacing) while items do (let ((item (pop items))) (maxf h (bounding-rectangle-height item)) (adjust-cell* item x y width (bounding-rectangle-height item) (output-record-baseline item)))) (incf y (+ h y-spacing)))))) (t ;; This is somewhat easier ... (let (h) (loop for xi below n-columns for x = (if initial-spacing (floor x-spacing 2) 0) then (+ x width x-spacing) while items do (loop for yi below n-rows for y = 0 then (+ y y-spacing h) while items do (let ((item (pop items))) (setf h (bounding-rectangle-height item)) (adjust-cell* item x y width h (output-record-baseline item))))))))))))) (defun adjust-cell* (cell x y w h ascent) (setf (output-record-position cell) (values (case (cell-align-x cell) ((nil :left) x) ;### (:center (+ x (/ (- w (bounding-rectangle-width cell)) 2))) (:right (- (+ x w) (bounding-rectangle-width cell)))) (case (cell-align-y cell) (:top y) (:bottom (- (+ y h) (bounding-rectangle-height cell))) (:center (+ y (/ (- h (bounding-rectangle-height cell)) 2))) ((nil :baseline) (multiple-value-bind (baseline) (output-record-baseline cell) ;; make (+ y ascents) line up with (+ y1 b) ;; that is y+a = y1+b -> y1= y+a-b (+ y (- ascent baseline)))))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/TODO0000600000175000017500000000610310423413274015457 0ustar pdmpdmTBM:20040123:204400 rescanning buffers with accept extents doesn't work reliably, especially in accepting-values. The default present methods, and those for Lisp types, should be more careful about :acceptably. In the same vein, command-line-command-unparser should be prepared to emit accept-extents (how?) if the arguments aren't acceptable as text. TBM:20031112:002300 These are TODO's from the 0.9 release notes. The listed functions are unimplemented unless otherwise noted. General designs need more work, particularly the support of compositing. make-design-from-output-record (setf* pointer-position) More spiffy presentation accept and present methods with-input-editor-typeout read-only extents in Goatee with-accept-help accepting-values needs a lot of work command-line-complete-input display-command-table-menu, menu-choose-command-from-table notify-user :accept-values panes display-command-menu restraining-pane RS:20030805:111640 Changing the sheet-transformation of a pane does not alter its native transformation, despite the fact that calls are made to invalidate-cached-transformations and note-sheet-transformation-changed. Perhaps this code is responsible: (defmethod invalidate-cached-transformations ((sheet mirrored-sheet-mixin)) (with-slots (native-transformation device-transformation) sheet (setf ;; native-transformation nil XXX hm... device-transformation nil)) (loop for child in (sheet-children sheet) do (invalidate-cached-transformations child))) RS:20030805:101708 The way the text-field pane handles keyboard input focus (by remembering who had it before and restoring it) does not work very well with respect to other X applications. It would be better for each pane to decide when it wants the input focus. ====================== Resolved issues ====================== TBM:20060323:175700 A compound output recording record structure based on R trees or another spatial data structure is needed. [Implemented by Christophe Rhodes and Andreas Fuchs]. drag-output-record, dragging-output define-drag-and-drop-translator raise-frame, bury-frame frame-drag-and-drop-feedback, frame-drag-and-drop-highlighting TBM:20040524:100000 command-enable TBM:20040121:150000 presentation type histories, frame-maintain-presentation-histories [This has been implemented but needs some work] presentation-default-processor [ The presentation generic function is defined and called, but there aren't real methods defined yet.] TBM:20031124:230300 command-or-form presentation type TBM:20031119:142500 presentation-single-box TBM:20031113:234700 surrounding-output-with-border - :move-cursor RS:20030805:102038 Output recording is broken for records that inherit from coord-seq-mixin. Contrary to comments in the code, the coordinate sequence is not transformed before the output record is created. [resolved by moore and hefner in various ways] cl-mcclim-0.9.6.dfsg.cvs20100315.orig/repaint.lisp0000644000175000017500000001100007751406762017340 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com), ;;; (c) copyright 2000 by ;;; Iban Hatchondo (hatchond@emi.u-bordeaux.fr) ;;; Julien Boninfante (boninfan@emi.u-bordeaux.fr) ;;; Robert Strandh (strandh@labri.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; The Repaint Protocol (in-package :clim-internals) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; repaint protocol functions (defmethod queue-repaint ((sheet basic-sheet) (event window-repaint-event)) (queue-event sheet event)) (defmethod handle-repaint ((sheet basic-sheet) region) (declare (ignore region)) nil) (defmethod repaint-sheet ((sheet basic-sheet) region) (map-over-sheets-overlapping-region #'(lambda (s) (handle-repaint s region)) sheet region)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; repaint protocol classes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; standard repainting mixin (defclass standard-repainting-mixin () ()) (defmethod dispatch-event ((sheet standard-repainting-mixin) (event window-repaint-event)) (queue-repaint sheet event)) (defmethod dispatch-repaint ((sheet standard-repainting-mixin) region) (when (sheet-mirror sheet) ;only dispatch repaints, when the sheet has a mirror (queue-repaint sheet (make-instance 'window-repaint-event :sheet sheet :region (transform-region (sheet-native-transformation sheet) region))))) (defmethod handle-event ((sheet standard-repainting-mixin) (event window-repaint-event)) (handle-repaint sheet (window-event-region event))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; immediate repainting mixin (defclass immediate-repainting-mixin () ()) (defmethod dispatch-event ((sheet immediate-repainting-mixin) (event window-repaint-event)) (handle-repaint sheet (window-event-region event))) (defmethod dispatch-repaint ((sheet immediate-repainting-mixin) region) (handle-repaint sheet region)) (defmethod handle-event ((sheet immediate-repainting-mixin) (event window-repaint-event)) (handle-repaint sheet (window-event-region event))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; sheet mute repainting mixin (defclass sheet-mute-repainting-mixin () ()) (defmethod dispatch-repaint ((sheet sheet-mute-repainting-mixin) region) (when (sheet-mirror sheet) ;only dispatch repaints, when the sheet has a mirror (queue-repaint sheet (make-instance 'window-repaint-event :sheet sheet :region (transform-region (sheet-native-transformation sheet) region))))) ;;; I know what the spec says about sheet-mute-repainting-mixin, but I don't ;;; think it's right; "repaint-sheet that does nothing" makes no sense. ;;; -- moore #+nil (defmethod repaint-sheet ((sheet sheet-mute-repainting-mixin) region) (declare (ignorable sheet region)) (format *trace-output* "repaint ~S~%" sheet) (values)) (defmethod handle-repaint ((sheet sheet-mute-repainting-mixin) region) (declare (ignore region)) nil) (defclass clim-repainting-mixin (#+clim-mp standard-repainting-mixin #-clim-mp immediate-repainting-mixin) () (:documentation "Internal class that implements repainting protocol based on whether or not multiprocessing is supported.")) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/clouseau.asd0000640000175000017500000000071110553705667017321 0ustar pdmpdm;;; -*- lisp -*- (defpackage :clouseau.system (:use :cl :asdf)) (in-package :clouseau.system) (defsystem :clouseau :depends-on (:mcclim) :serial t :components ((:module "Apps/Inspector" :pathname #.(make-pathname :directory '(:relative "Apps" "Inspector")) :components ((:file "package") (:file "disassembly" :depends-on ("package")) (:file "inspector" :depends-on ("disassembly"))))))cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Examples/0000755000175000017500000000000011347763775016601 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/Examples/stream-test.lisp0000644000175000017500000000472610177775467021754 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-DEMO -*- ;;; (c) copyright 2001 by ;;; Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-demo) (defclass echo-interactor-pane (interactor-pane) ()) (defvar *debug-echo* t) (defmethod handle-event :after ((stream echo-interactor-pane) (event key-press-event)) (let* ((buffer (stream-input-buffer stream)) (fill (fill-pointer buffer))) (when (> fill 0) ;Should always be true (let ((gesture (aref buffer (1- fill)))) (when (characterp gesture) (stream-write-char stream gesture)))))) (defmethod stream-read-gesture :around ((stream echo-interactor-pane) &key &allow-other-keys) (let* ((results (multiple-value-list (call-next-method))) (gesture (car results))) (when (and *debug-echo* gesture) (print gesture *trace-output*)) (values-list results))) #+nil (define-application-frame stream-test () () (:pane (vertically () (make-pane 'echo-interactor-pane)) )) (define-application-frame stream-test () () (:panes (tester (make-clim-stream-pane :type 'echo-interactor-pane))) (:layouts (default (vertically () tester)))) (defun run-test (name) ; (loop for port in climi::*all-ports* ; do (destroy-port port)) ; (setq climi::*all-ports* nil) (when name (run-frame-top-level (make-application-frame name)))) (defun echo-stream-test () (run-test 'stream-test)) (define-application-frame edit-test () () (:panes (tester :interactor)) (:layouts (default (vertically () tester)))) (defmethod read-frame-command ((frame edit-test) &key (stream *standard-input*)) (with-input-editing (stream) (call-next-method frame :stream stream))) (defun input-edit-test () (run-test 'edit-test)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Examples/sliderdemo.lisp0000644000175000017500000001317411345155772021615 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- ;;; (c) copyright 2000 by ;;; Iban Hatchondo (hatchond@emi.u-bordeaux.fr) ;;; Julien Boninfante (boninfan@emi.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-demo) (defparameter calc '(0)) (defvar *text-field* nil) (defun sliderdemo () (let ((frame (make-application-frame 'sliderdemo))) (run-frame-top-level frame))) (defmacro queue-number(int) `(lambda (gadget) (declare (ignore gadget)) (let ((last-item (first (last calc)))) (if (numberp last-item) (setf (car (last calc)) (+ (* 10 last-item) ,int)) (setf calc (nconc calc (list ,int)))) (setf (gadget-value *text-field*) (princ-to-string (first (last calc))))))) (defmacro queue-operator (operator) `(lambda (gadget) (declare (ignore gadget)) (do-operation t) (if (functionp (first (last calc))) (setf (first (last calc)) ,operator) (setf calc (nconc calc (list ,operator)))))) (defun do-operation (gadget) (declare (ignore gadget)) (when (= 3 (length calc)) (setf (car calc) (apply (second calc) (list (first calc) (third calc))) (cdr calc) nil) (setf (gadget-value *text-field*) (princ-to-string (first calc))))) (defun initac (gadget) (declare (ignore gadget)) (setf calc (list 0) (gadget-value *text-field*) (princ-to-string 0))) (defun initce (gadget) (declare (ignore gadget)) (let ((last-item (first (last calc)))) (unless (or (null calc) (not (numberp last-item))) (setf calc (butlast calc) (gadget-value *text-field*) (princ-to-string 0))))) (defun print-screen (gadget) (declare (ignore gadget))) (defun slide (gadget value) (declare (ignore gadget)) (setf (gadget-value *text-field*) (princ-to-string value))) (defun find-text-field (frame) (first (member-if #'(lambda (gadget) (typep gadget 'text-field)) (frame-current-panes frame)))) (defmethod sliderdemo-frame-top-level ((frame application-frame) &key (command-parser 'command-line-command-parser) (command-unparser 'command-line-command-unparser) (partial-command-parser 'command-line-read-remaining-arguments-for-partial-command) (prompt "Command: ")) (declare (ignore command-parser command-unparser partial-command-parser prompt)) (setf *text-field* (find-text-field frame)) (clim-extensions:simple-event-loop)) (eval-when (:compile-toplevel) (defun make-operator-button-form (name label operator) `(,name :push-button :space-requirement (make-space-requirement :width 50 :height 50) :label ,label :activate-callback (queue-operator #',operator))) (defun make-number-button-form (name label number) `(,name :push-button :space-requirement (make-space-requirement :width 50 :height 50) :label ,label :activate-callback (queue-number ,number)))) (define-application-frame sliderdemo () () (:panes #.(make-operator-button-form 'plus "+" '+) #.(make-operator-button-form 'dash "-" '-) #.(make-operator-button-form 'multiply "*" '*) #.(make-operator-button-form 'divide "/" 'round) #.(make-operator-button-form 'result "=" 'do-operation) #.(make-number-button-form 'one "1" 1) #.(make-number-button-form 'two "2" 2) #.(make-number-button-form 'three "3" 3) #.(make-number-button-form 'four "4" 4) #.(make-number-button-form 'five "5" 5) #.(make-number-button-form 'six "6" 6) #.(make-number-button-form 'seven "7" 7) #.(make-number-button-form 'eight "8" 8) #.(make-number-button-form 'nine "9" 9) #.(make-number-button-form 'zero "0" 0) (screen :text-field :value "0" :space-requirement (make-space-requirement :width 200 :height 50)) (ac :push-button :space-requirement (make-space-requirement :width 50 :height 50) :label "AC" :activate-callback #'initac) (ce :push-button :space-requirement (make-space-requirement :width 50 :height 50) :label "CE" :activate-callback #'initce) (slider :slider :value-changed-callback #'slide :min-value 0 :max-value 100 :value 0 :normal +white+ :highlighted +cyan+ :pushed-and-highlighted +blue+)) (:layouts (defaults (horizontally () (vertically () screen (horizontally () ac ce) (tabling () (list one two plus) (list three four dash) (list five six multiply) (list seven eight divide) (list nine zero result))) slider))) (:top-level (sliderdemo-frame-top-level . nil))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Examples/logic-cube.lisp0000640000175000017500000005061010453774376021475 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-DEMO; -*- ;;; 3D Logic Cube flash game (http://www.newgrounds.com/portal/view/315702), ;;; translated into CL/McCLIM. ;;; (C) Copyright 2006 by Andy Hefner (ahefner@gmail.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-demo) ;; TODO: Improved puzzle generator. The puzzles currently generated by ;; "Random Puzzle" are all extremely easy to solve. I'm not admitting ;; defeat here, but I refuse to waste any more time on this program. ;; FIXME: When shrinking polygons during the victory animation, why ;; does their shape appear to distort? Look at the Z of the transformed ;; coordinates.. ;; Pane definition and puzzle generator (defclass logic-cube-pane (basic-gadget) ((background :initform (make-rgb-color 0.35 0.35 0.46) :reader background-color) (pitch :initform 0.0 :accessor pitch) (yaw :initform 0.0 :accessor yaw) (density :initform 5 :accessor density) (playfield :reader playfield) (drag-color :initform nil :accessor drag-color) (dragging :initform nil :accessor dragging) (squeeze :initform nil :accessor squeeze) ; For victory animation (flyaway :initform 0.0 :accessor flyaway) ; For victory animation (decorator :initform nil :accessor decorator))) ; Hook for victory text (defun reset-logic-cube (cube new-density) (with-slots (density playfield squeeze drag-color dragging flyaway decorator) cube (setf density new-density dragging nil decorator nil drag-color nil flyaway 0.0 squeeze nil playfield (make-array (list 3 density density) :initial-element (list nil nil))))) ;; Playfield squares are a pair of color and {nil, t, terminal} (defun scrub-square (square) (if (second square) square (list nil nil))) (defun cleanup-cube (cube) (apply-to-hemicube-faces (density cube) (lambda (side i j &rest points) (declare (ignore points)) (symbol-macrolet ((square (aref (playfield cube) side i j))) (setf square (scrub-square square)))))) (defparameter *logic-cube-colors* (list +red+ +yellow+ +blue+ +green+ +orange+ +purple+)) ; Produce crappy, trivial puzzles, slowly. (defun generate-cube-puzzle (cube &optional (num-colors 6)) (reset-logic-cube cube 5) (labels ((sq (s i j) (first (aref (playfield cube) s i j))) (sql (indices) (apply #'sq indices)) (set-playfield (indices square) (destructuring-bind (s i j) indices (setf (aref (playfield cube) s i j) square))) (satisfying (pred) (loop for tries from 0 by 1 as s = (random 3) as i = (random (density cube)) as j = (random (density cube)) as result = (funcall pred (sq s i j) s i j) while (< tries (expt (density cube) 4)) ; ^_^ when result return result))) (let ((iterators (loop for color-index from 0 below num-colors collect (destructuring-bind (root iterator) (satisfying (lambda (color &rest root-indices) (let ((our-color (elt *logic-cube-colors* color-index)) (current-head root-indices)) (when (null color) (labels ((find-new-head () (satisfying ;; Obviously I should not use 'satisfying' here.. (lambda (head-color &rest head-indices) (and (null head-color) ;; .. but computers are very fast. (not (equal head-indices current-head)) (member head-indices (apply #'adjacent-squares cube current-head) :test #'equal) (>= 1 (count-if (lambda (c) (eql c our-color)) (apply #'adjacent-squares cube head-indices) :key #'sql)) head-indices)))) (choose-new-head () (let ((new-head (find-new-head))) (if new-head (set-playfield new-head (list our-color nil)) (unless (equal current-head root-indices) (set-playfield current-head (list our-color 'terminal)))) (setf current-head new-head) (and new-head #'choose-new-head)))) (choose-new-head) (and current-head (list root-indices #'choose-new-head))))))) (set-playfield root (list (elt *logic-cube-colors* color-index) 'terminal)) iterator)))) (loop for i from 0 by 1 while (and iterators (< i 100)) do (setf iterators (remove nil (mapcar #'funcall iterators)))) (apply-to-hemicube-faces (density cube) (lambda (side i j &rest points) (declare (ignore points)) (when (and (null (sq side i j)) (< (random 1.0) 0.65)) (set-playfield (list side i j) (list nil t)))))))) ;; The puzzles coming out of the above were so bad that I threw this together to ;; reject some of the obviously awful ones. (defun generate-better-cube-puzzle (cube &optional (num-colors 6)) (loop for i from 0 below 100 do (generate-cube-puzzle cube num-colors) (multiple-value-bind (solvable min-path-length) (check-victory cube) (assert solvable) (when (>= min-path-length 6) (return-from generate-better-cube-puzzle)))) (format *trace-output* "~&Settling for lousy puzzle..~%")) (defmethod initialize-instance :after ((pane logic-cube-pane) &rest args) (declare (ignore args)) (generate-better-cube-puzzle pane 6) (cleanup-cube pane)) (defmethod compose-space ((pane logic-cube-pane) &key width height) (declare (ignore width height)) ;; Hmm. How does one constrain the aspect ratio of a pane? (make-space-requirement :min-width 200 :min-height 200 :width 550 :height 550)) ;; Math utilities (defun lc-scaling-matrix (scale) (let ((matrix (make-array '(3 3) :initial-element 0.0))) (dotimes (i 3) (setf (aref matrix i i) scale)) matrix)) (defun lc-m3xv3 (a b) ; multiply 3x3 matrix by vector (flet ((f (i) (loop for j from 0 below 3 sum (* (aref a i j) (elt b j))))) (vector (f 0) (f 1) (f 2)))) (defun lc-m3xm3 (a b) ; multiply two 3x3 matrices (let ((matrix (make-array '(3 3) :initial-element 0.0))) (dotimes (row 3) (dotimes (col 3) (dotimes (i 3) (incf (aref matrix row col) (* (aref a row i) (aref b i col)))))) matrix)) (defun lc-rotation-matrix (theta axis-a axis-b) (let ((matrix (lc-scaling-matrix 1.0))) (setf (aref matrix axis-a axis-a) (cos theta) (aref matrix axis-a axis-b) (sin theta) (aref matrix axis-b axis-a) (- (sin theta)) (aref matrix axis-b axis-b) (cos theta)) matrix)) (defun lc-v+ (a b) (map 'vector #'+ a b)) ; 3-vector addition a+b (defun lc-v- (a b) (map 'vector #'- a b)) ; 3-vector subtract a-b (defun lc-scale (a s) (map 'vector (lambda (x) (* x s)) a)) ; 3-vector multiply by scalar (defun lc-cross (a b) ; 3-vector cross product (macrolet ((woo (p q) `(- (* (elt a ,p) (elt b ,q )) (* (elt a ,q) (elt b ,p))))) (vector (woo 1 2) (woo 2 0) (woo 0 1)))) ;; Corner of hemicube is at origin. ;; Sides: 0=XY 1=XZ 2=YZ (defun apply-to-hemicube-faces (n fn) (let ((size (/ n))) (dotimes (d 3) (flet ((permute (x y) ; SBCL warns (erroneously?) below, but the code works. (flet ((f (i) (elt (vector x y 0) (mod (+ d i) 3)))) (vector (f 0) (f 1) (f 2))))) (dotimes (i n) (dotimes (j n) (let ((base-x (* i size)) (base-y (* j size))) (funcall fn d i j (permute base-x base-y) (permute (+ base-x size) base-y) (permute (+ base-x size) (+ base-y size)) (permute base-x (+ base-y size)))))))))) (defun lc-point-transformer (view-matrix) (lambda (point) (setf point (map 'vector (lambda (x) (- x 0.5)) point)) (setf point (lc-m3xv3 view-matrix point)) (let ((z (+ 2.0 (elt point 2))) (zoom 2.0)) (vector (* zoom (/ (elt point 0) z)) (* zoom (/ (elt point 1) z)) z)))) (defun lc-scale-polygon (polygon amount) (let ((center (reduce (lambda (a b) (lc-v+ a (lc-scale b (/ (length polygon))))) polygon :initial-value #(0.0 0.0 0.0)))) (mapcar (lambda (v) (lc-v+ center (lc-scale (lc-v- v center) amount))) polygon))) (defun draw-polygon-3d (pane points &rest polygon-args) (apply #'draw-polygon pane (mapcar (lambda (p) (make-point (elt p 0) (elt p 1))) points) polygon-args)) (defun apply-to-transformed-faces (pane continuation) (let ((transformer (lc-point-transformer (lc-m3xm3 (lc-scaling-matrix (- 1.0 (flyaway pane))) (lc-m3xm3 (lc-rotation-matrix (pitch pane) 1 2) (lc-rotation-matrix (yaw pane) 0 2)))))) (apply-to-hemicube-faces (density pane) (lambda (side i j &rest points) (apply continuation side i j (mapcar transformer points)))))) (defun lc-face-normal (points) (lc-cross (lc-v- (elt points 2) (elt points 1)) (lc-v- (elt points 0) (elt points 1)))) (defun backface-p (points) (<= (elt (lc-face-normal points) 2) 0)) (defun face-light (color side) (compose-over (compose-in color (make-opacity 0.65)) (elt (vector +gray30+ +white+ color) side))) (defun polygon-edges (points) (maplist (lambda (list) (lc-v- (or (second list) (first points)) (first list))) points)) (defun draw-polygon-outline-3d (pane a b &rest polygon-args) (maplist (lambda (a* b*) (apply #'draw-polygon-3d pane (list (first a*) (first b*) (or (second b*) (first b)) (or (second a*) (first a))) polygon-args)) a b)) (defun draw-logic-cube (pane) (apply-to-transformed-faces pane (lambda (side i j &rest camera-points) (unless (backface-p camera-points) (when (squeeze pane) (setf camera-points (lc-scale-polygon camera-points (squeeze pane)))) (destructuring-bind (color type) (aref (playfield pane) side i j) (cond ((null type) (draw-polygon-3d pane (lc-scale-polygon camera-points 0.8) :filled t :ink (face-light (or color +gray80+) side))) ((eql type 'terminal) (let ((selected (eql color (drag-color pane)))) (when selected (draw-polygon-3d pane camera-points :filled t :ink color)) (draw-polygon-outline-3d pane camera-points (lc-scale-polygon camera-points 0.7) :filled t :ink (if selected +white+ (face-light (or color +gray80+) side))))))))))) (defun invoke-in-lc-space (pane continuation) ; "logic-cube space" =p (let* ((width (bounding-rectangle-width pane)) (height (bounding-rectangle-height pane)) (radius (/ (min width height) 2))) (with-translation (pane (/ width 2) (/ height 2)) (with-scaling (pane radius) (funcall continuation pane))))) (defmethod handle-repaint ((pane logic-cube-pane) region) (with-bounding-rectangle* (x0 y0 x1 y1) (sheet-region pane) (climi::with-double-buffering ((pane x0 y0 x1 y1) (wtf-wtf-wtf)) (declare (ignore wtf-wtf-wtf)) (draw-rectangle* pane x0 y0 x1 y1 :filled t :ink (background-color pane)) (invoke-in-lc-space pane #'draw-logic-cube) (when (decorator pane) (funcall (decorator pane)))))) ;;; Locating the face under the pointer: (defun square (x) (* x x)) (defun point-in-poly-p (x y points) (every (lambda (point edge) (let* ((edge-length (sqrt (+ (square (elt edge 0)) (square (elt edge 1))))) (nx (/ (- (elt edge 1)) edge-length)) (ny (/ (elt edge 0) edge-length)) (c (+ (* nx (elt point 0)) (* ny (elt point 1))))) (< c (+ (* nx x) (* ny y))))) points (polygon-edges points))) (defun xy-to-viewport-coordinates (pane x y) (let* ((width (bounding-rectangle-width pane)) ; .. (height (bounding-rectangle-height pane)) (radius (/ (min width height) 2))) (values (/ (- x (/ width 2)) radius) (/ (- y (/ height 2)) radius)))) (defun find-poly-under-point (pane x y) (apply-to-transformed-faces pane (lambda (side i j &rest points) (unless (backface-p points) (when (point-in-poly-p x y points) (return-from find-poly-under-point (values side i j)))))) (values nil nil nil)) ;;; Game interaction: (defmethod handle-event ((pane logic-cube-pane) (event pointer-exit-event)) (setf (dragging pane) nil)) (defmethod handle-event ((pane logic-cube-pane) (event pointer-button-release-event)) (setf (dragging pane) nil)) (defun square+ (pane side i j di dj) (let ((ni (+ i di)) (nj (+ j dj))) (if (or (> 0 ni) (> 0 nj) (>= ni (density pane)) (>= nj (density pane))) nil (list side ni nj)))) (defun adjacent-squares (pane side i j) (remove nil ; Ouch.. (list (square+ pane side i j 1 0) (square+ pane side i j 0 1) (or (square+ pane side i j -1 0) (and (= side 2) (list 1 j 0)) (and (= side 0) (list 2 j 0)) (and (= side 1) (list 0 j 0))) (or (square+ pane side i j 0 -1) (and (= side 2) (list 0 0 i)) (and (= side 1) (list 2 0 i)) (and (= side 0) (list 1 0 i)))))) (defun check-victory (pane) (let ((success t) (min-path-length nil)) (apply-to-hemicube-faces (density pane) (lambda (side i j &rest points) (declare (ignore points)) (when (eql 'terminal (second (aref (playfield pane) side i j))) (let ((coverage (make-hash-table :test 'equal)) (color (first (aref (playfield pane) side i j)))) (labels ((searching (path-length &rest indices) (setf (gethash indices coverage) t) (some (lambda (indices) (destructuring-bind (color-2 type) (apply #'aref (playfield pane) indices) (and (eql color color-2) (not (gethash indices coverage)) (or (and (eql type 'terminal) (setf min-path-length (if min-path-length (min min-path-length path-length) path-length))) (apply #'searching (1+ path-length) indices))))) (apply #'adjacent-squares pane indices)))) (unless (searching 1 side i j) (setf success nil))))))) (values success min-path-length))) ; Successful if no unconnected roots remained (defun won-logic-cube (pane) (let ((start-time (get-internal-real-time)) (spin-start-time 0.3) (text-style (make-text-style :serif :bold :huge)) (start-yaw (yaw pane)) (win-message (elt '("Great Success!" "You Win!" "Completed!" "Vanquished!" "Terminated!" "Good job!" "Boom!") (random 7)))) (loop with sequence-length = 2.0 as time = (/ (- (get-internal-real-time) start-time) internal-time-units-per-second sequence-length) while (< time 1.0) do (setf (squeeze pane) (1- time) (flyaway pane) (expt time 0.55) (yaw pane) (let ((foo (if (< time spin-start-time) 0.0 (/ (- time spin-start-time) (- 1.0 spin-start-time))))) (+ start-yaw (* (expt foo 1.3) pi))) (decorator pane) (lambda () (draw-text* pane win-message 13 13 :text-style text-style :ink +black+ :align-y :top) (draw-text* pane win-message 10 10 :text-style text-style :ink +white+ :align-y :top))) (repaint-sheet pane (sheet-region pane)) (sleep 0.01))) ;) (generate-better-cube-puzzle pane) (cleanup-cube pane) (repaint-sheet pane (sheet-region pane))) (defun drag-on-square (pane cell) (if (and (null (second cell)) (drag-color pane)) (list (drag-color pane) nil) cell)) (defun touch-square (cube side i j) (when side (symbol-macrolet ((cell (aref (playfield cube) side i j))) (when (not (equalp cell (setf cell (drag-on-square cube cell)))) ; when we've genuinely changed the state.. (when (check-victory cube) ; .. check for win (repaint-sheet cube (sheet-region cube)) (won-logic-cube cube)))))) (defmethod handle-event ((pane logic-cube-pane) (event pointer-motion-event)) (multiple-value-bind (x y) (xy-to-viewport-coordinates pane (pointer-event-x event) (pointer-event-y event)) (when (dragging pane) (multiple-value-call #'touch-square pane (find-poly-under-point pane x y))) (setf (yaw pane) (- (* (/ pi 4) (max -1.0 (min 1.0 x))) (/ pi 4)) (pitch pane) (min 0.0 (- (* (/ pi 4) (max -1.0 (min 1.0 y))) (/ pi 8)))) (repaint-sheet pane (sheet-region pane)))) (defmethod handle-event ((pane logic-cube-pane) (event pointer-button-press-event)) (multiple-value-bind (side i j) (multiple-value-call #'find-poly-under-point pane (xy-to-viewport-coordinates pane (pointer-event-x event) (pointer-event-y event))) (when side (destructuring-bind (color type) (aref (playfield pane) side i j) (touch-square pane side i j) (setf (dragging pane) t (drag-color pane) (if (eql type 'terminal) color (drag-color pane)))))) (repaint-sheet pane (sheet-region pane))) (defun find-cube () (find-pane-named *application-frame* 'logic-cube)) (define-command-table logic-cube-game-commands) (define-application-frame logic-cube () () (:panes (logic-cube (make-pane 'logic-cube-pane))) (:layouts (:default logic-cube)) (:command-table (logic-cube :inherit-from (logic-cube-game-commands) :menu (("Game" :menu logic-cube-game-commands)))) (:menu-bar t)) (define-command (com-reset-puzzle :menu t :command-table logic-cube-game-commands) () (cleanup-cube (find-cube))) (define-command (com-random-puzzle :menu t :command-table logic-cube-game-commands) () (generate-better-cube-puzzle (find-cube)) (cleanup-cube (find-cube))) (add-menu-item-to-command-table (find-command-table 'logic-cube-game-commands) nil :divider nil) (define-command (com-lc-quit :menu "Quit" :command-table logic-cube-game-commands) () (frame-exit *application-frame*)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Examples/misc-tests.lisp0000755000175000017500000003464511345155772021572 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-DEMO; -*- ;;; Random McCLIM tests. ;;; Have some subtle stream/graphics/recording behavior which you'd ;;; like to ensure continues to work? Add a test for it here! ;;; (C) Copyright 2006 by Andy Hefner (ahefner@gmail.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-demo) (defvar *misc-tests* (make-hash-table :test 'equal)) (defstruct misc-test name description drawer) (defmacro define-misc-test (name arglist description &body body) (check-type name string) (check-type description string) `(setf (gethash ,name *misc-tests*) (make-misc-test :name ,name :description ,description :drawer (lambda ,arglist ,@body)))) (define-application-frame misc-tests () () (:panes (output :application-pane) (description :application-pane) (selector :list-pane :mode :exclusive :name-key #'misc-test-name :items (sort (loop for x being the hash-values of *misc-tests* collect x) #'string< :key #'misc-test-name) :value-changed-callback (lambda (pane item) (declare (ignore pane)) (let ((output (get-frame-pane *application-frame* 'output)) (description (get-frame-pane *application-frame* 'description))) (window-clear output) (window-clear description) (with-text-style (description (make-text-style :sans-serif :roman :normal)) (write-string (misc-test-description item) description)) (funcall (misc-test-drawer item) output))))) (:layouts (default (spacing (:thickness 3) (horizontally () (spacing (:thickness 3) (clim-extensions:lowering () selector)) (vertically () (spacing (:thickness 3) (clim-extensions:lowering () (scrolling (:width 600 :height 600) output))) (spacing (:thickness 3) (clim-extensions:lowering () (scrolling (:scroll-bar :vertical :height 200) description))))))))) (defun misc-test-postscript (test &optional filename) (let* ((test (if (stringp test) (gethash test *misc-tests*) test)) (test-name (misc-test-name test)) (filename (or filename (format nil "/tmp/~A.eps" test-name)))) (with-open-file (out filename :direction :output :if-exists :supersede) (with-output-to-postscript-stream (stream out :device-type :eps) #+NIL (with-text-style (stream (make-text-style :sans-serif :roman :normal)) (format stream "~&~A: ~A~%" test-name (misc-test-description test))) (funcall (misc-test-drawer test) stream))))) (defun run-all-postscript-tests () (loop for test being the hash-values of *misc-tests* do (restart-case (misc-test-postscript test) (:skip () :report (lambda (stream) (format stream "Skip ~A" (misc-test-name test))))))) (define-misc-test "Empty Records 1" (stream) "Tests the effect of empty output records on their parent's bounding rectangle. If successful, you will see a circle enclosed in a square. The square should tightly fit the circle. If the rectangle extends all the way to the top/left edges of the pane, McCLIM is not handling this correctly. This specifically exercises addition of empty children in recompute-extent-for-new-child." (surrounding-output-with-border (stream :shape :rectangle) (draw-circle* stream 200 200 40) (with-new-output-record (stream)))) (define-misc-test "Empty Records 2" (stream) "Tests the effect of empty output records on their parent's bounding rectangle. If successful, you will see a circle enclosed in a square. The square should fit the circle within a few pixels distance. If the rectangle extends all the way to the top/left edges of the pane, McCLIM is not handling this correctly. This specifically tests addition and deletion of an empty child, and failure may point to recompute-extent-for-new-child or recompute-extent-for-changed-child." (surrounding-output-with-border (stream :shape :rectangle) (draw-circle* stream 200 200 40) (let ((record (with-new-output-record (stream)))) (delete-output-record record (output-record-parent record))))) (define-misc-test "Empty Records 3" (stream) "Tests the effect of empty output records on their parent's bounding rectangle. If successful, you will see a circle enclosed in a square. The square should fit the circle within a few pixels distance. If the rectangle extends all the way to the top/left edges of the pane, McCLIM is not handling this correctly. This test creates a new output record, fills it with content, then clears the record contents." (surrounding-output-with-border (stream :shape :rectangle) (draw-circle* stream 200 200 40) (let ((record (with-new-output-record (stream) (draw-circle* stream 50 50 10)))) (clear-output-record record)))) (define-misc-test "Empty Borders" (stream) "Tests handling of empty output records by surrounding-output-with-border. If successful, you will see twelve small circles arranged themselves in a larger circle. A likely failure mode will exhibit the circles piled on each other in the upper-left corner of the pane." (with-room-for-graphics (stream :first-quadrant nil) (with-text-style (stream (make-text-style :sans-serif :roman :small)) (loop with outer-radius = 180 with inner-radius = 27 with n = 12 for i from 0 below n do (setf (stream-cursor-position stream) (values (* outer-radius (sin (* i 2 pi (/ n)))) (* outer-radius (cos (* i 2 pi (/ n)))))) (surrounding-output-with-border (stream :shape :ellipse :circle t :min-radius inner-radius :shadow +gray88+ :shadow-offset 7 :filled t :line-thickness 1 :background +gray50+ :outline-ink +gray40+)))))) (define-misc-test "Underlining" (stream) "Tests the underlining border style. You should see five lines of text, equally spaced, with the second and third lines having the phrase 'all live' underlined, first by a thick black line then by a thin dashed red line. If the lines are broken or the spacing is irregular, the :move-cursor nil key of surrounding-output-with-border may not have behaved as expected. " (with-text-family (stream :sans-serif) (format stream "~&We all live in a yellow subroutine.~%") (format stream "~&We ") (surrounding-output-with-border (stream :shape :underline :line-thickness 2 :move-cursor nil) (format stream "all live")) (format stream " in a yellow subroutine.~%") (format stream "~&We ") (surrounding-output-with-border (stream :shape :underline :ink +red+ :line-dashes t :move-cursor nil) (format stream "all live")) (format stream " in a yellow subroutine.~%") (format stream "~&We all live in a yellow subroutine.~%") (format stream "~&We all live in a yellow subroutine.~%"))) (define-misc-test "Transparent Ink Test" (stream) "Drawing with transparent ink can be useful as a way of reserving space as padding around the visible part of a drawing. This test checks that the medium supports drawing in transparent ink, and that it is recorded with the expected bounding rectangle. It will draw two tables, which should format identically except for one square, which will be transparent in the first table and blue in the second. If the in absence of the blue square its row and column collapse to a small size, the bounding rectangle for the transparent squares is probably wrong. Light gray circles will be drawn in the background, and should show through the empty row/column of the table." (let ((table '((1 1 1 0 1) (1 1 1 0 1) (1 1 1 0 1) (0 0 0 2 0) (1 1 1 0 1))) (inks (list +transparent-ink+ +red+ +blue+)) (records nil)) ;; Draw some junk to make sure the transparent ink is really transparent, ;; and not just matching the background: (dotimes (i 400) (draw-circle* stream (- (random 600) 100) (- (random 600) 100) (1+ (* 40 (random 1.0) (random 1.0))) :ink +gray90+)) ;; Draw two tables: (format-items '(0 2) :stream stream :printer (lambda (foo stream) ;; Why isn't there an :equalize-row-heights ? (surrounding-output-with-border (stream) (formatting-table (stream :equalize-column-widths nil) (dolist (row table) (formatting-row (stream) (dolist (cell row) (formatting-cell (stream) (push (with-new-output-record (stream) (draw-rectangle* stream 0 0 32 32 :ink (elt inks (if (eql cell 2) foo cell)))) records))))))))) ;; Make sure the bounding rectangles are the same: (unless (reduce (lambda (a b) (and a (> 1 (abs (- (bounding-rectangle-width a) (bounding-rectangle-width b)))) (> 1 (abs (- (bounding-rectangle-height a) (bounding-rectangle-height b)))) b)) records) (format stream "~&The bounding rectangles don't look right..~%")))) (define-misc-test "Arrows" (stream) "Tests scaling and rotation of arrow heads, and the handling of the case where the heads become sufficiently large that they would overlap and should join in the middle. The line thickness and arrowhead width is increased from thin to thick, counterclockwise. The tips of the arrows should always fall on the green and red points." (let ((scale 1.2) (from-head t) (to-head t)) (with-room-for-graphics (stream :first-quadrant nil) (with-scaling (stream scale scale) (loop for theta from 0.0 below (* 2 pi) by (/ (* 2 pi) 17) do (progn (let* ((x2 (* 250 (sin theta))) (y2 (* 250 (cos theta))) (x1 (* 0.2 x2)) (y1 (* 0.2 y2))) (draw-arrow* stream x1 y1 x2 y2 :line-thickness (1+ (* 8 theta)) :head-width (* 5 (1+ theta)) :to-head to-head :from-head from-head :head-length (* 10 (1+ theta)) ) (draw-point* stream x1 y1 :ink +red+ :line-thickness 5) (draw-point* stream x2 y2 :ink +green+ :line-thickness 5)))))))) (define-misc-test "Gadget Output Records" (stream) "This tests integration of gadget output records. They should have correct bounding rectangles, and moving the output record should move the gadget. Adding/removing the output record from the history should add/remove the gadget as expected. If these things are true, gadget outputs records should work in almost any situation normal CLIM drawing would (excluding inside incremental redisplay, at present (?)), including graph layout and table formatting. This test uses format-graph-from-roots to create graph whose nodes are push-buttons." (let ((tree '((peter peter pumpkin eater) (had (a wife) (but (couldnt (keep (her))))) (he (put her (in (a pumpkin shell)))) (and there he (kept her (very well)))))) (format-graph-from-roots tree (lambda (obj stream) (let ((obj (typecase obj (list (first obj)) (t obj)))) (let ((fm (frame-manager *application-frame*))) (with-look-and-feel-realization (fm *application-frame*) (with-output-as-gadget (stream) (make-pane 'push-button :activate-callback (lambda (&rest args) (declare (ignore args)) (notify-user *application-frame* "You clicked a button.")) :label (string-downcase (princ-to-string obj)))))))) (lambda (obj) (if (listp obj) (rest obj) nil)) :stream stream))) (define-misc-test "Line Widths" (stream) "Hi there." (formatting-table (stream) (loop for scale-expt from 0 upto 2 as scale = (expt 2 scale-expt) do (with-scaling (stream scale) (formatting-row (stream) (loop for thickness from 1 upto 25 by 5 with width = 40 with width/2 = (/ width 2) do (formatting-cell (stream) (draw-rectangle* stream 0 (- width/2) width width/2 :line-thickness thickness :filled nil :ink +red+ :line-unit :coordinate) (draw-circle* stream width/2 0 width/2 :line-thickness thickness :filled nil :ink +blue+ :line-unit :coordinate) (draw-line* stream 0 0 width 0 :line-thickness thickness :line-cap-shape :round :line-unit :coordinate) #+NIL (draw-rectangle* stream 0 (- width/2) width width/2 :filled nil :ink +white+)))))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Examples/font-selector.lisp0000644000175000017500000001342511345155772022251 0ustar pdmpdm;;; -*- Mode: Lisp; show-trailing-whitespace: t; indent-tabs: nil -*- ;;; A font selection dialog. #| (clim-demo::select-font) (clim-demo::select-font :port (clim:find-port :server-path (list :ps :stream *standard-output*))) |# ;;; (c) 2006 David Lichteblau (david@lichteblau.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-demo) (defun select-font (&key (port (find-port))) (let ((frame (make-application-frame 'font-selector :font-selector-port port))) (run-frame-top-level frame) (font-selector-text-style frame))) (define-application-frame font-selector () ((font-selector-port :initarg :font-selector-port :initform (find-port) :accessor font-selector-port) (font-selector-text-style :accessor font-selector-text-style)) (:menu-bar nil) (:panes (canvas :application :height 150 :scroll-bars nil :display-time t :display-function 'display-font-preview) (family (make-pane 'list-pane :items nil :name-key #'font-family-name :value-changed-callback 'family-changed)) (face (make-pane 'list-pane :items nil :name-key #'font-face-name :value-changed-callback 'face-changed)) (size (make-pane 'list-pane :items nil :value-changed-callback 'size-changed))) (:layouts (default (vertically (:height 400 :width 600) (horizontally () (labelling (:label "Family") (scrolling () family)) (labelling (:label "Face") (scrolling () face)) (labelling (:label "Size") (scrolling () size))) canvas (horizontally () +fill+ (make-pane 'push-button :label "OK" :activate-callback (lambda (ignore) ignore (frame-exit *application-frame*))) (make-pane 'push-button :label "Cancel" :activate-callback (lambda (ignore) ignore (setf (font-selector-text-style *application-frame*) nil) (frame-exit *application-frame*)))))))) (defmethod generate-panes :after (fm (frame font-selector)) (reset-list-pane (find-pane-named frame 'family) (port-all-font-families (font-selector-port *application-frame*)))) (defun family-changed (pane value) (declare (ignore pane)) (let* ((face-list (find-pane-named *application-frame* 'face)) (old-face (and (slot-boundp face-list 'climi::value) (gadget-value face-list))) (new-faces (font-family-all-faces value))) (reset-list-pane face-list new-faces) (when old-face (setf (gadget-value face-list :invoke-callback t) (or (find (font-face-name old-face) new-faces :key #'font-face-name :test #'equal) (first new-faces)))))) (defun face-changed (pane value) (declare (ignore pane)) (let ((sizes (if value (font-face-all-sizes value) nil))) (reset-list-pane (find-pane-named *application-frame* 'size) sizes (or (position-if (lambda (x) (>= x 20)) sizes) 0)))) (defun size-changed (pane value) (declare (ignore pane)) (setf (font-selector-text-style *application-frame*) (let ((face (gadget-value (find-pane-named *application-frame* 'face)))) (if (and face value) (font-face-text-style face value) nil))) (display-font-preview *application-frame* (frame-standard-output *application-frame*))) (defun reset-list-pane (pane items &optional (index 0)) (setf (climi::list-pane-items pane :invoke-callback nil) items) (setf (gadget-value pane :invoke-callback t) (or (and (slot-boundp pane 'climi::value) (gadget-value pane)) (let ((values (climi::generic-list-pane-item-values pane))) (if (plusp (length values)) (elt values index) nil))))) (defmethod display-font-preview (frame stream) (window-clear stream) (let* ((pane-width (rectangle-width (sheet-region stream))) (pane-height (rectangle-height (sheet-region stream))) (str "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz") (style (font-selector-text-style frame)) (ok nil)) (cond ((not (eq (port frame) (font-selector-port frame))) (setf str (format nil "Cannot preview font for ~A" (font-selector-port frame))) (setf style (make-text-style :sans-serif :italic :normal))) ((null style) (setf str "Error: Text style is null") (setf style (make-text-style :sans-serif :italic :normal))) (t (setf ok t))) (multiple-value-bind (width height final-x final-y baseline) (text-size stream str :text-style style) (declare (ignore final-x final-y)) (let* ((x1 (/ (- pane-width width) 2)) (y1 (/ (- pane-height height) 2)) (y2 (+ y1 height)) (ybase (+ y1 baseline))) (when ok (draw-line* stream 0 ybase pane-width ybase :ink +green+) (draw-line* stream 0 y1 pane-width y1 :ink +blue+) (draw-line* stream 0 y2 pane-width y2 :ink +blue+)) (handler-case (draw-text* stream str x1 ybase :text-style style) (error (c) (princ c))))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Examples/traffic-lights.lisp0000644000175000017500000001247211345155772022374 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- ;;; (c) copyright 2001 by ;;; Julien Boninfante (boninfan@emi.u-bordeaux.fr) ;;; (c) copyright 2009 by ;;; Robert Strandh (strandh@labri.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; How to use the possibilities of the traffic-lights, you have two ;;; possibilites : ;;; 1 - Click on a toggle-button : the color of the light-pane ;;; will change ;;; 2 - Click on the orange or green toggle-button, then move your ;;; mouse-pointer on the light-pane, and wait a few seconds. (in-package :clim-internals) ;;; example gadget definition (defclass light-pane (standard-gadget) ()) (defmethod handle-repaint ((pane light-pane) region) (declare (ignore region)) (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* (sheet-region pane)) (display-gadget-background pane (gadget-current-color pane) 0 0 (- x2 x1) (- y2 y1)))) (in-package :clim-demo) ;;; callback functions (defmethod handle-event :after ((pane clim-internals::light-pane) (event pointer-event)) (declare (ignorable event)) (let ((label (gadget-label (radio-box-current-selection (slot-value *application-frame* 'radio-box))))) (cond ((string= label "O") (traffic-pause 3) (simulate-user-action (find-pane-named *application-frame* 'red))) ((string= label "G") (traffic-pause 5) (simulate-user-action (find-pane-named *application-frame* 'orange))) (t nil)))) (defun traffic-pause (time) (let ((time-left-window (find-pane-named *application-frame* 'time-left))) (flet ((show-time (left) (setf (gadget-value time-left-window) (format nil "~D" left)))) (loop for left from time downto 1 do (show-time left) (sleep 1)) (show-time 0)))) (defmethod simulate-user-action ((pane toggle-button)) (setf (gadget-value pane :invoke-callback t) (not (gadget-value pane)))) (defun callback-red (gadget value) (declare (ignorable gadget)) (when value (setf (clim-internals::gadget-current-color (slot-value *application-frame* 'light)) (clim-internals::gadget-normal-color (slot-value *application-frame* 'light))))) (defun callback-orange (gadget value) (declare (ignore gadget)) (when value (setf (clim-internals::gadget-current-color (slot-value *application-frame* 'light)) (clim-internals::gadget-highlighted-color (slot-value *application-frame* 'light))))) (defun callback-green (gadget value) (declare (ignore gadget)) (when value (setf (clim-internals::gadget-current-color (slot-value *application-frame* 'light)) (clim-internals::gadget-pushed-and-highlighted-color (slot-value *application-frame* 'light))))) ;;; test functions (defun traffic-lights () (loop for port in climi::*all-ports* do (destroy-port port)) (setq climi::*all-ports* nil) (run-frame-top-level (make-application-frame 'traffic-lights))) (defmethod traffic-lights-frame-top-level ((frame application-frame)) (setf (slot-value frame 'light) (find-pane-named frame 'light) (slot-value frame 'radio-box) (find-pane-named frame 'radio-box)) (clim-extensions:simple-event-loop)) (defmacro make-color-chooser-toggle-button (name color label callback) (let ((color-name (gensym "COLOR"))) `(let ((,color-name ,color)) (make-pane 'toggle-button :name ,name :label ,label :indicator-type :one-of :width 30 :height 30 :normal ,color-name :highlighted ,color-name :pushed-and-highlighted ,color-name :value-changed-callback ,callback)))) (define-application-frame traffic-lights () ((radio-box :initform nil) (light :initform nil)) (:panes (light :light :width 30 :normal +red+ :highlighted +orange+ :pushed-and-highlighted +green+) (radio-box (with-radio-box () (radio-box-current-selection (make-color-chooser-toggle-button 'red +red+ "R" 'callback-red)) (make-color-chooser-toggle-button 'orange +orange+ "O" 'callback-orange) (make-color-chooser-toggle-button 'green +green+ "G" 'callback-green))) (time-left text-field :editable-p nil :value "0")) (:layouts (default (horizontally () (vertically (:spacing 10) radio-box time-left) light))) (:top-level (traffic-lights-frame-top-level . nil))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Examples/demodemo.lisp0000644000175000017500000002415111345155772021254 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-DEMO; -*- ;;; -------------------------------------------------------------------------------------- ;;; Title: The demo demo ;;; Created: 2002-02-11 ;;; Author: Gilbert Baumann ;;; License: LGPL (See file COPYING for details). ;;; -------------------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-demo) (defun make-demo-button (title demo-frame-class) (make-pane 'push-button :label title :activate-callback (let ((frame nil)) (lambda (&rest ignore) (declare (ignore ignore)) (cond ((null frame) ;; I broke this logic, sorry.. -Hefner (setq frame (run-frame-top-level (make-application-frame demo-frame-class :calling-frame *application-frame*)))) (t #+nil (destroy-frame frame))))))) (define-application-frame demodemo () () (:menu-bar nil) (:layouts (default (vertically (:equalize-width t) (progn ;;spacing (:thickness 10) (labelling (:label "McCLIM Demos" :text-style (make-text-style :sans-serif :roman :huge) :align-x :center))) (progn ;; spacing (:thickness 10) (horizontally () ;; '+fill+ (labelling (:label "Demos") (vertically (:equalize-width t) (make-demo-button "CLIM-Fig" 'clim-fig) (make-demo-button "Calculator" 'calculator) (make-demo-button "Method Browser" 'method-browser) (make-demo-button "Address Book" 'address-book) (make-demo-button "Puzzle" 'puzzle) (make-demo-button "Logic Cube" 'logic-cube) (make-demo-button "Gadget Test" 'gadget-test) (make-demo-button "Drag and Drop" 'dragndrop) ;(make-demo-button "Colorslider" 'colorslider) (make-demo-button "D&D Translator" 'drag-test) (make-demo-button "Draggable Graph" 'draggable-graph-demo) (make-demo-button "Image viewer" 'image-viewer) (make-pane 'push-button :label "Font Selector" :activate-callback (lambda (&rest ignore) (declare (ignore ignore)) (format *trace-output* "~&You chose: ~A~%" (select-font)))) (make-demo-button "Tab Layout" 'tabdemo:tabdemo))) (labelling (:label "Tests") (vertically (:equalize-width t) (make-demo-button "Label Test" 'label-test) (make-demo-button "Table Test" 'table-test) (make-demo-button "Scroll Test" 'Scroll-test) (make-demo-button "List Test" 'list-test) (make-demo-button "HBOX Test" 'hbox-test) (make-demo-button "Text Size Test" 'text-size-test) (make-demo-button "Goatee Test" 'goatee::goatee-test) (make-demo-button "Drawing Benchmark" 'drawing-benchmark) (make-demo-button "Border Styles Test" 'bordered-output) (make-demo-button "Misc. Tests" 'misc-tests))))))))) (defun demodemo () #+nil (loop for port in climi::*all-ports* do (destroy-port port)) (run-frame-top-level (make-application-frame 'demodemo))) (define-application-frame hbox-test () () (:layouts (default (horizontally (:background climi::*3d-normal-color*) 30 (make-pane 'push-button :label "Okay" :width '(50 :mm)) '+fill+ (make-pane 'push-button :label "Cancel") '+fill+ (make-pane 'push-button :label "Help") 5 ) ))) (define-application-frame table-test () () (:layouts (default (tabling (:background +red+) (list (make-pane 'push-button :label "Last Name" :max-height +fill+) (make-pane 'push-button :label "First Name" #||:max-height +fill+||#)) (list (make-pane 'push-button :label "C 1 0") (make-pane 'push-button :label "C 1 1")) ) ))) (defun make-test-label (ax ay) (labelling (:label "Some Label" :align-x ax :label-alignment ay :foreground +WHITE+ :background +PALETURQUOISE4+ :text-style (make-text-style :sans-serif :roman :normal)) (make-pane 'push-button :label (format nil "~S" (list ax ay)) :text-style (make-text-style :sans-serif :roman :normal) :max-width 1000 :max-height 1000))) (defun make-test-label2 (ax ay) (labelling (:label (format nil "~(~S~)" (list ax ay)) :align-x ax :label-alignment ay :foreground +WHITE+ :background +PALETURQUOISE4+ :text-style (make-text-style :sans-serif :roman :normal)) #+nil (make-pane 'push-button :label :text-style (make-text-style :sans-serif :roman :normal) :max-width 1000 :max-height 1000))) (define-application-frame label-test () () (:layouts (default ; (scrolling (:width 400 :height 200 ; :max-width 1000 :max-height 2000) (vertically (:equalize-width t ;;:width 400 ;;:height 800 :max-width 2000 :max-height 2000) 10 (labelling (:label "CLIM Label Tests" :align-x :center :text-style (make-text-style :sans-serif :roman :huge))) 10 (9/10 (horizontally (:equalize-height t) (1/2 (labelling (:label "Labels with content") (vertically (:equalize-width t) (make-test-label :left :top) 5 (make-test-label :center :top) 5 (make-test-label :right :top) 5 (make-test-label :left :bottom) 5 (make-test-label :center :bottom) 5 (make-test-label :right :bottom)))) (1/2 (labelling (:label "Labels w/o content") (vertically (:equalize-width t) (make-test-label2 :left :top) 5 (make-test-label2 :center :top) 5 (make-test-label2 :right :top) 5 (make-test-label2 :left :bottom) 5 (make-test-label2 :center :bottom) 5 (make-test-label2 :right :bottom)))))))))) (defclass foo-pane (basic-pane permanent-medium-sheet-output-mixin) ()) (defmethod compose-space ((pane foo-pane) &key width height) (declare (ignore width height)) (make-space-requirement :width 800 :height 1e3)) (defmethod repaint-sheet ((pane foo-pane) region) (draw-line* pane 50 50 200 50) (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* region) (let ((k 20)) (loop for y from (* k (floor (- y1 10) k)) below (+ y2 10) by k do (draw-text* pane (format nil "~D" y) 20 y))))) (defmethod dispatch-repaint ((foo-pane foo-pane) region) (repaint-sheet foo-pane region)) (defmethod handle-event ((pane foo-pane) (event window-repaint-event)) (repaint-sheet pane (window-event-region event))) (define-application-frame scroll-test () () (:layouts (defaults (scrolling (:width 400 :height 400) (make-pane 'foo-pane))))) (define-application-frame list-test () () (:panes (substring :text-field :value "INTER") (result-list (make-pane 'list-pane :value 'clim:region-intersection :items (apropos-list "INTER" :clim t) :presentation-type-key (constantly 'list-test-symbol) :name-key (lambda (x) (format nil "~(~S~)" x)))) (interactor :interactor :height 200)) (:layouts (defaults (labelling (:label "Matching symbols" :text-style (make-text-style :sans-serif :roman :normal)) (vertically () (scrolling (:height 200) result-list) (horizontally () substring (make-pane 'push-button :label "Update" :activate-callback 'update-list-test)) interactor))))) (define-presentation-type list-test-symbol ()) (define-list-test-command com-describe-symbol ((sym 'list-test-symbol :gesture :select)) ;; Let's print only three lines, we don't have space for more. (with-input-from-string (s (with-output-to-string (s) (describe sym s))) (dotimes (x 3) (write-line (read-line s nil "") *standard-input*)))) (defun update-list-test (pane) (declare (ignore pane)) (setf (list-pane-items (find-pane-named *application-frame* 'result-list)) (apropos-list (gadget-value (find-pane-named *application-frame* 'substring)) :clim t))) (format t "~&;; try (CLIM-DEMO::DEMODEMO)~%") cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Examples/bordered-output-examples.lisp0000750000175000017500000002101510561521625024406 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-DEMO; -*- ;;; Test surrounding-output-with-border with various shapes and keywords. ;;; (c) Copyright 2007 by Andy Hefner (ahefner@gmail.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-demo) (define-presentation-type border-style ()) (define-application-frame bordered-output () ((shapes :initform (append (reverse climi::*border-types*) (list (list :rectangle :ink +gray80+ :padding 0 :padding-left 24 :line-thickness 4) (list :rectangle :ink +gray50+ :line-dashes t) (list :oval :ink +white+ :highlight-background +white+ :line-thickness 3) (list :oval :line-dashes t) (list :oval :ink nil :background +white+) (list :underline :ink +red+ :line-thickness 2) (list :underline :ink +red+ :line-dashes t) (list :rectangle :ink +gray50+ :background +white+ :filled t) (list :oval :ink +gray60+ :background +gray85+ :filled t) (list :oval :ink (make-ihs-color 0.8 1.0 0.5) :line-thickness 3 :background (make-ihs-color 1.0 0.0 0.5) ;; FIXME, breaks on ovals. =( ;:highlight-background (make-ihs-color 1.5 0.0 0.5) :shadow-offset 8 :shadow +gray80+ :filled t) (list :drop-shadow :ink +black+ :padding 10 :padding-left 20 :background +gray70+ :shadow +gray80+ :shadow-offset 8 :filled t) (list :rectangle :shadow +grey80+ :background +white+) (list :rounded :padding-x 27 :padding-top 17 :padding-bottom 27) (list :rounded :line-dashes t) (list :rounded :padding 13 :line-thickness 2 :ink +gray70+) (list :rounded :padding 13 :line-thickness 2 :shadow +gray80+ :background +white+ :ink +red+) (list :ellipse :line-dashes t :circle t) (list :ellipse :line-thickness 2 :outline-ink +red+ :background +white+) (list :ellipse :shadow +gray80+ :outline-ink +gray60+ :background +white+) ;; These are just my tests that the literal corner cases of draw-rounded-rectangle* ;; work correctly. (list :rounded :highlight-background +yellow+ :radius 27 :radius-top 0 :outline-ink +red+ :background +white+ :shadow +gray80+) (list :rounded :highlight-background +yellow+ :radius 27 :radius-left 0 :outline-ink +red+ :background +white+ :shadow +gray80+) (list :rounded :highlight-background +yellow+ :radius 27 :radius-right 0 :outline-ink +red+ :background +white+ :shadow +gray80+) (list :rounded :highlight-background +yellow+ :radius 27 :radius-bottom 0 :outline-ink +red+ :background +white+ :shadow +gray80+) (list :rounded :highlight-background +yellow+ :radius 27 :radius-y 0 :outline-ink +red+ :background +white+ :shadow +gray80+) (list :rounded :highlight-background +yellow+ :radius 27 :radius-x 0 :outline-ink +red+ :background +white+ :shadow +gray80+) (list :rounded :highlight-background +yellow+ :radius 27 :radius-right 0 :radius-top 0 :outline-ink +red+ :background +white+ :shadow +gray80+) (list :rounded :highlight-background +yellow+ :radius 27 :radius-bottom 0 :radius-left 0 :outline-ink +red+ :background +white+ :shadow +gray80+))) :reader shapes-of)) (:pane (scrolling (:width 600 :height 700) (make-pane :application-pane :end-of-line-action :allow :end-of-page-action :allow ; Why isn't this working? :background +gray90+ :name :border-examples :display-function (lambda (frame stream) (format-items (shapes-of frame) :stream stream :presentation-type 'border-style :cell-align-x :center :cell-align-y :center :y-spacing 16 :x-spacing 16 :printer (lambda (shape stream) (let ((shape-name-style (make-text-style :sans-serif :bold :normal)) (keywords-style (make-text-style :sans-serif :roman :small))) (flet ((show (stream) (with-text-style (stream shape-name-style) (if (listp shape) (progn (format stream "~A" (first shape)) (with-text-style (stream keywords-style) (format stream "~{~% ~W ~W~}" (rest shape)))) (princ shape stream))))) (if (listp shape) (apply #'climi::invoke-surrounding-output-with-border stream #'show (cons :shape shape)) (surrounding-output-with-border (stream :shape shape) (show stream))))))) (terpri stream)))))) ;;; Define a dummy command, just to get highlighting of the border styles. (define-bordered-output-command (com-do-nothing) ((style 'border-style :gesture :select)) (declare (ignore style)) #+NIL (clouseau:inspector (stream-output-history *standard-output*))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Examples/dragndrop-translator.lisp0000600000175000017500000000611310405323200023573 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-DEMO -*- ;;; (c) copyright 2006 by ;;; Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-demo) (defparameter *colors* (list +black+ +white+ +red+ +green+ +blue+ +magenta+ +cyan+ +yellow+)) (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *color-alist* `(("black" . ,+black+) ("white" . ,+white+) ("red" . ,+red+) ("green" . ,+green+) ("blue" . ,+blue+) ("magenta" . ,+magenta+) ("cyan" . ,+cyan+) ("yellow" . ,+yellow+)))) (define-presentation-type named-color () :inherit-from `(completion ,*color-alist* :value-key cdr)) (defclass rect () ((x :accessor x :initarg :x) (y :accessor y :initarg :y) (width :accessor width :initarg :width) (height :accessor height :initarg :height) (color :accessor color :initarg :color)) (:default-initargs :x 0 :y 0 :width 50 :height 50 :color +black+)) (defgeneric draw (stream thing)) (defmethod draw (stream (thing rect)) (with-output-as-presentation (stream thing 'rect) (let ((x (x thing)) (y (y thing))) (draw-rectangle* stream x y (+ x (width thing)) (+ y (height thing)) :ink (color thing))))) (define-application-frame drag-test () ((shape1 :accessor shape1 :initform (make-instance 'rect :x 10 :y 10)) (shape2 :accessor shape2 :initform (make-instance 'rect :x 100 :y 10))) (:pointer-documentation t) (:panes (interactor :interactor) (scribble :application :width 200 :display-function 'display-shapes)) (:layouts (default (vertically () scribble interactor)))) (defun display-shapes (frame stream) (draw stream (shape1 frame)) (draw stream (shape2 frame))) (define-drag-test-command (com-set-color :name t) ((shape 'rect) &key (color 'named-color :default +cyan+ )) (setf (color shape) color)) (define-drag-test-command (com-set-random-color :name t) ((shape 'rect)) (let ((elt (random (length *color-alist*)))) (setf (color shape) (cdr (nth elt *color-alist*))))) (define-drag-and-drop-translator com-drop-color (rect command rect drag-test) (object destination-object) (if (eq object destination-object) `(com-set-random-color ,object) `(com-set-color ,destination-object :color ,(color object)))) #-(and) (define-gesture-name :drag-and-drop :pointer-button (:control :left) :unique t) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Examples/clim-fig.lisp0000644000175000017500000004062011345155772021151 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-DEMO -*- ;;; (c) copyright 2001 by ;;; Arnaud Rouanet (rouanet@emi.u-bordeaux.fr) ;;; Lionel Salabartan (salabart@emi.u-bordeaux.fr) ;;; (c) copyright 2002 by ;;; Alexey Dejneka (adejneka@comail.ru) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-demo) (defclass canvas-pane (application-pane) ((first-point-x :initform nil) (first-point-y :initform nil))) (defun set-status-line (string) (setf (gadget-value (clim-fig-status *application-frame*)) string)) (defun draw-figure (pane x y x1 y1 &key fastp cp-x1 cp-y1 cp-x2 cp-y2) (with-slots (line-style current-color fill-mode constrict-mode) *application-frame* (let* ((radius-x (- x1 x)) (radius-y (- y1 y)) (line-style (if fastp (medium-line-style pane) line-style)) (fill-mode (if fastp nil fill-mode))) (when constrict-mode (case (clim-fig-drawing-mode *application-frame*) ((:line :arrow) (if (> (abs radius-x) (abs radius-y)) (setf y1 y) (setf x1 x))) ((:rectangle :ellipse) (let ((radius-max (max (abs radius-x) (abs radius-y)))) (setf radius-x (* (signum-1 radius-x) radius-max) radius-y (* (signum-1 radius-y) radius-max) x1 (+ x radius-x) y1 (+ y radius-y)))))) (case (clim-fig-drawing-mode *application-frame*) (:point (draw-point* pane x y :ink current-color :line-style line-style)) (:line (draw-line* pane x y x1 y1 :ink current-color :line-style line-style)) (:arrow (draw-arrow* pane x y x1 y1 :ink current-color :line-style line-style :to-head t :head-width 20 :head-length 20)) (:rectangle (draw-rectangle* pane x y x1 y1 :filled fill-mode :ink current-color :line-style line-style)) (:ellipse (draw-ellipse* pane x y radius-x 0 0 radius-y :filled fill-mode :ink current-color :line-style line-style)) (:bezier (when fastp (draw-text* pane "[Use the middle and right mouse button to set control points]" 0 20)) (let* ((cp-x1 (or cp-x1 x)) (cp-y1 (or cp-y1 y1)) (cp-x2 (or cp-x2 x1)) (cp-y2 (or cp-y2 y)) (design (climi::make-bezier-thing* 'climi::bezier-area (list x y cp-x1 cp-y1 cp-x2 cp-y2 x1 y1)))) (unless (or (= x cp-x1 x1 cp-x2) (= y cp-y1 y1 cp-y2)) ; Don't draw null beziers. (climi::draw-bezier-design* pane design) (draw-line* pane x y cp-x1 cp-y1 :ink +red+) (draw-line* pane x1 y1 cp-x2 cp-y2 :ink +blue+)))))))) (defun signum-1 (value) (if (zerop value) 1 (signum value))) (define-presentation-type figure ()) (define-presentation-method highlight-presentation ((type figure) record stream state) (declare (ignore record stream state)) nil) (defun handle-draw-object (pane x1 y1) (let* ((pixmap-width (round (bounding-rectangle-width (sheet-region pane)))) (pixmap-height (round (bounding-rectangle-height (sheet-region pane)))) (canvas-pixmap (allocate-pixmap pane pixmap-width pixmap-height)) cp-x1 cp-y1 cp-x2 cp-y2) (copy-to-pixmap pane 0 0 pixmap-width pixmap-height canvas-pixmap) (multiple-value-bind (x y) (block processor (if (eq (slot-value *application-frame* 'drawing-mode) :point) (values x1 y1) (tracking-pointer (pane) (:pointer-motion (&key window x y) (declare (ignore window)) (set-status-line (format nil "~:(~A~) from (~D,~D) to (~D,~D)~%" (slot-value *application-frame* 'drawing-mode) (round x1) (round y1) (round x) (round y))) (with-output-recording-options (pane :record nil) (copy-from-pixmap canvas-pixmap 0 0 pixmap-width pixmap-height pane 0 0) (draw-figure pane x1 y1 x y :fastp t :cp-x1 cp-x1 :cp-y1 cp-y1 :cp-x2 cp-x2 :cp-y2 cp-y2))) (:pointer-button-release (&key event x y) (when (= (pointer-event-button event) +pointer-left-button+) (return-from processor (values x y)))) (:pointer-button-press (&key event x y) (cond ((= (pointer-event-button event) +pointer-right-button+) (setf cp-x1 x cp-y1 y)) ((= (pointer-event-button event) +pointer-middle-button+) (setf cp-x2 x cp-y2 y))))))) (set-status-line " ") (copy-from-pixmap canvas-pixmap 0 0 pixmap-width pixmap-height pane 0 0) (deallocate-pixmap canvas-pixmap) (with-output-as-presentation (pane nil 'figure :single-box t) (draw-figure pane x1 y1 x y :cp-x1 cp-x1 :cp-y1 cp-y1 :cp-x2 cp-x2 :cp-y2 cp-y2)) (setf (clim-fig-redo-list *application-frame*) nil)))) (defun handle-move-object (pane figure first-point-x first-point-y) (tracking-pointer (pane) (:pointer-button-release (&key event x y) (when (= (pointer-event-button event) +pointer-right-button+) (multiple-value-bind (old-x old-y) (output-record-position figure) (setf (output-record-position figure) (values (+ old-x (- x first-point-x)) (+ old-y (- y first-point-y))))) (window-refresh pane) (return-from handle-move-object))))) (defun clim-fig () (run-frame-top-level (make-application-frame 'clim-fig))) (defun make-colored-button (color &key width height) (make-pane 'push-button :label " " :activate-callback #'(lambda (gadget) (setf (clim-fig-current-color (gadget-client gadget)) color)) :width width :height height :background color :foreground color :normal color :pushed-and-highlighted color :highlighted color)) (defun make-drawing-mode-button (label mode &key width height) (make-pane 'push-button :label label :activate-callback #'(lambda (gadget) (setf (clim-fig-drawing-mode (gadget-client gadget)) mode)) :width width :height height)) (defun make-merged-line-style (line-style &key unit thickness joint-shape cap-shape (dashes nil dashes-p)) (make-line-style :unit (or unit (line-style-unit line-style)) :thickness (or thickness (line-style-thickness line-style)) :joint-shape (or joint-shape (line-style-joint-shape line-style)) :cap-shape (or cap-shape (line-style-cap-shape line-style)) :dashes (if dashes-p dashes (line-style-dashes line-style)))) (define-application-frame clim-fig () ((drawing-mode :initform :line :accessor clim-fig-drawing-mode) (output-record :accessor clim-fig-output-record) (redo-list :initform nil :accessor clim-fig-redo-list) (current-color :initform +black+ :accessor clim-fig-current-color) (line-style :initform (make-line-style) :accessor clim-fig-line-style) (fill-mode :initform nil :accessor clim-fig-fill-mode) (constrict-mode :initform nil :accessor clim-fig-constrict-mode) (status :initform nil :accessor clim-fig-status)) (:menu-bar menubar-command-table) (:panes (canvas (make-pane 'canvas-pane :name 'canvas :display-time nil)) (line-width-slider :slider :label "Line Width" :value 1 :min-value 1 :max-value 100 :value-changed-callback #'(lambda (gadget value) (declare (ignore gadget)) (with-slots (line-style) *application-frame* (setf line-style (make-merged-line-style line-style :thickness (round value))))) :show-value-p t :decimal-places 0 :height 50 :orientation :horizontal) (round-shape-toggle :toggle-button :label "Round Cap/Joint" :value nil :value-changed-callback #'(lambda (gadget value) (declare (ignore gadget)) (with-slots (line-style) *application-frame* (let ((cap-shape (if value :round :butt)) (joint-shape (if value :round :miter))) (setf line-style (make-merged-line-style line-style :cap-shape cap-shape :joint-shape joint-shape)))))) (fill-mode-toggle :toggle-button :label "Fill" :value nil :value-changed-callback #'(lambda (gadget value) (declare (ignore gadget)) (setf (clim-fig-fill-mode *application-frame*) value))) (constrict-toggle :toggle-button :label "Constrict" :value nil :value-changed-callback #'(lambda (gadget value) (declare (ignore gadget)) (setf (clim-fig-constrict-mode *application-frame*) value))) ;; Drawing modes (point-button (make-drawing-mode-button "Point" :point)) (line-button (make-drawing-mode-button "Line" :line)) (arrow-button (make-drawing-mode-button "Arrow" :arrow)) (rectangle-button (make-drawing-mode-button "Rectangle" :rectangle)) (ellipse-button (make-drawing-mode-button "Ellipse" :ellipse)) (bezier-button (make-drawing-mode-button "Bezier" :bezier)) ;; Colors (black-button (make-colored-button +black+)) (blue-button (make-colored-button +blue+)) (green-button (make-colored-button +green+)) (cyan-button (make-colored-button +cyan+)) (red-button (make-colored-button +red+)) (magenta-button (make-colored-button +magenta+)) (yellow-button (make-colored-button +yellow+)) (white-button (make-colored-button +white+)) (turquoise-button (make-colored-button +turquoise+)) (grey-button (make-colored-button +grey+)) (brown-button (make-colored-button +brown+)) (orange-button (make-colored-button +orange+)) (undo :push-button :label "Undo" :activate-callback #'(lambda (x) (declare (ignore x)) (com-undo))) (redo :push-button :label "Redo" :activate-callback #'(lambda (x) (declare (ignore x)) (com-redo))) (clear :push-button :label "Clear" :activate-callback #'(lambda (x) (declare (ignore x)) (com-clear))) (status :text-field :value "CLIM Fig" :editable-p nil)) (:layouts (default (vertically () (horizontally () (vertically (:width 150) (tabling (:height 60) (list black-button blue-button green-button cyan-button) (list red-button magenta-button yellow-button white-button) (list turquoise-button grey-button brown-button orange-button)) line-width-slider round-shape-toggle (horizontally () fill-mode-toggle constrict-toggle) point-button line-button arrow-button ellipse-button rectangle-button bezier-button) (scrolling (:width 600 :height 400) canvas)) (horizontally (:height 30) clear undo redo) status))) (:top-level (default-frame-top-level :prompt 'clim-fig-prompt))) (defmethod frame-standard-output ((frame clim-fig)) (find-pane-named frame 'canvas)) (define-presentation-to-command-translator add-figure (blank-area com-add-figure clim-fig :gesture :select ; XXX :echo nil :tester ((window) (typep window 'canvas-pane))) (x y) (list x y)) (define-presentation-to-command-translator move-figure (figure com-move-figure clim-fig :gesture :menu ; XXX :echo nil) (presentation x y) (list presentation x y)) (defmethod generate-panes :after (frame-manager (frame clim-fig)) (declare (ignore frame-manager)) (setf (clim-fig-output-record frame) ;; *standard-output* not bound to the canvas pane yet. (stream-current-output-record (frame-standard-output frame)) (clim-fig-status frame) (find-pane-named frame 'status))) (defun clim-fig-prompt (stream frame) (declare (ignore stream frame))) (define-clim-fig-command com-exit () (frame-exit *application-frame*)) (define-clim-fig-command com-undo () (let* ((output-history (clim-fig-output-record *application-frame*)) (record-count (output-record-count output-history)) (record (and (not (zerop record-count)) (elt (output-record-children output-history) (1- record-count))))) (if record (progn (erase-output-record record *standard-output*) (push record (clim-fig-redo-list *application-frame*))) (beep)))) (define-clim-fig-command com-redo () (let* ((record (pop (clim-fig-redo-list *application-frame*)))) (if record (progn (stream-add-output-record *standard-output* record) (replay record *standard-output* (bounding-rectangle record))) (beep)))) (define-clim-fig-command com-clear () (setf (clim-fig-redo-list *application-frame*) (append (coerce (output-record-children (clim-fig-output-record *application-frame*)) 'list) (clim-fig-redo-list *application-frame*))) (window-clear *standard-output*)) (define-clim-fig-command (com-add-figure :name nil) ((x 'real) (y 'real)) (handle-draw-object (find-pane-named *application-frame* 'canvas) x y)) (define-clim-fig-command (com-move-figure :name nil) ((figure 'figure) (x 'real) (y 'real)) (handle-move-object (find-pane-named *application-frame* 'canvas) figure x y)) (make-command-table 'file-command-table :errorp nil :menu '(("Exit" :command com-exit))) (make-command-table 'edit-command-table :errorp nil :menu '(("Undo" :command com-undo) ("Redo" :command com-redo) ("Clear" :command com-clear))) (make-command-table 'menubar-command-table :errorp nil :menu '(("File" :menu file-command-table) ("Edit" :menu edit-command-table))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Examples/text-size-test.lisp0000640000175000017500000001566110561555373022376 0ustar pdmpdm;;; -*- Mode: Lisp; -*- ;;; (c) 2006 David Lichteblau (david@lichteblau.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-demo) (define-application-frame text-size-test () () (:panes (canvas :application :min-width 600 :display-time t :display-function 'display-canvas) (text (make-pane 'text-editor :height 200 :value "ytmM")) (family (with-radio-box () (make-pane 'toggle-button :label "Fixed" :id :fixed) (radio-box-current-selection (make-pane 'toggle-button :label "Serif" :id :serif)) (make-pane 'toggle-button :label "Sans Serif" :id :sans-serif))) (face (with-radio-box (:type :some-of) (make-pane 'toggle-button :label "Bold" :id :bold) (make-pane 'toggle-button :label "Italic" :id :italic))) (rectangle (with-radio-box () (radio-box-current-selection (make-pane 'toggle-button :label "Text-Size" :id :text-size)) (make-pane 'toggle-button :label "Text-Bounding-Rectangle" :id :text-bounding-rectangle))) (size (make-pane 'slider :orientation :horizontal :value 120 :min-value 1 :max-value 1000))) (:layouts (default (vertically () (labelling (:label "Text") text) (horizontally () (labelling (:label "Family") family) (labelling (:label "Face") face) (labelling (:label "Rectangle") rectangle)) (labelling (:label "Size") size) canvas)))) (defun draw-vstrecke (stream x y1 y2 &rest args &key ink &allow-other-keys) (draw-line* stream (- x 10) y1 (+ x 10) y1 :ink ink) (draw-line* stream (- x 10) y2 (+ x 10) y2 :ink ink) (apply #'draw-arrow* stream x y1 x y2 args)) (defun draw-hstrecke (stream y x1 x2 &rest args &key ink &allow-other-keys) (draw-line* stream x1 (- y 10) x1 (+ y 10) :ink ink) (draw-line* stream x2 (- y 10) x2 (+ y 10) :ink ink) (apply #'draw-arrow* stream x1 y x2 y args)) (defun legend-text-style () (make-text-style :sans-serif :roman :small)) (defun draw-legend (stream &rest entries) (let* ((style (legend-text-style)) (y 2) (h (nth-value 1 (text-size stream "dummy" :text-style style)))) (dolist (entry entries) (when entry (incf y h) (let ((y* (+ 0.5 (round (- y (/ h 2)))))) (apply #'draw-line* stream 2 y* 35 y* (cdr entry))) (draw-text* stream (car entry) 40 y :text-style style))))) (defmethod display-canvas (frame stream) (window-clear stream) (let* ((pane-width (rectangle-width (sheet-region stream))) (pane-height (rectangle-height (sheet-region stream))) (str (gadget-value (find-pane-named frame 'text))) (size (gadget-value (find-pane-named frame 'size))) (family (gadget-id (gadget-value (find-pane-named frame 'family)))) (faces (mapcar #'gadget-id (gadget-value (find-pane-named frame 'face)))) (rectangle (gadget-id (gadget-value (find-pane-named frame 'rectangle)))) (face (if (cdr faces) '(:bold :italic) (car faces))) (style (make-text-style family face size)) (medium (sheet-medium stream))) (multiple-value-bind (width height final-x final-y baseline) (text-size stream str :text-style style) (let* ((x1 (/ (- pane-width width) 2)) (y1 (/ (- pane-height height) 2)) (ybase (+ y1 baseline))) (draw-text* stream (format nil "fixed-width-p: ~(~A~)" (handler-case (text-style-fixed-width-p style medium) (error (c) c))) 2 pane-height :text-style (legend-text-style)) (draw-legend stream (list "Ascent" ;; :line-style (make-line-style :dashes '(1.5)) :ink +black+) (list "Descent" :ink +black+) (list "Height" :line-style (make-line-style :thickness 2) :ink +black+) (list "Width (Avg.)" :ink +black+) (list "Baseline" :ink +green+) (when (eq rectangle :text-bounding-rectangle) (list "Bounding rectangle" :ink +purple+)) (when (eq rectangle :text-size) (list "Text size (width/height)" :ink +red+)) (when (eq rectangle :text-size) (list "Text size (final x/y)" :ink +blue+))) (draw-vstrecke stream (- x1 20) ybase (- ybase (text-style-ascent style medium)) ;; :line-style (make-line-style :dashes '(1.5)) :ink +black+) (draw-vstrecke stream (- x1 20) ybase (+ ybase (text-style-descent style medium)) :ink +black+) (draw-vstrecke stream (- x1 40) y1 (+ y1 (text-style-height style medium)) :line-style (make-line-style :thickness 2) :ink +black+) (draw-hstrecke stream (- y1 20) x1 (+ x1 (text-style-width style medium)) :ink +black+) (draw-line* stream 0 ybase pane-width ybase :ink +green+) (draw-text* stream str x1 ybase :text-style style) ;; Gtkairo's DRAW-TEXT* understands multiple lines. ;; (CLIM-CLX doesn't like multiple lines much.) ;; ;; If we use WRITE-STRING instead of DRAW-TEXT, the frontend will ;; handle the line breaks, but lines 2..n will start at x = 0 rather ;; than x = x1, confusing our diagram. ;;; (setf (stream-cursor-position stream) (values x1 y1)) ;;; (with-text-style (stream style) ;;; (write-string str stream)) (ecase rectangle ((:text-size) (draw-rectangle* stream x1 y1 (+ x1 width) (+ y1 height) :ink +red+ :filled nil) (draw-line* stream 0 (+ y1 final-y) pane-width (+ y1 final-y) :ink +blue+) (draw-line* stream (+ x1 final-x) 0 (+ x1 final-x) pane-height :ink +blue+)) ((:text-bounding-rectangle) (multiple-value-bind (left top right bottom) (climi::text-bounding-rectangle* medium str :text-style style) (draw-rectangle* stream (+ x1 left) (+ y1 baseline top) (+ x1 right) (+ y1 baseline bottom) :ink +purple+ :filled nil)))))))) (define-text-size-test-command (com-quit-text-size-test :menu "Quit") () (frame-exit *application-frame*)) (define-text-size-test-command (com-update-text-size-test :menu "Update") () (display-canvas *application-frame* (frame-standard-output *application-frame*))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Examples/method-browser.lisp0000644000175000017500000004174011345155772022427 0ustar pdmpdm(in-package :clim-demo) ;;;; Method-Browser Example ;;; (C) Copyright 2005 by Andy Hefner (ahefner@gmail.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; -------------------------------------------------------------------- ;;; This is an example of how to write a CLIM application with a ;;; "normal" GUI, where "normal" is a completely event driven app ;;; built using gadgets and not using the command-oriented framework. ;;; Running the method-browser: ;;; (clim-demo::run-test 'clim-demo::method-browser) ;;; How to use this app: Position the mouse over the text field labelled ;;; "Enter Name of Generic Function." Type the name of a generic ;;; function (the text field currently behaves in a focus-follows-mouse ;;; fashion) and hit enter. The specializers pane below will fill ;;; with buttons for each required argument of the function. Clicking ;;; each button produces a menu of types which that argument of the ;;; function is specialized on. As you adjust the argument types, ;;; the bottom pane of the application will display which methods ;;; would be applicable for the given arguments. ;;; This example demonstrates: ;;; * Conventional gadget-oriented interface ;;; * Dynamic creation of interface objects ;;; * Use of CLIM extended-output-streams (fonts, text-styles, etc) ;;; * CLIM table formatting ;;; * Portable MOP provided by CLIM-MOP package ;;; TODO: ;;; * Nicer, more clever display of methods than simply listing them ;;; in a row. To do this right really involes some nonportable ;;; fun and a codewalker. You could probably write something that ;;; just understood the standard method combination and qualifiers ;;; with substantially less work. ;;; * Change focus behavior of McCLIM text entry gadget ;;; * Implement focus-aware cursor shapes in McCLIM and/or Goatee ;;; (actually I did this ages ago, but let it rot away on my disk..) ;;; * Make sure the MOP usage works outside CMUCL/SBCL ;;;; CLOS / MOP Utilities (defun compute-gf-specializers (gf) "Computes a list of lists of the types for which required argument is specialized on, removing duplicates" (let* ((specializers (mapcar #'clim-mop:method-specializers (clim-mop:generic-function-methods gf)))) (loop for index from 0 below (length (first specializers)) collect (remove-duplicates (mapcar (lambda (specs) (nth index specs)) specializers))))) ;;; FIXME: why is this necessary? I'm pretty sure the #+CMU clause ;;; here has been superseded by events for quite a while now. (Should ;;; clim-mop:class not cater for these implementation differences?) (defun classp (x) (or (typep x 'cl:class) #+CMU (typep x 'pcl::class) #+scl (typep x 'clos::std-class))) ;; FIXME: returns nil if there is both an EQL specializer and a ;; class specializer for which no prototype instance is available. (defun compute-applicable-methods-from-specializers (gf specializers) (if (every #'classp specializers) (clim-mop:compute-applicable-methods-using-classes gf specializers) (let ((instances (mapcar (lambda (s) (cond ((classp s) ;; Implementation-dependent whether prototypes for ;; built-in classes (like integer, t) are available. (multiple-value-bind (prot err) (ignore-errors (clim-mop:class-prototype s)) (if err 'no-prototype prot))) ((typep s 'clim-mop:eql-specializer) (clim-mop:eql-specializer-object s)) (t (error "Can't compute effective methods, specializer ~A is not understood." s)))) specializers))) (unless (member 'no-prototype instances) (clim-mop:compute-applicable-methods gf instances))))) ;; FIXME: Support EQL specializers. ;; This is hard to do ideally, and I'm not really trying. ;; So we just make sure that T ends up at the head of the list. (defun sorted-gf-specializers (gf) "Sort a list of specializers for aesthetic purposes" (mapcar (lambda (types) (sort (copy-list types) (lambda (a b) (cond ((eql a (find-class t)) t) ((eql b (find-class t)) nil) ((and (classp a) (classp b)) (string< (class-name a) (class-name b))) ((and (typep a 'clim-mop:eql-specializer) (not (typep b 'clim-mop:eql-specializer))) nil) ((and (not (typep a 'clim-mop:eql-specializer)) (typep b 'clim-mop:eql-specializer)) t) ((and (typep a 'clim-mop:eql-specializer) (typep b 'clim-mop:eql-specializer)) (string< (princ-to-string (clim-mop:eql-specializer-object a)) (princ-to-string (clim-mop:eql-specializer-object b)))) (t (warn "Received specializer of unknown type") nil) )))) (compute-gf-specializers gf))) (defun simple-generic-function-lambda-list (gf) "Returns the required arguments of a generic function" (let ((ll (clim-mop:generic-function-lambda-list gf))) (subseq ll 0 (apply #'min (remove-if #'null (list (length ll) (position '&key ll) (position '&optional ll) (position '&rest ll) (position '&aux ll))))))) (defun specializer-pretty-name (spec) "Pretty print the name of a method specializer" (cond ((classp spec) (princ-to-string (class-name spec))) ((typep spec 'clim-mop:eql-specializer) (format nil "(EQL '~A)" (clim-mop:eql-specializer-object spec))) (t (princ-to-string spec)))) (defun maybe-find-gf (name) "Search for the generic function named by the user" (ignore-errors (let ((sym (read-from-string name))) (and sym (fboundp sym) (typep (symbol-function sym) 'generic-function) (symbol-function sym))))) (defun methodp (object) (typep object 'method)) ;; Walk the form returned by compute-effective-method, noting any methods in ;; the order we find them. This is good enough for the sort of output we are ;; producing. I hope. (defun walk-em-form (form) "Walks an effective methods form, attempting to determine what order methods will be called" (cond ((typep form 'cons) (append (walk-em-form (car form)) (walk-em-form (cdr form)))) ((methodp form) (list form)) (t nil))) ;;;; CLIM GUI ;; Every CLIM app starts with an application frame, an object which ;; encapsulates the state of an application. Windowing and abstractions ;; such as commands and menus are designed around application frames. ;; DEFINE-APPLICATION-FRAME is an extension of DEFCLASS adding options ;; to define the layout(s) and content of your application window, ;; commands within your application, a menu bar, etc. ;; The :panes option is typically used to define and name the important ;; elements of your interface. CLIM provides some syntactic sugar, for ;; example (arg-pane :vrack-pane) below is equivalent to ;; (arg-pane (make-pane 'vrack-pane)). ;; The :layouts option defines the hierarchy of windows to instantiate. ;; Multiple layouts can be defined, but a single default layout is sufficient. ;; When defining a layout, the things defined by :pane can be referred to by ;; name. The forms within the default layout below are actual lisp code - ;; vertically, labelling, scrolling, etc. are macros which can be called at ;; any time, provided some context is established first. Similarly, you could ;; call make-pane here to construct a pane anonymously. (define-application-frame method-browser () ((gf :accessor gf :initarg :gf :initform nil) (arg-types :accessor arg-types :initarg :arg-types :initform nil)) (:panes ;; Text box for the user to enter a function name (gf-name-input :text-field :activate-callback 'gf-name-input-callback :background +white+ :text-style (make-text-style :sans-serif :roman :large)) ;; Empty vertical layout pane where option-panes for arguments are added (arg-pane :vrack-pane) ;; Blank pane where the program can render output (output-pane :application-pane :text-style (make-text-style :sans-serif :roman :normal) :display-time t :display-function 'display-methods)) (:layouts (default (vertically () (labelling (:label "Enter Name of Generic Function") gf-name-input) (labelling (:label "Specializers") (spacing (:thickness 6) arg-pane)) (scrolling (:width 800 :height 600) output-pane))))) ;;; When the user types a method name and hits enter, the callback function ;;; below will be called, setting in motion the process of updating the ;;; slots in the application-frame, examining the generic function to ;;; build a set of controls for selecting argument types, and finally ;;; printing a table listing the methods. (defun gf-name-input-callback (gadget) "Callback invoked by the text input gadget when the user hits enter" (let ((gf (maybe-find-gf (gadget-value gadget)))) (when gf (setup-new-gf *application-frame* gf)))) (defun setup-new-gf (frame gf) "Update the application frame to display the supplied generic function" (setf (gf frame) gf) (setf (arg-types frame) (compute-initial-arg-types gf)) (changing-space-requirements () (gen-arg-pane frame (arg-types frame))) (redisplay-frame-pane frame (get-frame-pane frame 'output-pane) :force-p t)) (defun compute-initial-arg-types (gf) "Returns a list containing the initial specializers to use for each required argument of a function" (mapcar #'first (sorted-gf-specializers gf))) ;; Within the macro WITH-LOOK-AND-FEEL-REALIZATION, panes may be created ;; at runtime. This macro sets the environment up such that an abstract pane ;; class such as 'push-button can be translated to a concrete pane class ;; appropriate for your window system. (defun gen-arg-pane (frame arg-types) "Generates contents of argument pane. For each required argument an option-pane is created allowing the user to select one of the specializers available for that argument." (let ((container (find-pane-named frame 'arg-pane))) ;; Delete the children of the container pane (dolist (child (sheet-children container)) (sheet-disown-child container child)) ;; Repopulate the container pane with a new table pane containing ;; option-panes for each specializer argument. (let ((fm (frame-manager *application-frame*))) (with-look-and-feel-realization (fm *application-frame*) (sheet-adopt-child container (make-pane 'table-pane :spacing 8 ;; McCLIM issue: spacing initarg :contents (loop for index from 0 by 1 for curval in arg-types for specs in (sorted-gf-specializers (gf frame)) for name in (simple-generic-function-lambda-list (gf frame)) collect (list (make-pane 'label-pane :label (princ-to-string name)) (make-pane 'option-pane :items specs :value curval :value-changed-callback (let ((index index)) (lambda (value-gadget value) (declare (ignore value-gadget)) (setf (nth index (arg-types frame)) value) (redisplay-frame-pane frame (find-pane-named frame 'output-pane) :force-p t))) :name-key #'specializer-pretty-name)))) ))))) ;;; Generate contents of output-pane (defparameter *method-qualifier-ink* +red+) (defparameter *specializer-text-style* (make-text-style :sans-serif :roman :normal)) (defmethod present-method (method stream) "Produces one table row to describe a method" (let ((*print-pretty* nil)) ;; Method type, if not standard-method (formatting-cell (stream :align-x :left) (when (not (typep method 'standard-method)) (princ (type-of method) stream))) ;; Method qualifiers (formatting-cell (stream :align-x :center) (with-drawing-options (stream :ink *method-qualifier-ink*) (when (clim-mop:method-qualifiers method) (let ((first t)) (dolist (symbol (clim-mop:method-qualifiers method)) (if first (setf first nil) (princ " " stream)) (present symbol (presentation-type-of symbol) :stream stream)))))) ;; Method specializers ; This is very silly, but put the surrounding parens in their own column ; because I'm anal about the formatting. (formatting-cell (stream :align-x :right) (princ " (" stream)) (dolist (spec (clim-mop:method-specializers method)) (formatting-cell (stream :align-x :center) (with-drawing-options (stream :text-style *specializer-text-style* :ink (ink-for-specializer spec)) (with-output-as-presentation (stream spec (presentation-type-of spec)) (princ (specializer-pretty-name spec) stream))))) (formatting-cell (stream :align-x :left) (princ ")" stream)))) (defun display-methods (frame pane) "Generates the display of applicable methods in the output-pane" (when (gf frame) (let* ((gf (gf frame)) (methods (compute-applicable-methods-from-specializers gf (arg-types frame))) (combination (clim-mop:generic-function-method-combination gf)) (effective-methods (clim-mop:compute-effective-method gf combination methods)) (serial-methods (walk-em-form effective-methods))) ;; Print the header (fresh-line) (with-drawing-options (pane :text-style (make-text-style :sans-serif :bold :large) :ink +royal-blue+) (surrounding-output-with-border (pane :shape :underline) (princ "Applicable Methods" pane))) (terpri) ;; Generate a table for the methods (formatting-table (pane :x-spacing " ") (formatting-row (pane) (gf-column-headers (gf frame) pane)) (dolist (method serial-methods) (formatting-row (pane) (present-method method pane)))) (terpri pane)))) (defun ink-for-specializer (spec) "Determine a color to use when displaying a specializer, highlighting if one of the types selected by the user." (if (not (typep *application-frame* 'method-browser)) +foreground-ink+ (if (member spec (arg-types *application-frame*)) +OliveDrab4+ +grey18+))) (defparameter *column-header-ink* +gray50+) (defparameter *column-header-text-style* (make-text-style :sans-serif :bold :small)) (defun gf-column-headers (gf stream) "Produces a row of column titles for the method table" (flet ((header (label) (formatting-cell (stream :align-x :center) (unless (zerop (length label)) (with-drawing-options (stream :ink *column-header-ink* :text-style *column-header-text-style*) (surrounding-output-with-border (stream :shape :underline) (princ label stream))))))) ;; Method type (header "") (header "Qualifier") (header "") (dolist (arg (simple-generic-function-lambda-list gf)) (header (princ-to-string arg))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Examples/gadget-test.lisp0000600000175000017500000002701310423413313021643 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- ;;; (c) copyright 2000 by ;;; Iban Hatchondo (hatchond@emi.u-bordeaux.fr) ;;; Julien Boninfante (boninfan@emi.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-demo) ;; Gadget Test/Demo ;; To run the gadget test: (clim-demo:gadget-test) ;; McCLIM contains an alternate look and feel entitled "pixie" which is ;; not the default. It can by used by creating your application using an ;; alternate frame manager, clim-internals::pixie/clx-look. ;; To run the gadget test using the pixie frame manager: ;; (gadget-test 'clim-internals::pixie/clx-look) ;; This may require you to load the clim-looks system. (defun gadget-test (&optional frame-manager-name) (run-frame-top-level (if frame-manager-name (make-application-frame 'gadget-test :frame-manager (make-instance frame-manager-name :port (find-port))) (make-application-frame 'gadget-test)))) (export 'gadget-test) (defun run-pixie-test (name) (when name (run-frame-top-level (make-application-frame name :frame-manager (make-instance 'clim-internals::pixie/clx-look :port (find-port)))))) (defmethod gadget-test-frame-top-level ((frame application-frame) &key (command-parser 'command-line-command-parser) (command-unparser 'command-line-command-unparser) (partial-command-parser 'command-line-read-remaining-arguments-for-partial-command) (prompt "Command: ")) (declare (ignore command-parser command-unparser partial-command-parser prompt)) (catch 'exit (clim-extensions:simple-event-loop)) (frame-exit frame)) (make-command-table 'lisp-menu :errorp nil :menu '(("Heir" :menu lisp-sub-menu) ("Lisp" :command test) ("Lisp" :command test))) (make-command-table 'lisp-sub-menu :errorp nil :menu '(("Does" :command test) ("This" :command test) ("Work?" :command test))) (make-command-table 'edit-menu :errorp nil :menu '(("Edit" :command test) ("Edit" :command test) ("Edit" :command test))) (make-command-table 'view-menu :errorp nil :menu '(("View" :command test) ("View" :command test) ("View" :command test))) (make-command-table 'search-menu :errorp nil :menu '(("Search" :command test) ("Search" :command test) ("Search" :command test))) (define-command test () (format *error-output* "That was just a test~%") (finish-output *error-output*)) (macrolet ((make-pane-constructor (class-name) `(defmacro ,class-name (&rest options) `(make-pane ',',class-name ,@options)))) (make-pane-constructor text-field) (make-pane-constructor text-edit) (make-pane-constructor slider) (make-pane-constructor push-button) (make-pane-constructor toggle-button)) (define-application-frame gadget-test () () (:menu-bar (("Lisp" :menu lisp-menu) ("Edit" :menu edit-menu) ("View" :menu view-menu) ("Search" :menu search-menu))) (:panes ; (raised (raising (:border-width 3 :background +Gray83+) ; (make-pane 'check-box :choices '("First" "Second" "Third")))) (tf1 :push-button :text-style (make-text-style :fix :roman 24) :label "Text Field") (tf2 :push-button :text-style (make-text-style :serif :roman 24) :label "Text Field") (tf3 :push-button :text-style (make-text-style :serif :italic 24) :label "Text Field") (tf4 :push-button :text-style (make-text-style :sans-serif '(:bold :italic) 24) :label "Text Field") (text-edit :text-editor :value "Text Editor") (slider-h :slider :min-value 0 :max-value 100 :value 0 :show-value-p t :orientation :horizontal :current-color +black+) (slider-v :slider :min-value 0 :max-value 100 :orientation :vertical :current-color +black+ :value 0) (slider-v1 :slider :min-value 0 :max-value 100 :orientation :vertical :current-color +black+ :value 0) (slider-v2 :slider :min-value 0 :max-value 100 :orientation :vertical :current-color +black+ :value 0) (slider-v3 :slider :min-value 0 :max-value 100 :orientation :vertical :current-color +black+ :value 0) (radar (make-pane 'radar-pane :name 'radar)) (push-btn (lowering (:border-width 3 :background +Gray83+) (horizontally () (push-button :name "Radiate" :label "Radiate" :activate-callback (lambda (pane &rest args) nil)) (push-button :label "No, Push Me") (push-button :label "Me!")))) (table (lowering (:border-width 3 :background +Gray83+) (tabling (:height 50) (list (push-button :label "A") (push-button :label "B")) (list (push-button :label "C") (push-button :label "D")) (list (push-button :label "E") (push-button :label "F"))))) (toggle-btn :toggle-button :label "Toggle" :value t :normal +red+ :highlighted +red+ :pushed-and-highlighted +red+) (scroll (raising (:border-width 1 :background +Gray83+) (scrolling (:background +Gray83+ :width 100 :height 100) (horizontally () (vertically () (push-button :label "This is a button") (push-button :label "That is a button") (push-button :label "This is a button too")) (with-radio-box (:orientation :vertical) (clim:radio-box-current-selection "First") "Second" "Third" "Red" "Blue" "Orange" "Elephant" "Dog" "Cat") (with-radio-box (:orientation :vertical :type :some-of) (clim:radio-box-current-selection "Fourth") "Fifth" "Sixth") (with-radio-box (:orientation :vertical) (clim:radio-box-current-selection "Seventh") "Eighth" "Ninth") (with-radio-box (:orientation :vertical :type :some-of) (clim:radio-box-current-selection "Tenth") "Eleventh" "Twelth"))))) (radio-box (with-radio-box (:orientation :horizontal) (clim:radio-box-current-selection "One") "Two" "Three")) (check-box (with-radio-box (:type :some-of :orientation :horizontal) (clim:radio-box-current-selection "First") "Second" "Third"))) (:layouts (default (raising (:border-width 5 :background +Gray83+) (horizontally () (vertically () (horizontally () (horizontally () (vertically () slider-v slider-v2) slider-v3) (vertically () tf1 tf2 tf3 tf4 slider-h)) ;; FIXME: the radar doesn't seem to do anything except take ;; up vast amounts of space. #+(or) radar text-edit) (vertically () push-btn table toggle-btn scroll radio-box check-box))))) (:top-level (gadget-test-frame-top-level . nil))) (defmethod run-frame-top-level :around ((frame gadget-test) &key &allow-other-keys) ;; FIXME: Timer events appear to have rotted. ;; Also, the following won't work because the frame has not really been realized yet, ;; so you can't get at its panes. Yet it has worked, and recently. Odd. ;; (clim-internals::schedule-timer-event (find-pane-named frame 'radar) 'radiate 0.1) (call-next-method)) (defclass radar-pane (basic-gadget) ( (points :initform '((0.01 0.01 0.10 0.10) (0.10 0.02 0.70 0.40) (0.20 0.03 0.60 0.30) (0.20 0.04 0.20 0.50) (0.20 0.05 0.60 0.20) (0.20 0.06 0.30 0.40) (0.20 0.07 0.60 0.90) (0.20 0.08 0.80 0.30) (0.20 0.09 0.60 0.20))))) (defmethod handle-event ((pane radar-pane) (event timer-event)) (with-slots (points) pane (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region pane) (let ((xf (- x2 x1)) (yf (- y2 y1))) (dolist (point points) (destructuring-bind (radius grow x y) point (let ((old-radius radius)) (setf radius (if (< radius 0.3) (+ radius grow) (progn (setf (second point) (random 0.10)) (setf (third point) (random 1.0)) (setf (fourth point) (random 1.0)) 0.01))) (setf (first point) radius) ; v- fix with a transform? (let ((x (+ x1 (* x xf))) (y (+ y1 (* y yf))) (rx (* radius xf)) (ry (* radius yf)) (orx (* old-radius xf)) (ory (* old-radius yf))) (when (> radius 0.01) (draw-ellipse* pane x y 0 ry rx 0 :ink +black+ :filled nil)) (draw-ellipse* pane x y 0 ory orx 0 :ink +white+ :filled nil)))))))) (clim-internals::schedule-timer-event pane 'radiate 0.1)) #-sbcl (defun common-lisp-user::lg () ; convenience, because I'm lazy (with-open-file (file "Examples/grammar.lisp" :external-format :euc-kr) (load file)) (run-pixie-test 'grammar)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Examples/views.lisp0000640000175000017500000001625310521232654020606 0ustar pdmpdm;;; ;;; This example shows how to use CLIM view objects. We imagine a small ;;; database of members in some organization, and we sometimes want to ;;; see a list of all the members, with one member per line, and sometimes ;;; a detailed view of a single member, perhaps in order to check the ;;; payment record, or to modify some information such as the address. ;;; Copyright (c) 2006 by Robert Strandh ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (defpackage :views-example (:use :clim-lisp :clim) (:export #:views-example)) (in-package :views-example) ;;; part of application "business logic" (defclass person () ((%last-name :initarg :last-name :accessor last-name) (%first-name :initarg :first-name :accessor first-name) (%address :initarg :address :accessor address) (%membership-number :initarg :membership-number :reader membership-number))) ;;; constructor for the PERSON class. Not strictly necessary. (defun make-person (last-name first-name address membership-number) (make-instance 'person :last-name last-name :first-name first-name :address address :membership-number membership-number)) ;;; initial list of members of the organization we imagine for this example (defparameter *members* (list (make-person "Doe" "Jane" "123, Glencoe Terrace" 12345) (make-person "Dupont" "Jean" "111, Rue de la Republique" 54321) (make-person "Smith" "Eliza" "22, Trafalgar Square" 121212) (make-person "Nilsson" "Sven" "Uppsalagatan 33" 98765))) ;;; we define a present method that is called when CLIM is told to ;;; display a person object to the user. (define-presentation-method present ((object person) (type person) stream view &key) (declare (ignore view)) (format stream "~A ~A" (first-name object) (last-name object))) ;; we also define an accept method that CLIM uses to convert text ;; input to a person. Note that the text generated by the present ;; method is acceptable input for the accept method. (define-presentation-method accept ((type person) stream view &key) ;; this means we can have spaces in the input. (with-delimiter-gestures (nil :override t) ;; we just ask for a string and complain if it isn't a known ;; name. We also do not want to show another input prompt, hence ;; the :prompt and :prompt-mode parameters. (let ((name (accept 'string :stream stream :view view :prompt "" :prompt-mode :raw))) (or (find name *members* :test #'string= :key #'(lambda (person) (format nil "~A ~A" (first-name person) (last-name person)))) (simple-parse-error "~A is not a known person" name))))) ;;; the CLIM view class that corresponds to a list of members, one member ;;; per line of text in a CLIM application pane. (defclass members-view (view) ()) ;;; since this view does not take any parameters in our simple example, ;;; we need only a single instance of it. (defparameter *members-view* (make-instance 'members-view)) ;;; the application frame. It contains instance-specific data ;;; such as the members of our organization. (define-application-frame views () ((%members :initform *members* :accessor members)) (:panes (main-pane :application :height 500 :width 500 :display-function 'display-main-pane ;; notice the initialization of the default view of ;; the application pane. :default-view *members-view*) (interactor :interactor :height 100 :width 500)) (:layouts (default (vertically () main-pane interactor)))) ;;; the trick here is to define a generic display function ;;; that is called on the frame, the pane AND the view, ;;; whereas the standard CLIM display functions are called ;;; only on the frame and the pane. (defgeneric display-pane-with-view (frame pane view)) ;;; this is the display function that is called in each iteration ;;; of the CLIM command loop. We simply call our own, more elaborate ;;; display function with the default view of the pane. (defun display-main-pane (frame pane) (display-pane-with-view frame pane (stream-default-view pane))) ;;; now we can start writing methods on our own display function ;;; for different views. This one displays the data each member ;;; on a line of its own. (defmethod display-pane-with-view (frame pane (view members-view)) (loop for member in (members frame) do (with-output-as-presentation (pane member 'person) (format pane "~a, ~a, ~a, ~a~%" (membership-number member) (last-name member) (first-name member) (address member))))) ;;; this CLIM view is used to display the information about ;;; a single person. It has a slot that indicates what person ;;; we want to view. (defclass person-view (view) ((%person :initarg :person :reader person))) ;;; this method on our own display function shows the detailed ;;; information of a single member. (defmethod display-pane-with-view (frame pane (view person-view)) (let ((person (person view))) (format pane "Last name: ~a~%First Name: ~a~%Address: ~a~%Membership Number: ~a~%" (last-name person) (first-name person) (address person) (membership-number person)))) ;;; entry point to start our applciation (defun views-example () (run-frame-top-level (make-application-frame 'views))) ;;; command to quit the application (define-views-command (com-quit :name t) () (frame-exit *application-frame*)) ;;; command to switch the default view of the application pane ;;; (which is the value of *standard-output*) to the one that ;;; shows a member per line. (define-views-command (com-show-all :name t) () (setf (stream-default-view *standard-output*) *members-view*)) ;;; command to switch to a view that displays a single member. ;;; this command takes as an argument the person to display. ;;; In this application, the only way to satisfy the demand for ;;; the argument is to click on a line of the members view. In ;;; more elaborate application, you might be able to type a ;;; textual representation (using completion) of the person. (define-views-command (com-show-person :name t) ((person 'person)) (setf (stream-default-view *standard-output*) (make-instance 'person-view :person person))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Examples/calculator.lisp0000640000175000017500000001157410561555373021615 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- ;;; (c) copyright 2000 by ;;; Iban Hatchondo (hatchond@emi.u-bordeaux.fr) ;;; Julien Boninfante (boninfan@emi.u-bordeaux.fr) ;;; Robert Strandh (strandh@labri.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-demo) (defparameter *calculator-text-style* (make-text-style :sans-serif :roman :large)) (defun calculator () #+nil (progn (loop for port in climi::*all-ports* do (destroy-port port)) (setq climi::*all-ports* nil)) (let ((frame (make-application-frame 'calculator))) (run-frame-top-level frame) frame)) (defun show (number) (setf (gadget-value (slot-value *application-frame* 'text-field)) (princ-to-string number))) (defun queue-number (number) (lambda (gadget) (declare (ignore gadget)) (with-slots (state) *application-frame* (if (numberp (first state)) (setf (first state) (+ (* 10 (first state)) number)) (push number state)) (show (first state))))) (defun queue-operator (operator) (lambda (gadget) (declare (ignore gadget)) (do-operation t) (with-slots (state) *application-frame* (if (functionp (first state)) (setf (first state) operator) (push operator state))))) (defun do-operation (gadget) (declare (ignore gadget)) (with-slots (state) *application-frame* (when (= 3 (length state)) (setf state (list (funcall (second state) (third state) (first state)))) (show (first state))))) (defun initac (gadget) (declare (ignore gadget)) (with-slots (state) *application-frame* (setf state (list 0))) (show 0)) (defun initce (gadget) (declare (ignore gadget)) (with-slots (state) *application-frame* (when (numberp (first state)) (pop state)) (show 0))) (defmethod calculator-frame-top-level ((frame application-frame) &key (command-parser 'command-line-command-parser) (command-unparser 'command-line-command-unparser) (partial-command-parser 'command-line-read-remaining-arguments-for-partial-command) (prompt "Command: ")) (declare (ignore command-parser command-unparser partial-command-parser prompt)) (clim-extensions:simple-event-loop)) (defun make-button (label operator &key width height (max-width +fill+) min-width (max-height +fill+) min-height) (make-pane 'push-button :label label :activate-callback operator :text-style *calculator-text-style* :width width :height height :max-width max-width :min-width min-width :max-height max-height :min-height min-height)) (define-application-frame calculator () ((text-field :initform nil) (state :initform (list 0))) (:panes (plus (make-button "+" (queue-operator #'+))) (dash (make-button "-" (queue-operator #'-))) (multiply (make-button "*" (queue-operator #'*))) (divide (make-button "/" (queue-operator #'round))) (result (make-button "=" #'do-operation)) (one (make-button "1" (queue-number 1))) (two (make-button "2" (queue-number 2))) (three (make-button "3" (queue-number 3))) (four (make-button "4" (queue-number 4))) (five (make-button "5" (queue-number 5))) (six (make-button "6" (queue-number 6))) (seven (make-button "7" (queue-number 7))) (eight (make-button "8" (queue-number 8))) (nine (make-button "9" (queue-number 9))) (zero (make-button "0" (queue-number 0))) (screen :text-field :value "0" :text-style *calculator-text-style*) (ac (make-button "AC" #'initac)) (ce (make-button "CE" #'initce))) (:layouts (default (with-slots (text-field) *application-frame* (vertically (:width 150 :max-width 500) (setf text-field screen) (horizontally (:height 50) ac ce) (tabling (:grid t) (list one two plus) (list three four dash) (list five six multiply) (list seven eight divide) (list nine zero result)))))) (:top-level (calculator-frame-top-level . nil))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Examples/draggable-graph.lisp0000600000175000017500000001103310416424770022450 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-DEMO -*- ;;; (c) copyright 2005 by ;;; Andy Hefner (ahefner@gmail.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-demo) ;;; Demo of draggable graph nodes (define-application-frame draggable-graph-demo () () (:pane (make-pane 'application-pane :width :compute :height :compute :display-function 'generate-graph :display-time t))) (defun generate-graph (frame pane) (format-graph-from-roots (list (find-class 'number)) (lambda (object stream) (present (clim-mop:class-name object) (presentation-type-of object) :stream stream)) #'clim-mop:class-direct-subclasses :stream pane)) (defun record-parent-chain (record) (and record (cons record (record-parent-chain (output-record-parent record))))) (defun find-graph-node (record) "Searches upward until a graph node parent of the supplied output record is found." (find-if #'graph-node-output-record-p (record-parent-chain record))) (defun node-edges (node) (let (edges) (maphash (lambda (child edge) (declare (ignore child)) (push edge edges)) (slot-value node 'climi::edges-from)) (maphash (lambda (parent edge) (declare (ignore parent)) (push edge edges)) (slot-value node 'climi::edges-to)) edges)) (defun redisplay-edges (graph edges) (dolist (edge edges) (with-slots (climi::from-node climi::to-node) edge (climi::layout-edge-1 graph climi::from-node climi::to-node)))) ;;; (AH) McCLIM bug of the day: ;;; ;;; (I haven't looked in detail at the spec or McCLIM to confirm my ;;; assumptions here, but as I understand things..) CLIM regions are ;;; immutable. Output records ARE mutable. A McCLIM output record can ;;; be used as a rectangular region corresponding to its bounding ;;; rectangle. But this bounding rectangle is not immutable! So, ;;; region operations such as region-union may build a rectangle-set ;;; capturing the mutable output-record object, violating the ;;; immutability of regions and causing widespread panic and ;;; confusion. (defun stupid-copy-rectangle (region) (with-bounding-rectangle* (x0 y0 x1 y1) region (make-rectangle* x0 y0 x1 y1))) (define-draggable-graph-demo-command (com-drag-node) ((record t) (x 'real) (y 'real)) (let* ((graph-node (find-graph-node record)) (edges (node-edges graph-node)) (erase-region (stupid-copy-rectangle (reduce (lambda (x &optional y) (if y (region-union x y) x)) edges)))) (multiple-value-bind (px py) (output-record-position graph-node) (let ((graph (output-record-parent graph-node)) (x-offset (- x px)) (y-offset (- y py))) (assert (typep graph 'graph-output-record)) (erase-output-record graph-node *standard-output*) (dolist (edge edges) (clear-output-record edge)) (when edges (repaint-sheet *standard-output* erase-region)) (multiple-value-bind (final-x final-y) (drag-output-record *standard-output* graph-node :erase-final t :finish-on-release t) (setf (output-record-position graph-node) (values (- final-x x-offset) (- final-y y-offset))) (add-output-record graph-node graph) (redisplay-edges graph edges) (repaint-sheet *standard-output* graph-node)))))) (define-presentation-to-command-translator record-dragging-translator (t com-drag-node draggable-graph-demo :tester ((presentation) (find-graph-node presentation))) (presentation x y) (list presentation x y)) ;;; (CSR) This demo code is quite cool; visually, it's a little ;;; disconcerting to have the edges disappear when dragging, but ;;; that's acceptable, though I think it might be possible to preserve ;;; them by having a feedback function for the call to ;;; DRAG-OUTPUT-RECORD. cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Examples/stopwatch.lisp0000644000175000017500000001721210261236753021472 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-DEMO -*- ;;; (c) copyright 2005 by ;;; Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; This is an example of multiprocessing in which a thread -- running a ;;; simulation or responding to external events -- sends events to the ;;; application thread that cause it to refresh the display. The two threads ;;; share state variables protected by a lock; the application thread uses a ;;; condition variable to signal the simulation thread to change its ;;; behavior. One could also envision sending the simulation state in a ;;; message to the application thread and using an event queue to send control ;;; messages back to the simulation thread, eliminating the need for explicit ;;; locks. Perhaps in anothor demo... ;;; ;;; Based on an idea described by Paul Werkowski in the mcclim-devel mailing ;;; list. (in-package :clim-demo) (define-application-frame stopwatch () ( ;; state of the timer (start-time :accessor start-time :initform 0 :documentation "In internal time units") (elapsed-time :accessor elapsed-time :initform 0 :documentation "In internal time units") (stop-time :accessor stop-time :initform 0 :documentation "In count-down mode, elapsed time to stop") (mode :accessor mode :initform :stopped) ;; data displayed by main thread (hours :accessor hours :initform 0) (minutes :accessor minutes :initform 0) (seconds :accessor seconds :initform 0) (clock-process :accessor clock-process :initform nil) (condition-variable :accessor condition-variable :initform (clim-sys:make-condition-variable)) (clock-lock :accessor clock-lock :initform (clim-sys:make-lock))) (:pointer-documentation t) (:panes (clock :application :width 300 :height 200 :display-function 'draw-clock :incremental-redisplay t :scroll-bars nil) (commands :interactor :height 100)) (:layouts (default (vertically () clock commands)))) (define-presentation-type clock () :inherit-from t) (defmacro with-locking-bind (var-forms lock &body body) "Bind the variables in VAR-FORMS under the protection of LOCK, then release the lock for the BODY. Declarations are permitted in BODY." (let ((vars (mapcar #'(lambda (form) (if (consp form) (car form) form)) var-forms)) (vals (mapcar #'(lambda (form) (if (consp form) (cadr form) nil)) var-forms))) `(multiple-value-bind ,vars (clim-sys:with-lock-held (,lock) (values ,@vals)) ,@body))) (defun draw-clock (frame pane) (with-locking-bind ((hours (hours frame)) (minutes (minutes frame)) (seconds (seconds frame)) (elapsed-time (elapsed-time frame))) (clock-lock frame) ;; Center the clock face in the pane (with-bounding-rectangle* (min-x min-y max-x max-y) (sheet-region pane) (let ((record (with-output-recording-options (pane :record t :draw nil) (with-output-as-presentation (pane elapsed-time 'clock :single-box t) (with-text-size (pane :huge) ;; Use a table because otherwise its tricky to get the ;; stream state just right for each individual ;; updating-output form. (formatting-table (pane :x-spacing 0) (formatting-row (pane) (formatting-cell (pane) (updating-output (pane :unique-id 'hours :cache-value hours) (format pane "~D:" hours))) (formatting-cell (pane) (updating-output (pane :unique-id 'minutes :cache-value minutes) (format pane "~2,'0D:" minutes))) (formatting-cell (pane) (let ((secs (truncate seconds))) (updating-output (pane :unique-id 'seconds :cache-value secs) (format pane "~2,'0D" secs))))))))))) (with-bounding-rectangle* (r-minx r-miny r-maxx r-maxy) record (let ((width (- r-maxx r-minx)) (height (- r-maxy r-miny))) (setf (output-record-position record) (values (+ min-x (/ (- max-x min-x width) 2.0)) (+ min-y (/ (- max-y min-y height) 2.0)))))) (replay record pane))))) (defclass my-event (device-event) () (:default-initargs :modifier-state 0)) ;;; Paul's example, which works in Lispworks' CLIM, doesn't specialize on the ;;; client argument. Mcclim has a primary method defined on ;;; standard-sheet-input-mixin which does nothing, so we need to specialize ;;; the first argument here to override that method. (defmethod handle-event ((client application-pane) (event my-event)) (with-application-frame (frame) (redisplay-frame-pane frame client))) (defun decode-time (internal-time) (multiple-value-bind (hours min-rem) (truncate (float (/ internal-time internal-time-units-per-second)) 3600.0) (multiple-value-bind (minutes secs) (truncate min-rem 60.0) (values hours minutes (float secs))))) ;;; The simulation thread function. (defun update-clock (frame client) (let ((tls (frame-top-level-sheet frame)) (clock-lock (clock-lock frame))) (clim-sys:with-lock-held (clock-lock) (loop (when (eq (mode frame) :exit) (return-from update-clock nil)) (when (eq (mode frame) :stopped) (clim-sys:condition-wait (condition-variable frame) clock-lock) (setf (start-time frame) (get-internal-real-time) (elapsed-time frame) 0)) (when (eq (mode frame) :running) (let ((new-time (- (get-internal-real-time) (start-time frame)))) (setf (elapsed-time frame) new-time) (multiple-value-bind (hours minutes seconds) (decode-time new-time) (when (or (/= hours (hours frame)) (/= minutes (minutes frame)) (/= seconds (seconds frame))) (setf (hours frame) hours (minutes frame) minutes (seconds frame) seconds) (queue-event tls (make-instance 'my-event :sheet client)))) (clim-sys:condition-wait (condition-variable frame) clock-lock .1))))))) (defmethod run-frame-top-level ((frame stopwatch) &key) (let ((clock-pane (find-pane-named frame 'clock))) (setf (clock-process frame) (clim-sys:make-process #'(lambda () (update-clock frame clock-pane)) :name "ticker"))) (unwind-protect (call-next-method) (when (clock-process frame) (clim-sys:destroy-process (clock-process frame)) (setf (clock-process frame) nil)))) (define-stopwatch-command (com-toggle-watch :name t) () (setf (mode *application-frame*) (if (eq (mode *application-frame*) :stopped) :running :stopped)) (clim-sys:with-lock-held ((clock-lock *application-frame*) "clock lock") (clim-sys:condition-notify (condition-variable *application-frame*)))) (define-presentation-to-command-translator com-click-stopwatch (clock com-toggle-watch stopwatch) () nil) (define-stopwatch-command (com-quit :name t) () (setf (mode *application-frame*) :exit) (clim-sys:condition-notify (condition-variable *application-frame*)) (frame-exit *application-frame*)) (defun run-stopwatch () (run-frame-top-level (make-application-frame 'stopwatch))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Examples/transformations-test.lisp0000644000175000017500000002014507636702774023700 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-TRANSFORMATIONS-TEST; Base: 10; Lowercase: Yes -*- ;;; (c) copyright 2001 by ;;; Alexey Dejneka (adejneka@comail.ru) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (defpackage "CLIM-TRANSFORMATIONS-TEST" (:use :clim :clim-lisp)) (in-package :clim-transformations-test) (defparameter *transformations-test-file* #p"transformations-test.ps") ;;; --- Test 1: Painter (see SICP 2.2.4). Scaling and reflection. ;;; Protocol class (defclass picture () ()) (defgeneric draw (sheet picture) (:documentation "Draw PICTURE on SHEET in square (0,0)-(1,0)-(1,1)-(0,1)")) ;;; Basic picture (defconstant +d+ 0.15) (defconstant +eyes-y+ 0.80) (defconstant +r-mouth+ +d+) (defclass face (picture) ()) (defmethod draw (sheet (picture face)) (draw-circle* sheet 0.5 0.5 0.45 :filled nil) (draw-points* sheet (list (- 0.5 +d+) +eyes-y+ (+ 0.5 +d+) +eyes-y+)) (draw-line* sheet 0.5 +eyes-y+ 0.5 0.5) (draw-circle* sheet 0.5 0.5 +r-mouth+ :filled nil :start-angle (* 5/4 pi))) ;;; (defclass vertical-picture (picture) ((picture1 :type picture :initarg :picture1) (picture2 :type picture :initarg :picture2))) (defmethod draw (sheet (picture vertical-picture)) (with-slots (picture1 picture2) picture (with-scaling (sheet 1 0.5) (draw sheet picture1) (with-translation (sheet 0 1) (draw sheet picture2))))) (defclass horizontal-picture (picture) ((picture1 :type picture :initarg :picture1) (picture2 :type picture :initarg :picture2))) (defmethod draw (sheet (picture horizontal-picture)) (with-slots (picture1 picture2) picture (with-scaling (sheet 0.5 1) (draw sheet picture1) (with-translation (sheet 1 0) (draw sheet picture2))))) (defun below (picture1 picture2) (make-instance 'vertical-picture :picture1 picture1 :picture2 picture2)) (defun beside (picture1 picture2) (make-instance 'horizontal-picture :picture1 picture1 :picture2 picture2)) ;;; Transformers (defclass picture-transformer (picture) ((original :type picture :initarg :picture :reader original))) (defmethod draw (sheet (picture picture-transformer)) (draw sheet (original picture))) ;;; Flipping (defclass vertically-flipped-picture (picture-transformer) ()) (defmethod draw :around (sheet (picture vertically-flipped-picture)) (with-drawing-options (sheet :transformation (make-reflection-transformation* 0 0.5 1 0.5)) (call-next-method sheet picture))) (defclass horizontally-flipped-picture (picture-transformer) ()) (defmethod draw :around (sheet (picture horizontally-flipped-picture)) (with-drawing-options (sheet :transformation (make-reflection-transformation* 0.5 0 0.5 1)) (call-next-method sheet picture))) (defun flip-vert (picture) (make-instance 'vertically-flipped-picture :picture picture)) (defun flip-horiz (picture) (make-instance 'horizontally-flipped-picture :picture picture)) ;;; ROTATED-PICTURE (defclass rotated-picture (picture-transformer) ()) (defmethod draw :around (sheet (picture rotated-picture)) (with-rotation (sheet (* pi 0.5) (make-point 0.5 0.5)) (call-next-method sheet picture))) (defun rotate (picture) (make-instance 'rotated-picture :picture picture)) ;;; Recursive splitting (defun right-split (picture times) (if (= times 0) picture (let ((smaller (right-split picture (1- times)))) (beside picture (below smaller smaller))))) (defun up-split (picture times) (if (= times 0) picture (let ((smaller (up-split picture (1- times)))) (below picture (beside smaller smaller))))) (defun corner-split (picture times) (if (= times 0) picture (let ((up (up-split picture (1- times))) (right (right-split picture (1- times)))) (let ((top-left (beside up up)) (bottom-right (below right right)) (corner (corner-split picture (1- times)))) (beside (below picture top-left) (below bottom-right corner)))))) (defun square-limit (picture n) (let* ((quarter (corner-split picture n)) (half (beside (flip-horiz quarter) quarter))) (below (flip-vert half) half))) ;;; Test (defvar *basic-picture* (make-instance 'face)) (defvar *my-picture* (square-limit *basic-picture* 4)) (defun test-painter (sheet) (with-scaling (sheet 300) (with-translation (sheet 0.5 1) (draw sheet *my-picture*)))) ;;; --- Test 2: Rotation and slanting --- (defun make-slanting-transformation (k) "Make transformation (x,y) -> (x, y+kx)" (make-3-point-transformation* 0 0 1 0 0 1 0 0 1 0 k 1)) (defmacro with-slanting ((medium k) &body body) `(with-drawing-options (,medium :transformation (make-slanting-transformation ,k)) ,@body)) (defun draw-my-square (sheet) (draw-rectangle* sheet -0.5 -0.5 0.5 0.5 :filled nil) (draw-circle* sheet 0 0 0.5 :start-angle (* pi 0.5) :ink +red+)) (defconstant +slanting-full-angle+ (* pi 0.5)) (defconstant +slanting-full-slant+ 3) (defun draw-slantings (sheet &key (nangles 10) (nslantings 10)) (let ((da (/ +slanting-full-angle+ nangles)) (ds (/ +slanting-full-slant+ nslantings))) (dotimes (iangle (1+ nangles)) (let ((angle (* da iangle))) (dotimes (islant nslantings) (let ((slant (* ds islant))) (with-translation (sheet (* 1.5 iangle) (* 1.5 islant)) (with-slanting (sheet slant) (with-rotation (sheet angle) (draw-my-square sheet))) (draw-lines* sheet '( -0.5 0 0.5 0 0 -0.5 0 0.5) :ink +blue+)))))))) (defun test-slantings (sheet) (with-scaling (sheet 30) (with-translation (sheet 1 1) (draw-slantings sheet)))) ;;; --- Test 3: Continuity --- (defun draw-sectors (sheet &key (nwidths 10) (nstarts 10)) (let ((dsa (/ (* 2 pi) nstarts)) (dw (/ (* 2 pi) nwidths))) (dotimes (iw (1+ nwidths)) (dotimes (isa (1+ nstarts)) (let* ((sa (* isa dsa)) (w (* iw dw))) (with-translation (sheet (* 1.5 iw) (* 1.5 isa)) (with-rotation (sheet sa (make-point 0.5 0.5)) (draw-circle* sheet 0.5 0.5 0.5 :start-angle 0 :end-angle w :ink +blue+ :filled nil)) (draw-lines* sheet '(0.0 0.5 1.0 0.5 0.5 0.0 0.5 1.0) :ink +red+))))))) (defun test-continuity (sheet) (with-scaling (sheet 30) (draw-sectors sheet))) ;;; Test (defun transformations-test () (with-open-file (file *transformations-test-file* :direction :output) (with-output-to-postscript-stream (stream file) (with-output-recording-options (stream :record nil) (test-painter stream) (new-page stream) (test-slantings stream) (new-page stream) (test-continuity stream) (new-page stream) (with-drawing-options (stream :transformation (make-reflection-transformation* 0 500 500 0)) (test-continuity stream)))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Examples/drawing-benchmark.lisp0000640000175000017500000000624710430173232023031 0ustar pdmpdm;;; -*- Mode: Lisp; -*- ;;; (c) 2006 David Lichteblau (david@lichteblau.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-demo) (define-application-frame drawing-benchmark () () (:panes (canvas :application :min-width 600 :incremental-redisplay nil :display-time nil) (mode (with-radio-box () (radio-box-current-selection (make-pane 'toggle-button :label "rectangle" :id :rectangle)) (make-pane 'toggle-button :label "text" :id :text))) (ink (with-radio-box () (radio-box-current-selection (make-pane 'toggle-button :label "random" :id :random)) (make-pane 'toggle-button :label "red" :id +red+) (make-pane 'toggle-button :label "flipping ink" :id +flipping-ink+)))) (:layouts (default (vertically () (horizontally () (labelling (:label "Mode") mode) (labelling (:label "Ink") ink)) canvas)))) (defmethod run-drawing-benchmark (frame stream) (setf (stream-recording-p stream) nil) (window-clear stream) (let* ((width (rectangle-width (sheet-region stream))) (height (rectangle-height (sheet-region stream))) (mode (gadget-id (gadget-value (find-pane-named frame 'mode)))) (ink (gadget-id (gadget-value (find-pane-named frame 'ink)))) (itups internal-time-units-per-second) (n 0) (start (get-internal-real-time)) (stop (+ start itups))) (do () ((>= (get-internal-real-time) stop)) (incf n) (let ((ink (if (eq ink :random) (clim:make-rgb-color (random 1.0d0) (random 1.0d0) (random 1.0d0)) ink))) (ecase mode (:rectangle (draw-rectangle* stream 10 10 (- width 10) (- height 10) :ink ink :filled t)) (:text (dotimes (x 10) (draw-text* stream "Bla blub hastenichgesehen noch viel mehr Text so fuellen wir eine Zeile." 0 (* x 20) :ink ink)))))) (finish-output stream) (medium-finish-output (sheet-medium stream)) (climi::port-force-output (car climi::*all-ports*)) (setf stop (get-internal-real-time)) (window-clear stream) (setf (stream-recording-p stream) t) (format stream "Score: ~A operations/s~%" (float (/ n (/ (- stop start) itups)))))) (define-drawing-benchmark-command (com-quit-drawing-benchmark :menu "Quit") () (frame-exit *application-frame*)) (define-drawing-benchmark-command (com-run-drawing-benchmark :menu "Run") () (run-drawing-benchmark *application-frame* (frame-standard-output *application-frame*))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Examples/dragndrop.lisp0000644000175000017500000000525510173263175021442 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-DEMO -*- ;;; (c) copyright 2004 by ;;; Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-demo) (define-application-frame dragndrop () () (:pointer-documentation t) (:panes (interactor :interactor) (scratchpad :application :display-time nil :height 600 :scroll-bars nil)) (:layouts (default (vertically () (scrolling (:height 300) scratchpad) interactor)))) (defclass shape () ((x :accessor x :initarg :x) (y :accessor y :initarg :y))) (defclass circle (shape) ((radius :accessor radius :initarg :radius)) (:default-initargs :radius 50)) (define-dragndrop-command (com-add-circle) ((x 'real :prompt "x") (y 'real :prompt "y") (radius 'real :prompt "radius")) (with-output-as-presentation (t (make-instance 'circle :x x :y y :radius radius) 'circle) (draw-circle* *standard-output* x y radius ))) (define-dragndrop-command (com-quit-dragndrop :name "Quit") () (frame-exit *application-frame*)) (define-presentation-to-command-translator translator-draw-circle (blank-area com-add-circle dragndrop :documentation "Add a circle") (object x y) `(,x ,y 50)) (define-dragndrop-command (com-clone-circle) ((original 'circle) (start-x 'real) (start-y 'real)) ;; Track the pointer offset from the center of the original object (let ((x-offset (- (x original) start-x)) (y-offset (- (y original) start-y))) (multiple-value-bind (final-x final-y) (dragging-output (t :finish-on-release t) (draw-circle* *standard-output* (x original) (y original) (radius original) :filled nil )) (com-add-circle (+ final-x x-offset) (+ final-y y-offset) (radius original))))) (define-presentation-to-command-translator translator-clone-circle (circle com-clone-circle dragndrop) (object x y) `(,object ,x ,y)) (defun drag-circles () (run-frame-top-level (make-application-frame 'dragndrop))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Examples/colorslider.lisp0000644000175000017500000001434711345155772022012 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- ;;; (c) copyright 2000 by ;;; Iban Hatchondo (hatchond@emi.u-bordeaux.fr) ;;; Julien Boninfante (boninfan@emi.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) ;; example gadget definition (defclass slider-test-pane (standard-gadget) ()) (defmethod handle-repaint ((pane slider-test-pane) region) (declare (ignore region)) (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* (sheet-region pane)) (display-gadget-background pane (gadget-current-color pane) 0 0 (- x2 x1) (- y2 y1)))) #+nil (defmethod handle-event ((pane slider-test-pane) (event window-repaint-event)) (declare (ignorable event)) (dispatch-repaint pane (sheet-region pane))) (in-package :clim-demo) ;; slider callback and macro (defvar *rgb* '(0 0 0)) ;; Macro defining all the slider-call-back (defmacro define-slider-callback (name position) `(defun ,(make-symbol name) (gadget value) (let ((colored (find-if (lambda (x) (typep x 'climi::slider-test-pane)) (sheet-siblings gadget)))) (setf ,(case position (1 `(car *rgb*)) (2 `(cadr *rgb*)) (3 `(caddr *rgb*))) (/ value 10000) (clim-internals::gadget-current-color colored) (apply #'clim-internals::make-named-color "our-color" (mapcar #'(lambda (color) (coerce color 'single-float)) *rgb*)))))) (defvar callback-red (define-slider-callback "SLIDER-R" 1)) (defvar callback-green (define-slider-callback "SLIDER-G" 2)) (defvar callback-blue (define-slider-callback "SLIDER-B" 3)) ;; test functions (defun colorslider () ; (declare (special frame fm port pane medium graft)) ; (loop for port in climi::*all-ports* ; do (destroy-port port)) ; (setq climi::*all-ports* nil) ; (setq fm (find-frame-manager)) ; (setq frame (make-application-frame 'colorslider ; :frame-manager fm)) ; (setq port (port fm)) ; (setq pane (frame-panes frame)) ; (setq medium (sheet-medium pane)) ; (setq graft (graft frame)) (run-frame-top-level (make-application-frame 'colorslider))) (defmethod slidertest-frame-top-level ((frame application-frame) &key (command-parser 'command-line-command-parser) (command-unparser 'command-line-command-unparser) (partial-command-parser 'command-line-read-remaining-arguments-for-partial-command) (prompt "Command: ")) (declare (ignore command-parser command-unparser partial-command-parser prompt)) (clim-extensions:simple-event-loop)) ;(define-application-frame colorslider () () ; (:panes ; (text :text-field ; :value "Pick a color" ; ;;:height 50 ; ;;:width 100 ; ) ; (slider-r :slider ; :drag-callback callback-red ; :value-changed-callback callback-red ; :min-value 0 ; :max-value 9999 ; :value 0 ; :show-value-p t ; ;;:orientation :horizontal ; :width 120) ; (slider-g :slider ; :drag-callback callback-green ; :value-changed-callback callback-green ; :min-value 0 ; :max-value 9999 ; :value 0 ; :width 120) ; (slider-b :slider ; :drag-callback callback-blue ; :value-changed-callback callback-blue ; :min-value 0 ; :max-value 9999 ; :value 0 ; :width 120) ; (colored :slider-test ; :normal +black+ ; :width 200 :height 90)) ; (:layouts ; (default (vertically () ; text ; (horizontally () ; slider-r ; slider-g ; slider-b ; colored)))) ; (:top-level (slidertest-frame-top-level . nil))) (define-application-frame colorslider () () (:panes (text :text-field :value "Pick a color" ;;:height 50 ;;:width 100 ) (slider-r :slider :drag-callback callback-red :value-changed-callback callback-red :min-value 0 :max-value 9999 :value 0 :show-value-p t :orientation :horizontal :width 120) (slider-g :slider :drag-callback callback-green :value-changed-callback callback-green :min-value 0 :max-value 9999 :orientation :horizontal :value 0 :width 120) (slider-b :slider :drag-callback callback-blue :value-changed-callback callback-blue :min-value 0 :max-value 9999 :orientation :horizontal :value 0 :width 120) (colored :slider-test :normal +black+ :width 200 :height 90)) (:layouts #+nil (default (vertically () text (horizontally () (vertically (:equalize-width t) (horizontally () (make-pane 'push-button :label "Red:") slider-r) (horizontally () (make-pane 'push-button :label "Green:") slider-g) (horizontally () (make-pane 'push-button :label "Blue:") slider-b)) colored))) (default (vertically () text slider-r slider-g slider-b colored))) (:top-level (slidertest-frame-top-level . nil))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Examples/presentation-test.lisp0000644000175000017500000000344407462461646023162 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-DEMO -*- ;;; (c) copyright 2001 by ;;; Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-demo) (define-application-frame summation () ((total :accessor summation-total :initarg :total :initform 0)) (:panes (tester :interactor)) (:layouts (default (vertically () tester))) (:top-level (summation-top-level))) (defun summation-top-level (frame &key command-parser command-unparser partial-command-parser prompt) (let ((*standard-output* (frame-standard-output frame)) (*standard-input* (frame-standard-input frame)) (*print-pretty* nil)) (setf (cursor-visibility (stream-text-cursor *standard-input*)) t) (present "Hallo" 'string) (loop (climi::catch-abort-gestures ("Return to ~A command level" (frame-pretty-name frame)) (present (summation-total frame) 'real) (fresh-line) (let ((new-val (accept 'real :default (summation-total frame) :default-type 'real))) (fresh-line) (incf (summation-total frame) new-val)))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Examples/postscript-test.lisp0000644000175000017500000001710207636702774022660 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-DEMO -*- ;;; (c) copyright 2001 by ;;; Arnaud Rouanet (rouanet@emi.u-bordeaux.fr) ;;; Lionel Salabartan (salabart@emi.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-demo) (defparameter *postscript-test-file* #p"ps-test.ps") (defun make-random-color () (make-rgb-color (/ (random 255) 255) (/ (random 255) 255) (/ (random 255) 255))) (defun draw-rosette (stream x y radius n &rest drawing-options) (loop with alpha = (/ (* 2 pi) n) and radius = (/ radius 2) for i below n do (apply #'draw-circle* stream (+ (* radius (cos (* alpha i))) x) (+ (* radius (sin (* alpha i))) y) radius :filled nil drawing-options))) (defun postscript-test () (format t ";; Creating ~S.~%" *postscript-test-file*) (with-open-file (file-stream *postscript-test-file* :direction :output) (with-output-to-postscript-stream (stream file-stream :header-comments '(:title "PostScript Medium Test Output")) (loop repeat 200 do (draw-line* stream (random 600) (random 900) (random 600) (random 900) :ink (make-random-color))) (new-page stream) (loop repeat 1000 do (draw-point* stream (random 600) (random 900) :ink (make-random-color) :line-thickness (random 50))) (new-page stream) (formatting-table (stream :x-spacing 50 :y-spacing 20) (formatting-row (stream) (formatting-cell (stream)) (formatting-cell (stream :align-x :center :align-y :bottom :min-height 100) (draw-text* stream "(Test Page)" 170 30 :text-style (make-text-style :fix :bold :huge)))) (loop for i from 1 to 15 do (formatting-row (stream) (formatting-cell (stream :align-x :right :align-y :center :min-width 100) (draw-point* stream 0 0 :line-thickness i)) (formatting-cell (stream :align-x :center :align-y :center) (draw-line* stream 0 0 200 0 :line-thickness i :line-dashes (list (* i 2) (round i 2)))) (formatting-cell (stream :align-x :right :align-y :center) (draw-text* stream (format nil "~D" i) 0 0 :text-style (make-text-style :sans-serif :bold :huge)))))) (new-page stream) (with-translation (stream 540 75) (with-scaling (stream 3) (with-rotation (stream (/ pi 2)) (clim:draw-rectangle* stream 10 10 200 150 :filled nil :line-thickness 2) (clim:draw-line* stream 200 10 10 150) (clim:draw-point* stream 180 25) (clim:draw-circle* stream 100 75 40 :filled nil) (clim:draw-ellipse* stream 160 110 30 0 0 10 :filled nil) (clim:draw-ellipse* stream 160 110 10 0 0 30) (clim:draw-polygon* stream '(20 20 50 80 40 20) :filled nil) (clim:draw-polygon* stream '(30 90 40 110 20 110))))) (new-page stream) (draw-rosette stream 300 300 200 18 :ink +steel-blue+ :line-thickness 2) (new-page stream) (with-text-style (stream '(:serif nil :huge)) (draw-text* stream "Text alignment test" 170 20 :text-family :sans-serif :text-face :bold) (with-scaling (stream 50) (loop for align-y in '(:bottom :center :top) and y from 1 do (loop for align-x in '(:right :center :left) and x from 1 do (draw-text* stream (format nil "~A~A" (elt (symbol-name align-x) 0) (elt (symbol-name align-y) 0)) x y :align-x align-x :align-y align-y) (draw-point* stream x y :ink +red+ :line-thickness 3 :line-unit :point)))) (draw-text* stream "Top: pQ" 50 200 :align-y :top) (draw-text* stream "Bottom: pQ" 170 200 :align-y :bottom) (draw-text* stream "Center: pQ" 290 200 :align-y :center) (draw-text* stream "Baseline: pQ" 410 200 :align-y :baseline) (draw-line* stream 50 200 535 200 :ink +red+)) (new-page stream) (formatting-table (stream) (flet ((draw (angle line-joint-shape) (let ((record (with-output-to-output-record (stream) (draw-polygon* stream (list 20 0 100 0 50 (* 50 (tan angle))) :closed nil :filled nil :line-thickness 40 :line-joint-shape line-joint-shape :line-cap-shape :round) (draw-polygon* stream (list 20 0 100 0 50 (* 50 (tan angle))) :closed nil :filled nil :line-thickness 0.01 :ink +green+)))) (multiple-value-call #'draw-rectangle* stream (bounding-rectangle* record) :filled nil :ink +red+ :line-thickness 0.01) (stream-add-output-record stream record) (replay record stream)))) (loop with dag = 2 with da = (* pi (/ dag 180)) for i from -10 to 10 for a = (* i da) unless (= i 0) do (formatting-row (stream) (formatting-cell (stream) (print (* i dag) stream)) (formatting-cell (stream) (draw a :miter)) (formatting-cell (stream) (draw a :bevel)) (formatting-cell (stream) (draw a :round))))))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Examples/menutest.lisp0000644000175000017500000000417310177775467021344 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: MENUTEST; Base: 10; Lowercase: Yes -*- ;;; (c) copyright 2000 by ;;; Robert Strandh (strandh@labri.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (defpackage :MENUTEST (:USE :CLIM :CLIM-EXTENSIONS :CLIM-LISP)) (in-package :menutest) (defun menutest () (let ((frame (make-application-frame 'menutest))) (run-frame-top-level frame) frame)) (define-application-frame menutest () () (:menu-bar menubar-command-table) (:panes (screen :application :display-time nil :text-style (make-text-style :sans-serif :roman :normal))) (:layouts (defaults (vertically () screen))) #+nil (:top-level (menutest-frame-top-level))) (define-menutest-command com-file () (format *standard-output* "You pressed the File button.~%") (finish-output *standard-output*)) (define-menutest-command com-hello () (format *standard-output* "You pressed the Hello button.~%") (finish-output *standard-output*)) (define-menutest-command com-hi () (format *standard-output* "You pressed the Hi button.~%") (finish-output *standard-output*)) (make-command-table 'buffer-command-table :errorp nil :menu '(("Hello there" :command com-hello) ("Hi there" :command com-hi))) (make-command-table 'menubar-command-table :errorp nil :menu '(("Buffer" :menu buffer-command-table) ("File" :command com-file))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Examples/gadget-test-kr.lisp0000644000175000017500000002233311345155772022305 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- ;;; (c) copyright 2000 by ;;; Iban Hatchondo (hatchond@emi.u-bordeaux.fr) ;;; Julien Boninfante (boninfan@emi.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Copied from colorslider (in-package :clim-internals) ;; example gadget definition (defclass gadget-test-pane (standard-gadget) ()) (in-package :clim-demo) (defun gadget-test () (loop for port in climi::*all-ports* do (destroy-port port)) (setq climi::*all-ports* nil) (setq frame (make-application-frame 'gadget-test :frame-manager (make-instance 'clim-internals::pixie/clx-look :port (find-port)))) ; (setq frame (make-application-frame 'gadget-test)) (setq fm (frame-manager frame)) (setq port (port fm)) (setq pane (first (frame-panes frame))) (setq medium (sheet-medium pane)) (setq graft (graft frame)) (setq vbox (climi::frame-pane frame)) (run-frame-top-level frame)) (defun run-pixie-test (name) (loop for port in climi::*all-ports* do (destroy-port port)) (setq climi::*all-ports* nil) (when name (run-frame-top-level (make-application-frame name :frame-manager (make-instance 'clim-internals:pixie/clx-look :port (find-port)))))) (defmethod gadget-test-frame-top-level ((frame application-frame) &key (command-parser 'command-line-command-parser) (command-unparser 'command-line-command-unparser) (partial-command-parser 'command-line-read-remaining-arguments-for-partial-command) (prompt "Command: ")) (declare (ignore command-parser command-unparser partial-command-parser prompt)) (catch 'exit (clim-extensions:simple-event-loop)) (frame-exit frame)) (let ((korean (make-text-style :sans-serif nil 12 :korean))) (make-command-table 'lisp-menu :errorp nil :menu `(("°è±Þ" :menu lisp-sub-menu :text-style ,korean) ("¸®½À" :command test :text-style ,korean) ("Lisp" :command test))) (make-command-table 'lisp-sub-menu :errorp nil :menu `(("Does" :command test) ("This" :command test) ("Work?" :command test))) (make-command-table 'edit-menu :errorp nil :menu `(("Edit" :command test) ("Edit" :command test) ("Edit" :command test))) (make-command-table `view-menu :errorp nil :menu '(("View" :command test) ("View" :command test) ("View" :command test))) (make-command-table `search-menu :errorp nil :menu '(("Search" :command test) ("Search" :command test) ("Search" :command test)))) (define-command test () (format *error-output* "That was just a test~%") (finish-output *error-output*)) (macrolet ((make-pane-constructor (class-name) `(defmacro ,class-name (&rest options) `(make-pane ',',class-name ,@options)))) (make-pane-constructor text-field) (make-pane-constructor text-edit) (make-pane-constructor slider) (make-pane-constructor push-button) (make-pane-constructor toggle-button)) (define-application-frame gadget-test () () (:menu-bar (("Lisp" :menu lisp-menu) ("Edit" :menu edit-menu) ("View" :menu view-menu) ("Search" :menu search-menu))) (:panes ; (raised (raising (:border-width 3 :background +Gray83+) ; (make-pane 'check-box :choices '("First" "Second" "Third")))) (tf1 :push-button :text-style (make-text-style :fix :roman 24 :korean) :label "º»¹®ÀÌ :fix ÀÌ¿ä") (tf2 :push-button :text-style (make-text-style :serif :roman 24 :korean) :label "ÜâÙþÀÌ :serif ÀÌ¿ä") (tf3 :push-button :text-style (make-text-style :serif :italic 24 :korean) :label "ÀÌÅŸ¯ italic ÀÌÅŸ¯") (tf4 :push-button :text-style (make-text-style :sans-serif '(:bold :italic) 24 :korean) :label "ȹÀÌ ±½Àº È°ÀÚ°ú ÀÌÅŸ¯ bold-italic") ; (text-edit :text-editor ; :value "Text Editor") (slider-h :slider :min-value 0 :max-value 100 :value 0 :show-value-p t :orientation :horizontal :current-color +black+) (slider-v :slider :min-value 0 :max-value 100 :orientation :vertical :current-color +black+ :value 0) (slider-v1 :slider :min-value 0 :max-value 100 :orientation :vertical :current-color +black+ :value 0) (slider-v2 :slider :min-value 0 :max-value 100 :orientation :vertical :current-color +black+ :value 0) (slider-v3 :slider :min-value 0 :max-value 100 :orientation :vertical :current-color +black+ :value 0) (slider-v4 :slider :min-value 0 :max-value 100 :orientation :vertical :current-color +black+ :value 0) (push-btn (lowering (:border-width 3 :background +Gray83+) (horizontally () (push-button :label "Push Me") (push-button :label "No, Push Me") (push-button :label "Me!")))) (table (lowering (:border-width 3 :background +Gray83+) (tabling (:height 50) (list (push-button :label "A") (push-button :label "B")) (list (push-button :label "C") (push-button :label "D")) (list (push-button :label "E") (push-button :label "F"))))) (toggle-btn :toggle-button :label "Toggle" :value t :normal +red+ :highlighted +red+ :pushed-and-highlighted +red+) (scroll (raising (:border-width 1 :background +Gray83+) (scrolling (:background +Gray83+) (horizontally () (vertically () (push-button :label "This is a button") (push-button :label "That is a button") (push-button :label "This is a button too")) (with-radio-box (:orientation :vertical) (clim:radio-box-current-selection "First") "Second" "Third" "Red" "Blue" "Orange" "Elephant" "Dog" "Cat") (with-radio-box (:orientation :vertical :type :some-of) (clim:radio-box-current-selection "Fourth") "Fifth" "Sixth") (with-radio-box (:orientation :vertical) (clim:radio-box-current-selection "Seventh") "Eighth" "Ninth") (with-radio-box (:orientation :vertical :type :some-of) (clim:radio-box-current-selection "Tenth") "Eleventh" "Twelth"))))) (radio-box (with-radio-box (:orientation :horizontal) (clim:radio-box-current-selection "One") "Two" "Three")) (check-box (with-radio-box (:type :some-of :orientation :horizontal) (clim:radio-box-current-selection "First") "Second" "Third"))) (:layouts (default (raising (:border-width 5 :background +Gray83+) (vertically () tf1 tf2 tf3 tf4 slider-h (horizontally () (vertically () slider-v slider-v2) slider-v3 slider-v4) push-btn table toggle-btn scroll radio-box check-box )))) (:top-level (gadget-test-frame-top-level . nil))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/Examples/image-viewer.lisp0000644000175000017500000001134211001100451022007 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-DEMO -*- ;;; (c) copyright 2008 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; A simple program for displaying images of formats known to McCLIM. (in-package :clim-demo) (defclass image-viewer-gadget (value-gadget) () (:documentation "An abstract gadget for displaying images. The value of the gadget is the image being displayed.") (:default-initargs :value nil)) (defmethod (setf gadget-value) :after (new-value (gadget image-viewer-gadget) &key &allow-other-keys) (handle-repaint gadget (or (pane-viewport-region gadget) (sheet-region gadget)))) (defclass image-viewer-pane (image-viewer-gadget basic-gadget) () (:documentation "A concrete gadget for displaying images. The value of the gadget is the image being displayed.")) (defmethod handle-repaint ((pane image-viewer-pane) region) (declare (ignore region)) ;; Clear the old image. (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region pane) (draw-rectangle* (sheet-medium pane) x1 y1 x2 y2 :ink +background-ink+)) ;; Draw the new one, if there is one. (when (gadget-value pane) (let ((image-height (pattern-height (gadget-value pane))) (image-width (pattern-width (gadget-value pane)))) ;; Try to ensure there is room for the new image. (change-space-requirements pane :height image-height :width image-width) ;; Draw it in the center. (handler-case (draw-pattern* pane (gadget-value pane) (/ (- (bounding-rectangle-width pane) image-width) 2) (/ (- (bounding-rectangle-height pane) image-height) 2)) (error () (with-text-style (pane (make-text-style nil :italic nil)) (draw-text* pane (format nil "Error while drawing image") 0 0 :align-y :top))))))) (define-application-frame image-viewer () ((%image-pathname :accessor image-pathname :initarg :image-pathname :initform nil)) (:menu-bar t) (:panes (viewer (make-pane 'image-viewer-pane)) (interactor :interactor :text-style (make-text-style :sans-serif nil nil) :min-height 100)) (:layouts (default (vertically () (4/5 (labelling (:label "Image") viewer)) (1/5 interactor)))) (:top-level ((lambda (frame) (default-frame-top-level frame))))) (define-image-viewer-command (com-display-image :name t :menu t) ((image-pathname 'pathname :default (user-homedir-pathname) :insert-default t)) (if (probe-file image-pathname) (let* ((type (funcall (case (readtable-case *readtable*) (:upcase #'string-upcase) (:downcase #'string-downcase) (t #'identity)) (pathname-type image-pathname))) (format (find-symbol type (find-package :keyword))) (viewer (find-pane-named *application-frame* 'viewer))) (handler-case (progn (setf (gadget-value viewer) (make-pattern-from-bitmap-file image-pathname :format format) (image-pathname *application-frame*) image-pathname) (format t "~A image loaded succesfully" type)) (unsupported-bitmap-format () (format t "Image format ~A not recognized" type)))) (format t "No such file: ~A" image-pathname))) (define-image-viewer-command (com-blank-image :name t :menu t) () (setf (gadget-value (find-pane-named *application-frame* 'viewer)) nil)) (defun image-viewer (&key (new-process t)) (flet ((run () (let ((frame (make-application-frame 'image-viewer))) (run-frame-top-level frame)))) (if new-process (clim-sys:make-process #'run :name "Image viewer") (run)))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/symlink-asd-files.sh0000750000175000017500000000121510553705667020701 0ustar pdmpdm#!/bin/sh -e # (Re-)Installs the top-level .asd files into an # asdf:*central-registry* directory. Prompts before overwriting # anything. CENTRAL_REG="$1" if [ -z "$CENTRAL_REG" ] ; then echo "USAGE: $0 central-registry-dir" 2>&1 echo " central-registry-dir is a directory where asdf looks for .asd files." 2>&1 echo " e.g. on SBCL, this could be ~/.sbcl/systems/" 2>&1 exit 1 fi cd "`dirname $0`" for i in *.asd ; do if [ -e "$CENTRAL_REG"/"$i" ]; then echo -en "Warning: overwriting $CENTRAL_REG/$i with link to \n`pwd`/$i (press RET to continue)" 2>&1 read fi ln -sf "`pwd`/$i" "$CENTRAL_REG"/"$i" donecl-mcclim-0.9.6.dfsg.cvs20100315.orig/commands.lisp0000644000175000017500000016632211345155771017514 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com) ;;; (c) copyright 2000 by Robert Strandh (strandh@labri.u-bordeaux.fr) ;;; (c) copyright 2002 by Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Command tables (defgeneric command-table-name (command-table)) (defgeneric command-table-inherit-from (command-table)) ;;; Container for info about a command (defclass command-item () ((command-name :initarg :command-name :reader command-item-name :initarg nil) (command-line-name :initarg :command-line-name :reader command-line-name))) (defmethod print-object ((obj command-item) stream) (print-unreadable-object (obj stream :identity t :type t) (cond ((slot-boundp obj 'command-line-name) (format stream "~A" (command-line-name obj))) ((slot-boundp obj 'command-name) (format stream "~S" (command-item-name obj))) (t nil)))) ;;; According to the specification, command menu items are stored as ;;; lists. This way seems better, and I hope nothing will break. (defclass %menu-item (command-item) ((menu-name :reader command-menu-item-name :initarg :menu-name) (type :initarg :type :reader command-menu-item-type) (value :initarg :value :reader command-menu-item-value) (documentation :initarg :documentation) (text-style :initarg :text-style :initform nil) (keystroke :initarg :keystroke))) (defmethod print-object ((item %menu-item) stream) (print-unreadable-object (item stream :identity t :type t) (when (slot-boundp item 'menu-name) (format stream "~S" (command-menu-item-name item))) (when (slot-boundp item 'keystroke) (format stream "~:[~; ~]keystroke ~A" (slot-boundp item 'menu-name) (slot-value item 'keystroke))))) (defun command-menu-item-options (menu-item) (with-slots (documentation text-style) menu-item (list ':documentation documentation ':text-style text-style))) (defclass standard-command-table (command-table) ((name :initarg :name :reader command-table-name) (inherit-from :initarg :inherit-from :initform '() :reader command-table-inherit-from :type list) (commands :accessor commands :initarg :commands :initform (make-hash-table :test #'eq)) (command-line-names :accessor command-line-names :initform (make-hash-table :test #'equal)) (presentation-translators :reader presentation-translators :initform (make-instance 'translator-table)) (inherit-menu :reader inherit-menu :initform nil ;; We interpret :menu to mean "inherit menu items ;; without keystrokes" and :keystrokes to mean ;; "inherit menu items with keystrokes". :type (member nil t :menu :keystrokes) :initarg :inherit-menu) (menu :initarg :menu :initform '()) (keystroke-accelerators :initform nil) (keystroke-items :initform nil))) (defmethod print-object ((table standard-command-table) stream) (print-unreadable-object (table stream :identity t :type t) (format stream "~S" (command-table-name table)))) ;;; We store command-table designators, but this function should ;;; return command table objects. (defmethod command-table-inherit-from :around ((command-table standard-command-table)) (mapcar #'find-command-table (call-next-method))) ;;; Franz user manual says that this slot is setf-able (defgeneric (setf command-table-inherit-from) (inherit-from table)) (defmethod (setf command-table-inherit-from) (inherit (table standard-command-table)) (invalidate-translator-caches) (setf (slot-value table 'inherit-from) inherit)) (defun inherit-keystrokes (command-table) "Return true if `command-table' (which must be a command table designator) inherits keystrokes." (let ((inherit-menu (inherit-menu (find-command-table command-table)))) (or (eq inherit-menu t) (eq inherit-menu :keystrokes)))) (defun inherit-menu-items (command-table) "Return true if `command-table' (which must be a command table designator) inherits menu items." (let ((inherit-menu (inherit-menu (find-command-table command-table)))) (or (inherit-keystrokes command-table) (eq inherit-menu :menu)))) (defparameter *command-tables* (make-hash-table :test #'eq)) (define-condition command-table-error (simple-error) ((command-table-name :reader error-command-table-name :initform nil :initarg :command-table-name)) (:default-initargs :format-control "" :format-arguments nil)) (defmethod print-object ((object command-table-error) stream) (print-unreadable-object (object stream :type t :identity t) (when (error-command-table-name object) (princ (error-command-table-name object) stream)))) (defun command-table-designator-as-name (designator) "Return the name of `designator' if it is a command table, `designator' otherwise." (if (typep designator 'standard-command-table) (command-table-name designator) designator)) (define-condition command-table-not-found (command-table-error) ()) (define-condition command-table-already-exists (command-table-error) ()) (define-condition command-not-present (command-table-error) ()) (define-condition command-not-accessible (command-table-error) ()) (define-condition command-already-present (command-table-error) ()) (defun find-command-table (name &key (errorp t)) (cond ((command-table-p name) name) ((gethash name *command-tables*)) (errorp (error 'command-table-not-found :command-table-name name)) (t nil))) (define-presentation-method present (object (type command-table) stream (view textual-view) &key acceptably for-context-type) (declare (ignore for-context-type)) (let ((name (command-table-name object))) (if acceptably (prin1 name stream) (princ name stream)))) (define-presentation-method accept ((type command-table) stream (view textual-view) &key) (multiple-value-bind (table success string) (completing-from-suggestions (stream) (loop for name being the hash-key of *command-tables* using (hash-value table) do (suggest (symbol-name name) table))) (if success table (simple-parse-error "~A is not the name of a command table" string)))) (defun menu-items-from-list (menu) (mapcar #'(lambda (item) (destructuring-bind (name type value &rest args) item (apply #'make-menu-item name type value args))) menu)) (setf (gethash 'global-command-table *command-tables*) (make-instance 'standard-command-table :name 'global-command-table :inherit-from nil :menu nil)) ; adjusted to allow anonymous command-tables for menu-bars (defun make-command-table (name &key inherit-from menu inherit-menu (errorp t)) (unless inherit-from (setq inherit-from '(global-command-table))) (if (and name errorp (gethash name *command-tables*)) (error 'command-table-already-exists :command-table-name name) (let ((result (make-instance 'standard-command-table :name name :inherit-from inherit-from :inherit-menu inherit-menu :menu (menu-items-from-list menu)))) (when name (setf (gethash name *command-tables*) result)) result))) (make-command-table 'user-command-table) (defmacro define-command-table (name &key inherit-from menu inherit-menu) `(let ((old-table (gethash ',name *command-tables* nil)) (inherit-from-arg (or ',inherit-from '(global-command-table)))) (if old-table (with-slots (inherit-from menu) old-table (setq inherit-from inherit-from-arg menu (menu-items-from-list ',menu)) old-table) (make-command-table ',name :inherit-from inherit-from-arg :inherit-menu ,inherit-menu :menu ',menu :errorp nil)))) (defun remove-command-from-command-table (command-name command-table &key (errorp t)) (let* ((table (find-command-table command-table)) (item (gethash command-name (commands table)))) (if (null item) (when errorp (error 'command-not-present :command-table-name (command-table-name command-table))) (progn (when (typep item '%menu-item) (remove-menu-item-from-command-table table (command-menu-item-name item) :errorp nil)) (when (command-item-name item) (remhash (command-item-name item) (command-line-names table))) (remhash command-name (commands table)))))) (defun add-command-to-command-table (command-name command-table &key name menu keystroke (errorp t) (menu-command (and menu `(,command-name)))) (let ((table (find-command-table command-table)) (name (cond ((stringp name) name) (name (command-name-from-symbol command-name)) (t nil)))) (multiple-value-bind (menu-name menu-options) (cond ((null menu) nil) ((stringp menu) menu) ((eq menu t) (if (stringp name) name (command-name-from-symbol command-name))) ((consp menu) (values (car menu) (cdr menu)))) (when keystroke (add-keystroke-to-command-table table keystroke :command command-name :errorp nil)) (let* ((item (if menu (apply #'make-menu-item menu-name :command menu-command :command-name command-name :command-line-name name `(,@(and keystroke `(:keystroke ,keystroke)) ,@menu-options)) (make-instance 'command-item :command-name command-name :command-line-name name))) (after (getf menu-options :after))) (when (and errorp (gethash command-name (commands table))) (error 'command-already-present :command-table-name command-table)) (remove-command-from-command-table command-name table :errorp nil) (setf (gethash command-name (commands table)) item) (when name (setf (gethash name (command-line-names table)) command-name)) (when menu (%add-menu-item table item after)))))) (defun apply-with-command-table-inheritance (fun command-table) (funcall fun command-table) (mapc #'(lambda (inherited-command-table) (apply-with-command-table-inheritance fun (find-command-table inherited-command-table))) (command-table-inherit-from command-table))) ;;; do-command-table-inheritance has been shipped off to utils.lisp. (defun map-over-command-table-commands (function command-table &key (inherited t)) (let ((command-table (find-command-table command-table))) (flet ((map-func (table) (maphash #'(lambda (key val) (declare (ignore val)) (funcall function key)) (slot-value table 'commands)))) (if inherited (apply-with-command-table-inheritance #'map-func command-table) (map-func command-table))))) (defun map-over-command-table-names (function command-table &key (inherited t)) (let ((command-table (find-command-table command-table))) (flet ((map-func (table) (maphash function (slot-value table 'command-line-names)))) (if inherited (apply-with-command-table-inheritance #'map-func command-table) (map-func command-table))))) (defun command-present-in-command-table-p (command-name command-table) (let ((table (find-command-table command-table))) (if (gethash command-name (slot-value table 'commands)) table nil))) (defun command-accessible-in-command-table-p (command-name command-table) (or (command-present-in-command-table-p command-name command-table) (some #'(lambda (table) (command-accessible-in-command-table-p command-name (find-command-table table))) (command-table-inherit-from (find-command-table command-table))))) (defun find-command-from-command-line-name (name command-table &key (errorp t)) (apply-with-command-table-inheritance #'(lambda (table) (let ((value (gethash name (command-line-names table)))) (when value (return-from find-command-from-command-line-name (values value table))))) (find-command-table command-table)) (if errorp (error 'command-not-accessible :command-table-name command-table))) (defun command-line-name-for-command (command-name command-table &key (errorp t)) (do-command-table-inheritance (table command-table) (let* ((command-item (gethash command-name (slot-value table 'commands))) (command-line-name (and command-item (command-line-name command-item)))) (when (stringp command-line-name) (return-from command-line-name-for-command command-line-name)))) (cond ((eq errorp :create) (command-name-from-symbol command-name)) (errorp (error 'command-not-accessible :command-table-name (command-table-designator-as-name command-table))) (t nil))) (defun find-menu-item (menu-name command-table &key (errorp t)) (let* ((table (find-command-table command-table)) (mem (member menu-name (slot-value table 'menu) :key #'command-menu-item-name :test #'string-equal))) (if mem (values (car mem) command-table) (or (find-if #'(lambda (table) (find-menu-item menu-name table :errorp nil)) (command-table-inherit-from table)) (when errorp (error 'command-not-accessible :command-table-name (command-table-designator-as-name table))))))) (defun remove-menu-item-from-command-table (command-table string &key (errorp t)) (let ((table (find-command-table command-table)) (item (find-menu-item string command-table :errorp nil))) (with-slots (menu) table (if (and errorp (not item)) (error 'command-not-present :command-table-name (command-table-designator-as-name table)) (setf menu (delete string menu :key #'command-menu-item-name :test #'string-equal)))))) (defun make-menu-item (name type value &key (documentation nil documentationp) (keystroke nil keystrokep) (text-style nil text-style-p) (command-name nil command-name-p) (command-line-name nil command-line-name-p) &allow-other-keys) ;; v-- this may be wrong, we do this to allow ;; text-style to contain make-text-style calls ;; so we use a very limited evaluator - FIXME (when (and (consp text-style) (eq (first text-style) 'make-text-style)) (setq text-style (apply #'make-text-style (rest text-style)))) (apply #'make-instance '%menu-item :menu-name name :type type :value value `(,@(and documentationp `(:documentation ,documentation)) ,@(and keystrokep `(:keystroke ,keystroke)) ,@(and text-style-p `(:text-style ,text-style)) ,@(and command-name-p `(:command-name ,command-name)) ,@(and command-line-name-p `(:command-line-name ,command-line-name))))) (defun %add-menu-item (command-table item after) (with-slots (menu) command-table (when (null menu) (setf after :start)) (case after (:start (push item menu)) ((:end nil) (setf menu (nconc menu (list item)))) (:sort (setf menu (sort (cons item menu) #'string-lessp :key #'command-menu-item-name))) (t (push item (cdr (member after menu :key #'command-menu-item-name :test #'string-equal)))))) (when (and (slot-boundp item 'keystroke) (slot-value item 'keystroke)) (%add-keystroke-item command-table (slot-value item 'keystroke) item nil))) (defun add-menu-item-to-command-table (command-table string type value &rest args &key documentation (after :end) keystroke text-style (errorp t)) (declare (ignore documentation keystroke text-style)) (let* ((table (find-command-table command-table)) (old-item (find-menu-item string command-table :errorp nil))) (cond ((and errorp old-item) (error 'command-already-present :command-table-name (command-table-designator-as-name table))) (old-item (remove-menu-item-from-command-table command-table string)) (t nil)) (%add-menu-item table (apply #'make-menu-item string type value args) after))) (defun map-over-command-table-menu-items (function command-table) "Applies function to all of the items in `command-table's menu. `Command-table' must be a command table or the name of a command table. `Function' must be a function of three arguments, the menu name, the keystroke accelerator gesture (which will be NIL if there is none), and the command menu item; it has dynamic extent. The command menu items are mapped over in the order specified by `add-menu-item-to-command-table'. `Command-table' is a command table designator. Any inherited menu items will be mapped over after `command-table's own menu items. `Map-over-command-table-menu-items' does not descend into sub-menus. If the programmer requires this behavior, he should examine the type of the command menu item to see if it is `:menu'." (let ((table-object (find-command-table command-table))) (flet ((map-table-entries (table) (mapc #'(lambda (item) (with-slots (menu-name keystroke) item (funcall function menu-name (and (slot-boundp item 'keystroke) keystroke) item))) (slot-value table 'menu)))) (map-table-entries table-object) (when (inherit-menu-items table-object) (dolist (table (command-table-inherit-from table-object)) (map-over-command-table-menu-items function table)))) (values))) (defun map-over-command-table-translators (function command-table &key (inherited t)) (flet ((map-func (table) (maphash #'(lambda (k v) (declare (ignore k)) (funcall function v)) (slot-value (presentation-translators table) 'translators)))) (let ((command-table (find-command-table command-table))) (if inherited (apply-with-command-table-inheritance #'map-func command-table) (map-func command-table))))) ;(defun add-presentation-translator-to-command-table ; (command-table translator-name &key (errorp t))) ; - fixme; spec says this fun is given a translator name, but that ; find-presentation-translator needs a translator name and a command ; table designator (defun add-actual-presentation-translator-to-command-table (command-table translator &key (errorp t)) (let ((translators (presentation-translators (find-command-table command-table)))) (when (and errorp (second (multiple-value-list (gethash (name translator) (slot-value translators 'translators))))) (error 'command-already-present :command-table-name command-table)) (add-translator translators translator))) ;; At this point we should still see the gesture name as supplied by the ;; programmer in 'gesture' (defun %add-keystroke-item (command-table gesture item errorp) (with-slots (keystroke-accelerators keystroke-items) command-table (let* ((gesture (if (and (symbolp gesture) ; symbolic gesture name? (gethash gesture *gesture-names*)) gesture (multiple-value-list (realize-gesture-spec :keyboard gesture)))) (in-table (position gesture keystroke-accelerators :test #'equal))) (when (and in-table errorp) (error 'command-already-present :command-table-name (command-table-designator-as-name command-table))) (if in-table (setf (nth in-table keystroke-items) item) (progn (push gesture keystroke-accelerators) (push item keystroke-items)))))) ;; FIXME: According to the spec, we need to remove the menu item if already ;; present. Also, you could argue we don't signal 'command-already-present ;; in quite the right circumstance (see above). (defun add-keystroke-to-command-table (command-table gesture type value &key documentation (errorp t)) (let ((command-table (find-command-table command-table))) (%add-keystroke-item command-table gesture (make-instance '%menu-item :type type :value value :keystroke gesture :documentation documentation) errorp))) (defun remove-keystroke-from-command-table (command-table gesture &key (errorp t)) (let ((command-table (find-command-table command-table))) (with-slots (keystroke-accelerators keystroke-items) command-table (let ((in-table (position gesture keystroke-accelerators :test #'equal))) (if in-table (if (zerop in-table) (setq keystroke-accelerators (cdr keystroke-accelerators) keystroke-items (cdr keystroke-items)) (let ((accel-tail (nthcdr (1- in-table) keystroke-accelerators)) (items-tail (nthcdr (1- in-table) keystroke-items))) (setf (cdr accel-tail) (cddr accel-tail)) (setf (cdr items-tail) (cddr items-tail)))) (when errorp (error 'command-not-present :command-table-name (command-table-designator-as-name command-table))))))) nil) (defun map-over-command-table-keystrokes (function command-table) (let ((command-table (find-command-table command-table))) (with-slots (keystroke-accelerators keystroke-items) command-table (loop for gesture in keystroke-accelerators for item in keystroke-items do (funcall function (and (slot-boundp item 'menu-name) (command-menu-item-name item)) gesture item))))) (defun find-keystroke-item (gesture command-table &key (test #'event-matches-gesture-name-p) (errorp t)) (let ((command-table (find-command-table command-table))) (loop for keystroke in (slot-value command-table 'keystroke-accelerators) for item in (slot-value command-table 'keystroke-items) if (funcall test gesture keystroke) do (return-from find-keystroke-item (values item command-table))) (if errorp (error 'command-not-present :command-table-name (command-table-designator-as-name command-table)) nil))) (defun lookup-keystroke-item (gesture command-table &key (test #'event-matches-gesture-name-p)) (let ((command-table (find-command-table command-table))) (multiple-value-bind (item table) (find-keystroke-item gesture command-table :test test :errorp nil) (when table (return-from lookup-keystroke-item (values item table))) (map-over-command-table-menu-items #'(lambda (name keystroke item) (declare (ignore name keystroke)) (when (eq (command-menu-item-type item) :menu) (multiple-value-bind (sub-item sub-command-table) (lookup-keystroke-item gesture (command-menu-item-value item) :test test) (when sub-command-table (return-from lookup-keystroke-item (values sub-item sub-command-table)))))) command-table)))) (defun partial-command-from-name (command-name command-table) (let ((parser (gethash command-name *command-parser-table*))) (if (null parser) (error 'command-not-present :command-table-name (command-table-designator-as-name command-table)) (cons command-name (mapcar #'(lambda (foo) (declare (ignore foo)) *unsupplied-argument-marker*) (required-args parser)))))) ;;; XXX The spec says that GESTURE may be a gesture name, but also that the ;;; default test is event-matches-gesture-name-p. Uh... (defun lookup-keystroke-command-item (gesture command-table &key test (numeric-arg 1)) (let ((item (lookup-keystroke-item gesture command-table :test (or test #'(lambda (gesture gesture-name) (or (equal gesture gesture-name) (event-matches-gesture-name-p gesture gesture-name))))))) (if item (let* ((value (command-menu-item-value item)) (command (case (command-menu-item-type item) (:command value) (:function (funcall value gesture numeric-arg)) ;; XXX What about the :menu case? (otherwise nil)))) (if command ; Return a literal command, or create a partial command from a command-name (substitute-numeric-argument-marker (if (symbolp command) (partial-command-from-name command command-table) command) numeric-arg) gesture)) gesture))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Commands (defclass command-parsers () ((parser :accessor parser :initarg :parser) (partial-parser :accessor partial-parser :initarg :partial-parser) (argument-unparser :accessor argument-unparser :initarg :argument-unparser) (required-args :accessor required-args :initarg :required-args) (keyword-args :accessor keyword-args :initarg :keyword-args)) (:documentation "A container for a command's parsing functions and data for unparsing")) (defparameter *command-parser-table* (make-hash-table) "Mapping from command names to argument parsing functions.") (defvar *unsupplied-argument-marker* '%unsupplied-argument-marker%) (defvar *numeric-argument-marker* '%numeric-argument-marker%) (defvar *command-name-delimiters* '(command-delimiter)) (defvar *command-argument-delimiters* '(command-delimiter)) ;;; A type indicating empty input. For example, if one types ;;; to get the default value of a keyword argument, and then types ;;; , we don't want to see "None" in the output history. So, ;;; we define this subtype of null that has no output. It's not meant ;;; to be read if the form is ever accepted again. (define-presentation-type empty () :inherit-from 'null) (define-presentation-method present (object (type empty) stream (view textual-view) &key &allow-other-keys) (declare (ignore object stream))) (defun accept-form-for-argument (stream arg) (let ((accept-keys '(:default :default-type :display-default :prompt :documentation :insert-default))) (destructuring-bind (name ptype &rest key-args &key (mentioned-default nil mentioned-default-p) &allow-other-keys) arg (declare (ignore name)) `(accept ,ptype :stream ,stream ,@(loop for (key val) on key-args by #'cddr when (member key accept-keys) append `(,key ,val) into args finally (return (if mentioned-default-p `(:default ,mentioned-default ,@args) args))))))) ;;; In the partial command reader accepting-values dialog, default ;;; values come either from the input command arguments, if a value ;;; was supplied, or from the default option for the command argument. ;;; ;;; accept for the partial command reader. Can this be refactored to ;;; share code with accept-form-for-argument? Probably not. ;;; ;;; original-command-arg is value entered by the user, or ;;; *unsupplied-argument-marker*. command-arg is the current value for the ;;; argument, originally bound to original-command-arg and now possibly ;;; changed by the user. (defun accept-form-for-argument-partial (stream ptype-arg command-arg original-command-arg ) (let ((accept-keys '(:default :default-type :display-default :prompt :documentation :insert-default))) (destructuring-bind (name ptype &rest key-args) ptype-arg (declare (ignore name)) (let ((args (loop for (key val) on key-args by #'cddr if (eq key :default) append `(:default (if (eq ,command-arg *unsupplied-argument-marker*) ,val ,command-arg)) else if (member key accept-keys :test #'eq) append `(,key ,val)))) (setq args (append args `(:query-identifier ',(gensym "COMMAND-PROMPT-ID")))) (if (member :default args :test #'eq) `(accept ,ptype :stream ,stream ,@args) `(if (eq ,original-command-arg *unsupplied-argument-marker*) (accept ,ptype :stream ,stream ,@args) (accept ,ptype :stream ,stream :default ,command-arg ,@args))))))) (defun make-keyword (sym) (intern (symbol-name sym) :keyword)) (defun make-key-acceptors (stream keyword-args key-results) ;; We don't use the name as a variable, and we do want a symbol in the ;; keyword package. (when (null keyword-args) (return-from make-key-acceptors nil)) (setq keyword-args (mapcar #'(lambda (arg) (cons (make-keyword (car arg)) (cdr arg))) keyword-args)) (let ((key-possibilities (gensym "KEY-POSSIBILITIES")) (member-ptype (gensym "MEMBER-PTYPE")) (key-result (gensym "KEY-RESULT")) (val-result (gensym "VAL-RESULT"))) `(let ((,key-possibilities nil)) ,@(mapcar #'(lambda (key-arg) (destructuring-bind (name ptype &key (when t) &allow-other-keys) key-arg (declare (ignore ptype)) (let ((key-arg-name (concatenate 'string ":" (keyword-arg-name-from-symbol name)))) `(when ,when (push `(,,key-arg-name ,,name) ,key-possibilities))))) keyword-args) (setq ,key-possibilities (nreverse ,key-possibilities)) (when ,key-possibilities (input-editor-format ,stream "(keywords) ") (let ((,member-ptype `(token-or-type ,,key-possibilities empty))) (loop (let* ((,key-result (prog1 (accept ,member-ptype :stream ,stream :prompt nil :default nil) (eat-delimiter-or-activator))) (,val-result (case ,key-result ,@(mapcar #'(lambda (key-arg) `(,(car key-arg) ,(accept-form-for-argument stream key-arg))) keyword-args)))) (setq ,key-results (list* ,key-result ,val-result ,key-results))) (eat-delimiter-or-activator)))) ,key-results))) (defun make-argument-accept-fun (name required-args keyword-args) (let ((stream-var (gensym "STREAM")) (required-arg-names (mapcar #'car required-args)) (key-results (gensym "KEY-RESULTS"))) `(defun ,name (,stream-var) (let (,@(mapcar #'(lambda (arg) `(,arg *unsupplied-argument-marker*)) required-arg-names) (,key-results nil)) (block activated (flet ((eat-delimiter-or-activator () (let ((gesture (read-gesture :stream ,stream-var))) (when (or (null gesture) (activation-gesture-p gesture)) (return-from activated nil)) (unless (delimiter-gesture-p gesture) (unread-gesture gesture :stream ,stream-var))))) (declare (ignorable (function eat-delimiter-or-activator))) (let ((gesture (read-gesture :stream ,stream-var :timeout 0 :peek-p t))) (cond ((and gesture (activation-gesture-p gesture)) (return-from activated nil))) ,@(mapcan #'(lambda (arg) (copy-list `((setq ,(car arg) ,(accept-form-for-argument stream-var arg)) (eat-delimiter-or-activator)))) required-args) ,(make-key-acceptors stream-var keyword-args key-results)))) (list* ,@required-arg-names ,key-results))))) (defun make-partial-parser-fun (name required-args) (with-gensyms (command-table stream partial-command command-name command-line-name) (let* ((required-arg-names (mapcar #'car required-args)) (original-args (mapcar #'(lambda (arg) (gensym (format nil "~A-ORIGINAL" (symbol-name arg)))) required-arg-names))) ;; We don't need fresh gensyms of these variables for each accept form. (with-gensyms (value ptype changedp) `(defun ,name (,command-table ,stream ,partial-command) (do ((still-missing nil t)) (nil) (destructuring-bind (,command-name ,@original-args) ,partial-command (let ((,command-line-name (command-line-name-for-command ,command-name ,command-table :errorp nil)) ,@(mapcar #'list required-arg-names original-args)) (accepting-values (,stream :select-first-query t :align-prompts t) (format ,stream "You are being prompted for arguments to ~S~%" ,command-line-name) ,@(loop for var in required-arg-names for original-var in original-args for parameter in required-args for first-arg = t then nil append `((multiple-value-bind (,value ,ptype ,changedp) ,(accept-form-for-argument-partial stream parameter var original-var) (declare (ignore ,ptype)) ,@(unless first-arg `((terpri ,stream))) (when ,changedp (setq ,var ,value))))) (when still-missing (format ,stream "~&Please supply all arguments.~%"))) (setf ,partial-command (list ,command-name ,@required-arg-names)) (unless (partial-command-p ,partial-command) (return ,partial-command)))))))))) ;;; XXX What do to about :acceptably? Probably need to wait for Goatee "buffer ;;; streams" so we can insert an accept-result-extent in the buffer for ;;; unacceptable objects. -- moore (defun make-unprocessor-fun (name required-args key-args) (with-gensyms (command command-args stream key key-arg-val seperator arg-tail) ;; Bind the argument variables because expressions in the ;; following arguments (including the presentation type!) might ;; reference them. (let ((required-arg-bindings nil) (key-case-clauses nil)) (loop for (arg ptype-form) in required-args collect `(,arg (progn (write-char ,seperator ,stream) (present (car ,command-args) ,ptype-form :stream ,stream) (pop ,command-args))) into arg-bindings finally (setq required-arg-bindings arg-bindings)) (loop for (arg ptype-form) in key-args for arg-key = (make-keyword arg) collect `(,arg-key (format ,stream "~C:~A~C" ,seperator ,(keyword-arg-name-from-symbol arg) ,seperator) (present ,key-arg-val ,ptype-form :stream ,stream)) into key-clauses finally (setq key-case-clauses key-clauses)) `(defun ,name (,command ,stream) ,(declare-ignorable-form* stream) (let* ((,seperator #\Space) (,command-args (cdr ,command)) ,@required-arg-bindings) (declare (ignorable ,seperator ,command-args ,@(mapcar #'car required-arg-bindings ))) ,@(when key-args `((loop for ,arg-tail on ,command-args by #'cddr for (,key ,key-arg-val) = ,arg-tail do (progn (case ,key ,@key-case-clauses) (when (cddr ,arg-tail) (write-char ,seperator ,stream))))))))))) (defun make-command-translators (command-name command-table args) "Helper function to create command presentation translators for a command." (loop with readable-command-name = (command-name-from-symbol command-name) ; XXX or :NAME for arg in args for arg-index from 0 append (when (getf (cddr arg) :gesture) (destructuring-bind (name ptype &key gesture &allow-other-keys) arg (let ((command-args (loop for a in args for i from 0 if (eql i arg-index) collect 'object else collect (getf (cddr a) :default) end)) (translator-name (intern (format nil ".~A-ARG~D." command-name arg-index) (symbol-package name)))) (multiple-value-bind (gesture translator-options) (if (listp gesture) (values (car gesture) (cdr gesture)) (values gesture nil)) (destructuring-bind (&key (documentation `((object stream) (orf stream *standard-output*) (format stream "~A " ,readable-command-name) (present object (presentation-type-of object) ; type? :stream stream :acceptably nil :sensitive nil)) documentationp) &allow-other-keys) translator-options `(define-presentation-to-command-translator ,translator-name (,(eval ptype) ,command-name ,command-table :gesture ,gesture ,@(unless documentationp `(:documentation ,documentation)) ,@translator-options) (object) (list ,@command-args))))))))) ;;; Vanilla define-command, as defined by the standard (defmacro %define-command (name-and-options args &body body) (unless (listp name-and-options) (setq name-and-options (list name-and-options))) (destructuring-bind (func &key command-table name menu keystroke) name-and-options (multiple-value-bind (required-args keyword-args) (loop for arg-tail on args for (arg) = arg-tail until (eq arg '&key) collect arg into required finally (return (values required (cdr arg-tail)))) (let* ((command-func-args `(,@(mapcar #'car required-args) ,@(and keyword-args `(&key ,@(mapcar #'(lambda (arg-clause) (destructuring-bind (arg-name ptype &key default &allow-other-keys) arg-clause (declare (ignore ptype)) `(,arg-name ,default))) keyword-args))))) (accept-fun-name (gentemp (format nil "~A%ACCEPTOR%" (symbol-name func)) (symbol-package func))) (partial-parser-fun-name (gentemp (format nil "~A%PARTIAL%" (symbol-name func)) (symbol-package func))) (arg-unparser-fun-name (gentemp (format nil "~A%unparser%" (symbol-name func)) (symbol-package func)))) `(progn (defun ,func ,command-func-args ,@body) ,(when command-table `(add-command-to-command-table ',func ',command-table :name ,name :menu ',menu :keystroke ',keystroke :errorp nil ,@(and menu `(:menu-command (list ',func ,@(make-list (length required-args) :initial-element '*unsupplied-argument-marker*)))))) ,(make-argument-accept-fun accept-fun-name required-args keyword-args) ,(make-partial-parser-fun partial-parser-fun-name required-args) ,(make-unprocessor-fun arg-unparser-fun-name required-args keyword-args) ,(and command-table (make-command-translators func command-table required-args)) (setf (gethash ',func *command-parser-table*) (make-instance 'command-parsers :parser #',accept-fun-name :partial-parser #',partial-parser-fun-name :required-args ',required-args :keyword-args ',keyword-args :argument-unparser #',arg-unparser-fun-name)) ',func))))) ;;; define-command with output destination extension (defclass output-destination () ()) (defgeneric invoke-with-standard-output (continuation destination) (:documentation "Invokes `continuation' (with no arguments) with *standard-output* rebound according to `destination'")) (defclass standard-output-destination (output-destination) ()) (defmethod invoke-with-standard-output (continuation (destination null)) "Calls `continuation' without rebinding *standard-output* at all." (funcall continuation)) (defclass stream-destination (output-destination) ((destination-stream :accessor destination-stream :initarg :destination-stream))) (defmethod invoke-with-standard-output (continuation (destination stream-destination)) (let ((*standard-output* (destination-stream destination))) (funcall continuation))) (define-presentation-method accept ((type stream-destination) stream (view textual-view) &key) (let ((dest (eval (accept 'form :stream stream :view view :default *standard-output*)))) (if (and (streamp dest) (output-stream-p dest)) (make-instance 'stream-destination :destination-stream dest) (input-not-of-required-type dest type)))) (defclass file-destination (output-destination) ((file :accessor file :initarg :file))) (defmethod invoke-with-standard-output (continuation (destination file-destination)) (with-open-file (*standard-output* (file destination) :direction :output :if-exists :supersede) (funcall continuation))) (define-presentation-method accept ((type file-destination) stream (view textual-view) &key) (let ((path (accept 'pathname :stream stream :prompt nil))) ;; Give subclasses a shot (with-presentation-type-decoded (type-name) type (format *debug-io* "file destination type = ~S~%" type) (make-instance type-name :file path)))) (defclass postscript-destination (file-destination) ()) (defmethod invoke-with-standard-output (continuation (destination postscript-destination)) (call-next-method #'(lambda () (with-output-to-postscript-stream (ps-stream *standard-output*) (let ((*standard-output* ps-stream)) (funcall continuation)))) destination)) (defparameter *output-destination-types* '(("File" file-destination) ("Postscript File" postscript-destination) ("Stream" stream-destination))) (define-presentation-method accept ((type output-destination) stream (view textual-view) &key) (let ((type (accept `(member-alist ,*output-destination-types*) :stream stream :view view :default 'stream-destination :additional-delimiter-gestures '(#\space)))) (read-char stream) (accept type :stream stream :view view))) ;;; The default for :provide-output-destination-keyword is nil until we fix ;;; some unfortunate problems with completion, defaulting, and keyword ;;; arguments. (defmacro define-command (name-and-options args &body body) (unless (listp name-and-options) (setq name-and-options (list name-and-options))) (destructuring-bind (func &rest options &key (provide-output-destination-keyword nil) &allow-other-keys) name-and-options (with-keywords-removed (options (:provide-output-destination-keyword)) (if provide-output-destination-keyword (multiple-value-bind (required optional rest key key-supplied) (parse-lambda-list args) (declare (ignore required optional rest key)) (let* ((destination-arg '(output-destination 'output-destination :default nil)) (new-args (if key-supplied `(,@args ,destination-arg) `(,@args &key ,destination-arg)))) (multiple-value-bind (decls new-body) (get-body-declarations body) (with-gensyms (destination-continuation) `(%define-command (,func ,@options) ,new-args ,@decls (flet ((,destination-continuation () ,@new-body)) (declare (dynamic-extent #',destination-continuation)) (invoke-with-standard-output #',destination-continuation output-destination))))))) `(%define-command (,func ,@options) ,args ,@body))))) ;;; Note that command table inheritance is the opposite of Common Lisp ;;; subclassing / subtyping: the inheriting table defines a superset ;;; of the commands of its ancestor, so therefore it's command ;;; presentation type is a supertype of its ancestor's! (defun command-table-inherits-from-p (command-table super-table) (let ((command-table (find-command-table command-table)) (super-table (find-command-table super-table))) (do-command-table-inheritance (table command-table) (when (eq table super-table) (return-from command-table-inherits-from-p (values t t)))) (values nil t))) (define-presentation-type command-name (&key (command-table (frame-command-table *application-frame*))) :inherit-from t) (define-presentation-method presentation-typep (object (type command-name)) (and (command-accessible-in-command-table-p object command-table) (command-enabled object *application-frame*))) (define-presentation-method presentation-subtypep ((type command-name) maybe-supertype) (with-presentation-type-parameters (command-name maybe-supertype) (let ((super-table command-table)) (with-presentation-type-parameters (command-name type) (command-table-inherits-from-p super-table command-table))))) (define-presentation-method present (object (type command-name) stream (view textual-view) &key) (let ((command-line-name (command-line-name-for-command object command-table :errorp nil))) (if command-line-name (write-string command-line-name stream) (prin1 object stream)))) (define-presentation-method accept ((type command-name) stream (view textual-view) &key) (flet ((generator (string suggester) (declare (ignore string)) (let ((possibilities nil)) (map-over-command-table-names (lambda (cline-name command-name) (unless (member command-name (disabled-commands *application-frame*)) (pushnew (cons cline-name command-name) possibilities :key #'car :test #'string=))) command-table) (loop for (cline-name . command-name) in possibilities do (funcall suggester cline-name command-name))))) ;; KLUDGE: here, we used to bind the frame's command table so that ;; a test with COMMAND-ENABLED passed with the command-table being ;; accepted from. Unfortunately, that interfered awfully with ;; drei gadgets and their command-table inheritance; the dynamic ;; inheritance from (frame-command-table *application-frame*) [ ;; which is needed to get things like frame menu items and other ;; commands to work ] works really badly if (frame-command-table ;; *application-frame*) is set/bound to the dispatching ;; command-table itself. ;; ;; Instead we now use the knowledge of how disabled commands are ;; implemented to satisfy the constraint that only enabeled ;; commands are acceptable (with the "accessible" constraint being ;; automatically satisfied by the generator mapping over the ;; command-table). ;; ;; This means that someone implementing their own version of the ;; "enabled-command" protocol will lose. Sorry. CSR, 2009-02-17 (multiple-value-bind (object success string) (complete-input stream #'(lambda (so-far mode) (complete-from-generator so-far #'generator '(#\space) :action mode)) :partial-completers '(#\space)) (if success (values object type) (simple-parse-error "No command named ~S" string))))) (defun command-line-command-parser (command-table stream) (let ((command-name nil) (command-args nil)) (with-delimiter-gestures (*command-name-delimiters* :override t) ;; While reading the command name we want use the history of the ;; (accept 'command ...) that's calling this function. (setq command-name (accept `(command-name :command-table ,command-table) :stream stream :prompt nil :history nil)) (let ((delimiter (read-gesture :stream stream :peek-p t))) ;; Let argument parsing function see activation gestures. (when (and delimiter (delimiter-gesture-p delimiter)) (read-gesture :stream stream)))) (with-delimiter-gestures (*command-argument-delimiters* :override t) (setq command-args (funcall (parser (gethash command-name *command-parser-table*)) stream))) (cons command-name command-args))) (defun command-line-command-unparser (command-table stream command) (write-string (command-line-name-for-command (car command) command-table :errorp :create) stream) (when (cdr command) (let ((parser-obj (gethash (car command) *command-parser-table*))) (if parser-obj (funcall (argument-unparser parser-obj) command stream) (with-delimiter-gestures (*command-argument-delimiters* :override t) (loop for arg in (cdr command) do (progn (write-char #\space stream) (write-token (present-to-string arg (presentation-type-of arg)) stream)))))))) ;;; In order for this to work, the input-editing-stream must implement ;;; a method for the nonstandard function ;;; `input-editing-stream-output-record'. (defun command-line-read-remaining-arguments-for-partial-command (command-table stream partial-command start-position) (declare (ignore start-position)) (let ((partial-parser (partial-parser (gethash (command-name partial-command) *command-parser-table*)))) (if (encapsulating-stream-p stream) (let ((interactor (encapsulating-stream-stream stream))) (with-bounding-rectangle* (x1 y1 x2 y2) (input-editing-stream-output-record stream) (declare (ignore y1 x2)) ;; Start the dialog below the editor area (letf (((stream-cursor-position interactor) (values x1 y2))) (fresh-line interactor) ;; FIXME error checking needed here? -- moore (funcall partial-parser command-table interactor partial-command)))) (progn (fresh-line stream) (funcall partial-parser command-table stream partial-command))))) (defparameter *command-parser* #'command-line-command-parser) (defparameter *command-unparser* #'command-line-command-unparser) (defvar *partial-command-parser* #'command-line-read-remaining-arguments-for-partial-command) (define-presentation-type command (&key (command-table (frame-command-table *application-frame*))) :inherit-from t) (define-presentation-method presentation-typep (object (type command)) (and (consp object) (presentation-typep (car object) `(command-name :command-table ,command-table)))) (define-presentation-method presentation-subtypep ((type command) maybe-supertype) (with-presentation-type-parameters (command maybe-supertype) (let ((super-table command-table)) (with-presentation-type-parameters (command type) (command-table-inherits-from-p super-table command-table))))) (define-presentation-method present (object (type command) stream (view textual-view) &key acceptably for-context-type) (declare (ignore acceptably for-context-type)) (funcall *command-unparser* command-table stream object)) (define-presentation-method accept ((type command) stream (view textual-view) &key) (let ((command (funcall *command-parser* command-table stream))) (cond ((null command) (simple-parse-error "Empty command")) ((partial-command-p command) (funcall *partial-command-parser* command-table stream command (position *unsupplied-argument-marker* command))) (t (values command type))))) ;;; A presentation type for empty input at the command line; something for ;;; read-command to supply as a default. The command is defined in ;;; builtin-commands.lisp. (define-presentation-type null-command () :inherit-from '(command :command-table global-command-table)) (define-presentation-method presentation-typep (object (type null-command)) (and (consp object) (eq (car object) 'com-null-command))) (define-presentation-method present (object (type null-command) stream (view textual-view) &key) (declare (ignore object stream view))) (defparameter +null-command+ '(com-null-command)) (defclass presentation-command-translator (presentation-translator) () (:documentation "Wraps the tester function with a test that determines if the command is enabled.")) (defmethod initialize-instance :after ((obj presentation-command-translator) &key tester command-name) (setf (slot-value obj 'tester) #'(lambda (&rest args) (if (command-enabled command-name *application-frame*) (when tester (apply tester args)) nil)))) (defmacro define-presentation-to-command-translator (name (from-type command-name command-table &key (gesture :select) (tester 'default-translator-tester testerp) (documentation nil documentationp) (pointer-documentation (command-name-from-symbol command-name)) (menu t) (priority 0) (echo t)) arglist &body body) (let ((command-args (gensym "COMMAND-ARGS"))) `(define-presentation-translator ,name (,from-type (command :command-table ,command-table) ,command-table :gesture ,gesture :tester ,tester :tester-definitive t ,@(and documentationp `(:documentation ,documentation)) :pointer-documentation ,pointer-documentation :menu ,menu :priority ,priority :translator-class presentation-command-translator :command-name ',command-name) ,arglist (let ((,command-args (progn ,@body))) (values (cons ',command-name ,command-args) '(command :command-table ,command-table) '(:echo ,echo)))))) (defun command-name (command) (first command)) (defun command-arguments (command) (rest command)) (defun partial-command-p (command) (member *unsupplied-argument-marker* command)) (defmacro with-command-table-keystrokes ((keystroke-var command-table) &body body) (with-gensyms (table) `(let* ((,table (find-command-table ,command-table)) (,keystroke-var (slot-value ,table 'keystroke-accelerators))) ,@body))) ;; This is probably wrong - we should walk the menu rather than inheritance ;; structure to be consistent with lookup-keystroke-item. (defun compute-inherited-keystrokes (command-table) "Return a list containing the keyboard gestures of accelerators defined in 'command-table' and all tables it inherits from." (let (accumulated-keystrokes) (do-command-table-inheritance (comtab command-table) (with-command-table-keystrokes (keystrokes comtab) (dolist (keystroke keystrokes) (setf accumulated-keystrokes (adjoin keystroke accumulated-keystrokes :test #'equal))))) accumulated-keystrokes)) (defun read-command (command-table &key (stream *standard-input*) (command-parser *command-parser*) (command-unparser *command-unparser*) (partial-command-parser *partial-command-parser*) use-keystrokes) (let ((*command-parser* command-parser) (*command-unparser* command-unparser) (*partial-command-parser* partial-command-parser)) (cond (use-keystrokes (let ((stroke-result (read-command-using-keystrokes command-table (compute-inherited-keystrokes command-table) :stream stream))) (if (consp stroke-result) stroke-result nil))) ((or (typep stream 'interactor-pane) (typep stream 'input-editing-stream)) (handler-case (multiple-value-bind (command ptype) (accept `(command :command-table ,command-table) :stream stream :prompt nil :default +null-command+ :default-type 'null-command) (cond ((eq ptype 'null-command) nil) ((partial-command-p command) (beep) (format *query-io* "~&Argument ~D not supplied.~&" (position *unsupplied-argument-marker* command)) nil) (t command))) ((or simple-parse-error input-not-of-required-type) (c) (beep) (fresh-line *query-io*) (princ c *query-io*) (terpri *query-io*) nil))) (t (with-input-context (`(command :command-table ,command-table)) (object) (loop (read-gesture :stream stream)) (t object)))))) (defun read-command-using-keystrokes (command-table keystrokes &key (stream *standard-input*) (command-parser *command-parser*) (command-unparser *command-unparser*) (partial-command-parser *partial-command-parser*)) (let ((*command-parser* command-parser) (*command-unparser* command-unparser) (*partial-command-parser* partial-command-parser) (*accelerator-gestures* keystrokes)) (handler-case (read-command command-table :stream stream) (accelerator-gesture (c) ;; If lookup-keystroke-item below returns a partial command, invoke the ;; partial command parser to complete it. (let ((command (lookup-keystroke-command-item (accelerator-gesture-event c) command-table))) (if (and (listp command) (partial-command-p command)) (funcall *partial-command-parser* command-table stream command (position *unsupplied-argument-marker* command)) command)))))) (defun substitute-numeric-argument-marker (command numeric-arg) (substitute numeric-arg *numeric-argument-marker* command)) (defvar *command-dispatchers* '(#\:)) (define-presentation-type command-or-form (&key (command-table (frame-command-table *application-frame*))) :inherit-from t) ;;; What's the deal with this use of with-input-context inside of ;;; accept? When this accept method is called, we want to accept both ;;; commands and forms via mouse clicks, both before and after the ;;; command dispatch character is typed. But command translators to ;;; command or form won't be applicable... translators from command or ;;; form to command-or-form won't help either because translators aren't ;;; applied more than once. ;;; ;;; By calling the input context continuation directly -- which was ;;; established by the call to (accept 'command-or-form ...) -- we let it do ;;; all the cleanup like replacing input, etc. (define-presentation-method accept ((type command-or-form) stream (view textual-view) &key) (let ((command-ptype `(command :command-table ,command-table))) (with-input-context (`(or ,command-ptype form)) (object type event options) (let ((initial-char (read-gesture :stream stream :peek-p t))) (if (member initial-char *command-dispatchers*) (progn (read-gesture :stream stream) (accept command-ptype :stream stream :view view :prompt nil :history 'command)) (accept 'form :stream stream :view view :prompt nil :history 'command-or-form))) (t (funcall (cdar *input-context*) object type event options))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/utils.lisp0000640000175000017500000005107210705412614017031 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2001 by Arnaud Rouanet (rouanet@emi.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) (defun get-environment-variable (string) #+excl (sys:getenv string) #+(or cmu scl) (cdr (assoc string ext:*environment-list* :test #'string=)) #+clisp (ext:getenv (string string)) #+sbcl (sb-ext::posix-getenv string) #+openmcl (ccl::getenv string) #+lispworks (lw:environment-variable string) #-(or excl cmu scl clisp sbcl openmcl lispworks) (error "GET-ENVIRONMENT-VARIABLE not implemented")) ;;; It would be nice to define this macro in terms of letf, but that ;;; would change the top-levelness of the enclosed forms. #+excl (defmacro with-system-redefinition-allowed (&body body) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) (setf (excl:package-definition-lock (find-package :common-lisp)) nil)) ,@body (eval-when (:compile-toplevel :load-toplevel :execute) (setf (excl:package-definition-lock (find-package :common-lisp)) t)))) #+clisp (defmacro with-system-redefinition-allowed (&body body) `(ext:without-package-lock ("COMMON-LISP") ,@body)) #+openmcl (defmacro with-system-redefinition-allowed (&body body) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) (setq ccl::*warn-if-redefine-kernel* nil)) ,@body (eval-when (:compile-toplevel :load-toplevel :execute) (setq ccl::*warn-if-redefine-kernel* t)))) #+cmu (eval-when (:compile-toplevel :execute) (when (find-symbol "PACKAGE-LOCK" :ext) (pushnew 'clim-internals::package-locks *features*))) #+(and cmu clim-internals::package-locks) (eval-when (:load-toplevel) (unless (find-symbol "PACKAGE-LOCK" :ext) (error "Binary incompatibility: your CMUCL does not have package locks"))) #+cmu (defmacro with-system-redefinition-allowed (&body body) #+clim-internals::package-locks `(progn (eval-when (:compile-toplevel :load-toplevel :execute) (setf (ext:package-definition-lock (find-package :common-lisp)) nil)) ,@body (eval-when (:compile-toplevel :load-toplevel :execute) (setf (ext:package-definition-lock (find-package :common-lisp)) t))) #-clim-internals::package-locks `(progn ,@body)) #+sbcl (eval-when (:compile-toplevel :execute) (when (find-symbol "UNLOCK-PACKAGE" :sb-ext) (pushnew 'clim-internals::package-locks *features*))) #+sbcl (defmacro with-system-redefinition-allowed (&body body) #+clim-internals::package-locks `(progn (eval-when (:compile-toplevel :load-toplevel :execute) (sb-ext:unlock-package :common-lisp)) ,@body (eval-when (:compile-toplevel :load-toplevel :execute) (sb-ext:lock-package :common-lisp))) #-clim-internals::package-locks `(progn ,@body)) #-(or excl openmcl cmu sbcl clisp) (defmacro with-system-redefinition-allowed (&body body) `(progn ,@body)) (defun last1 (list) "Last element of LIST." (first (last list))) (defun 2+ (x) (+ x 2)) (defun 2- (x) (- x 2)) (defun check-letf-form (form) (assert (and (listp form) (= 2 (length form))))) (defun valueify (list) (if (and (consp list) (endp (rest list))) (first list) `(values ,@list))) (defmacro letf ((&rest forms) &body body &environment env) "LETF ({(Place Value)}*) Declaration* Form* During evaluation of the Forms, SETF the Places to the result of evaluating the Value forms. The places are SETF-ed in parallel after all of the Values are evaluated." (mapc #'check-letf-form forms) (let* (init-let-form save-old-values-setf-form new-values-set-form old-values-set-form update-form) (loop for (place new-value) in forms for (vars vals store-vars writer-form reader-form) = (multiple-value-list (get-setf-expansion place env)) for old-value-names = (mapcar (lambda (var) (declare (ignore var)) (gensym)) store-vars) nconc (mapcar #'list vars vals) into temp-init-let-form nconc (copy-list store-vars) into temp-init-let-form nconc (copy-list old-value-names) into temp-init-let-form nconc `(,(valueify old-value-names) ,reader-form) into temp-save-old-values-setf-form nconc `(,(valueify store-vars) ,new-value) into temp-new-values-set-form nconc `(,(valueify store-vars) ,(valueify old-value-names)) into temp-old-values-set-form collect writer-form into temp-update-form finally (setq init-let-form temp-init-let-form save-old-values-setf-form temp-save-old-values-setf-form new-values-set-form temp-new-values-set-form old-values-set-form temp-old-values-set-form update-form (cons 'progn temp-update-form))) `(let* ,init-let-form (setf ,@save-old-values-setf-form) (unwind-protect (progn (setf ,@new-values-set-form) ,update-form (progn ,@body)) (setf ,@old-values-set-form) ,update-form)))) ;;; XXX This is currently broken with respect to declarations (defmacro letf* ((&rest forms) &body body) (if (null forms) `(locally ,@body) `(letf (,(car forms)) (letf* (,(cdr forms)) ,@body)))) (defun map-repeated-sequence (result-type n function sequence) "Like CL:MAP, but applies \\arg{function} to \\arg{n} consecutive elements of \\arg{sequence}. All the function's return values will be gathered into the output sequence. \\arg{result-type} can also be NIL, in which case the function is only applied for effect. Examples: (map-repeated-sequence 'list 2 #'list '(1 2 3 4 5 6)) => ((1 2) (3 4) (5 6)) (map-repeated-sequence 'list 2 #'+ '(1 2 3 4 5 6)) => (3 7 11) (map-repeated-sequence 'vector 3 #'+ '(1 2 3 4 5 6)) => #(6 15) (map-repeated-sequence 'list 2 #'floor '(2 1 4 3 6 5)) => (2 0 1 1 1 1) (map-repeated-sequence 'list 2 #'cons '(color red weight 17 name fred)) => ((COLOR . RED) (WEIGHT . 17) (NAME . FRED)) (map-repeated-sequence 'list 1 #'(lambda (p) (values (car p) (cdr p))) '((color . red) (weight . 17) (name . fred))) => (COLOR RED WEIGHT 17 NAME FRED) Note: Be careful, since this function is quite sensible to the number of values returned by \\arg{function}. " (assert (>= n 1)) (cond ((eq result-type 'nil) ;; just map for effect (cond ((vectorp sequence) (loop for i from 0 below (length sequence) by n do (apply function (loop for j from 0 below n collect (aref sequence (+ i j)))))) ((listp sequence) (let ((q sequence)) (loop until (null q) do (apply function (loop for j from 0 below n collect (pop q)))))))) (t ;; otherwise, we (for now) take the easy route of calling COERCE (coerce (cond ((vectorp sequence) (loop for i from 0 below (length sequence) by n nconc (multiple-value-list (apply function (loop for j from 0 below n collect (aref sequence (+ i j))))))) ((listp sequence) (let ((q sequence)) (loop until (null q) nconc (multiple-value-list (apply function (loop for j from 0 below n collect (pop q)))))))) result-type)))) ;;; A different way of attacking iteration of sequences (defmacro do-sequence ((vars sequence &optional result-form) &body body) "Iterate over SEQUENCE. VARS is a list of symbols (or a single symbol). At each iteration the variables in VARS are bound to the initial elements of the sequence. The iteration is then \"stepped\" by the number of variables in VARS." (flet ((list-accessor (n) (case n (0 'car) (1 'cadr) (2 'caddr) (3 'cadddr) (t `(lambda (list) (nth ,n list))))) (list-stepper (n) (case n (1 'cdr) (2 'cddr) (3 'cdddr) (4 'cddddr) (t `(lambda (list) (nthcdr ,n list)))))) (when (not (listp vars)) (setq vars (list vars))) (let* ((body-fun (gensym "BODY-FUN")) (var-length (length vars)) (seq-var (gensym "SEQ-VAR")) (tail-var (gensym "TAIL-VAR")) (i (gensym "I")) (list-args (loop for j from 0 below var-length collect `(,(list-accessor j) ,tail-var))) (vector-args (loop for j from 0 below var-length collect `(aref ,seq-var (+ ,i ,j))))) `(block nil (flet ((,body-fun ,vars (tagbody ,@body))) (let ((,seq-var ,sequence)) (etypecase ,seq-var (list (loop for ,tail-var on ,seq-var by #',(list-stepper var-length) do (,body-fun ,@list-args))) (vector (loop for ,i of-type fixnum from 0 below (length ,seq-var) by ,var-length do (,body-fun ,@vector-args)))))) ,@(when result-form `((let ,vars ;Bind variables to nil (declare (ignorable ,vars)) ,result-form))))))) (defun clamp (value min max) "Clamps the value 'value' into the range [min,max]." (max min (min max value))) ;;;; ;;;; meta functions ;;;; ;; these are as in Dylan (defun curry (fun &rest args) #'(lambda (&rest more) (apply fun (append args more)))) (define-compiler-macro curry (fun &rest args) `(lambda (&rest more) (apply ,fun ,@args more))) (defun always (x) #'(lambda (&rest more) (declare (ignore more)) x)) (define-compiler-macro always (x) (let ((g (gensym))) `(let ((,g ,x)) (lambda (&rest more) (declare (ignore more)) ,g)))) ;;; Convenience macros (define-modify-macro maxf (&rest args) max) (define-modify-macro minf (&rest args) min) (define-modify-macro nconcf (&rest args) nconc) (define-modify-macro orf (&rest args) or) ;;; Move this early so it can be used in presentations.lisp, which ;;; comes before commands.lisp. (defmacro do-command-table-inheritance ((command-table-var command-table) &body body) `(apply-with-command-table-inheritance #'(lambda (,command-table-var) ,@body) (find-command-table ,command-table))) ;;; (defmacro with-gensyms (syms &body body) "Binds each symbol in the list `syms' to a gensym which uses the name of the symbol." `(let ,(mapcar (lambda (symbol) `(,symbol (gensym ,(symbol-name symbol)))) syms) ,@ body)) (defun parse-method (description) (loop for (qualifier-or-ll . body) on description until (listp qualifier-or-ll) collect qualifier-or-ll into qualifiers finally (return (values qualifiers (clim-mop:extract-specializer-names qualifier-or-ll) (clim-mop:extract-lambda-list qualifier-or-ll) body)))) (defun get-body-declarations (body) "Collect all declaration forms from a body of forms that may have declarations at its top. Returns as values a list of the declarations and the rest of the body." (loop for bod on body for (form) = bod if (and (consp form) (eq (car form) 'declare)) collect form into decls else return (values decls bod) finally (return (values decls nil)))) ;It's all (declare ...) (defun decode-specializer (specializer-name) (if (atom specializer-name) (find-class specializer-name) (clim-mop:intern-eql-specializer (second specializer-name)))) (defmacro with-method ((name &rest description) &body body) "Executes BODY installing the specified method on the generic function named NAME." (multiple-value-bind (qualifiers specializers) (parse-method description) (with-gensyms (old-method decoded-specializers new-method) `(let* ((,decoded-specializers (mapcar #'decode-specializer ',specializers)) (,old-method (find-method #',name ',qualifiers ,decoded-specializers nil)) (,new-method (defmethod ,name ,@description))) (unwind-protect (locally ,@body) (remove-method #',name ,new-method) (when ,old-method (add-method #',name ,old-method))))))) ;;; Anaphoric (defmacro aif (test-form then-form &optional else-form) `(let ((it ,test-form)) (if it ,then-form ,else-form))) (defmacro awhen (test-form &body body) `(aif ,test-form (progn ,@body))) (defmacro aand (&rest args) (cond ((endp args) t) ((endp (rest args)) (first args)) (t `(aif ,(first args) (aand ,@(rest args)))))) ;;; (declaim (inline maybe-funcall maybe-apply)) (defun maybe-funcall (function &rest args) "If FUNCTION is not NIL, funcall it." (when function (apply function args))) (defun maybe-apply (function &rest args) "If FUNCTION is not NIL, apply it." (when function (apply #'apply function args))) ;;; Remove keyword pairs from an argument list, consing as little as possible (defun remove-keywords (arg-list keywords) (let ((clean-tail arg-list)) ;; First, determine a tail in which there are no keywords to be removed. (loop for arg-tail on arg-list by #'cddr for (key) = arg-tail do (when (member key keywords :test #'eq) (setq clean-tail (cddr arg-tail)))) ;; Cons up the new arg list until we hit the clean-tail, then nconc that on ;; the end. (loop for arg-tail on arg-list by #'cddr for (key value) = arg-tail if (eq arg-tail clean-tail) nconc clean-tail and do (loop-finish) else if (not (member key keywords :test #'eq)) nconc (list key value) end))) (defmacro with-keywords-removed ((var keywords &optional (new-var var)) &body body) "binds NEW-VAR (defaults to VAR) to VAR with the keyword arguments specified in KEYWORDS removed." `(let ((,new-var (remove-keywords ,var ',keywords))) ,@body)) (defun symbol-concat (&rest symbols) "Actually this function raises the next question: what is *PACKAGE* supposed to be? The correct answer: listen to the elders and don't use this function or any variant of it -- Don't construct symbols, instead let the user specify them." (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols)))) (defun stream-designator-symbol (symbol default) "Maps T to DEFAULT, barfs if argument does not look good. To be used in the various WITH-... macros." (cond ((eq symbol 't) default) ((symbolp symbol) symbol) (t (error "~S Can not be a stream designator for ~S" symbol default)))) (defun declare-ignorable-form (variables) #+CMU ;; CMUCL barfs if you declare a special variable ignorable, work ;; around that. `(declare (ignorable ,@(remove-if (lambda (symbol) (eq :special (lisp::info lisp::variable lisp::kind symbol))) variables))) #-CMU `(declare (ignorable ,@variables))) ;; spread version: (defun declare-ignorable-form* (&rest variables) (declare-ignorable-form variables)) (defun gen-invoke-trampoline (fun to-bind to-pass body) "Macro helper function, generates the LABELS / INVOKE-WITH-... ideom." (let ((cont (gensym ".CONT."))) `(labels ((,cont (,@to-bind) ,(declare-ignorable-form to-bind) ,@body)) (declare (dynamic-extent #',cont)) (,fun ,@to-bind #',cont ,@to-pass)))) ;;;; ---------------------------------------------------------------------- (defun parse-space (stream specification direction) "Returns the amount of space given by SPECIFICATION relating to the STREAM in the direction DIRECTION." ;; This implementation lives unter the assumption that an ;; extended-output stream is also a sheet and has a graft. ;; --GB 2002-08-14 (etypecase specification (integer specification) ((or string character) (multiple-value-bind (width height) (text-size stream specification) (ecase direction (:horizontal width) (:vertical height)))) #+nil ; WITH-OUTPUT-TO-OUTPUT-RECORD not yet defined as a macro (function (let ((record (with-output-to-output-record (stream) (funcall specification)))) (ecase direction (:horizontal (bounding-rectangle-width record)) (:vertical (bounding-rectangle-height record))))) (cons (destructuring-bind (value unit) specification (ecase unit (:character (* value (stream-character-width stream #\M))) (:line (* value (stream-line-height stream))) ((:point :pixel :mm) (let* ((graft (graft stream)) (gunit (graft-units graft))) ;; mungle specification into what grafts talk about (case unit ((:point) (setf value (/ value 72) unit :inches)) ((:pixel) (setf unit :device)) ((:mm) (setf unit :millimeters))) ;; (multiple-value-bind (dx dy) (multiple-value-call #'transform-distance (compose-transformation-with-scaling (sheet-delta-transformation stream graft) (/ (graft-width graft :units unit) (graft-width graft :units gunit)) (/ (graft-height graft :units unit) (graft-height graft :units gunit))) (ecase direction (:horizontal (values 1 0)) (:vertical (values 0 1)))) (/ value (sqrt (+ (* dx dx) (* dy dy)))))))))))) (defun delete-1 (item list &key (test #'eql) (key #'identity)) "Delete 1 ITEM from LIST. Second value is T if item was deleted." (loop for tail on list and tail-prev = nil then tail for (list-item) = tail if (funcall test item (funcall key list-item)) do (return-from delete-1 (if tail-prev (progn (setf (cdr tail-prev) (cdr tail)) (values list t)) (values (cdr tail) t))) finally (return (values list nil)))) ;;; Why do I feel like I've written this function 8 million times ;;; already? (defun parse-lambda-list (ll) "Extract the parts of a function or method lambda list. Returns values of required, &optional, &rest and &key parameters. 5th value indicates that &key was seen" (loop with state = 'required for var in ll if (member var '(&optional &rest &key)) do (setq state var) else if (eq state 'required) collect var into required else if (eq state '&optional) collect var into optional else if (eq state '&rest) collect var into rest else if (eq state '&key) collect var into key end finally (return (values required optional rest key (eq state '&key))))) (defun rebind-arguments (arg-list) "Create temporary variables for non keywords in a list of arguments. Returns two values: a binding list for let, and a new argument list with the temporaries substituted in." (loop for arg in arg-list for var = (gensym) if (keywordp arg) collect arg into new-arg-list else collect `(,var ,arg) into bindings and collect var into new-arg-list end finally (return (values bindings new-arg-list)))) (defun make-keyword (obj) "Turn OBJ into a keyword" (etypecase obj (keyword obj) (symbol (intern (symbol-name obj) :keyword)) (string (intern (string-upcase obj) :keyword)))) ;;; Command name utilities that are useful elsewhere. (defun command-name-from-symbol (symbol) (let ((name (symbol-name symbol))) (string-capitalize (substitute #\Space #\- (subseq name (if (string= '#:com- name :end2 (min (length name) 4)) 4 0)))))) (defun keyword-arg-name-from-symbol (symbol) (let ((name (symbol-name symbol))) (string-capitalize (substitute #\Space #\- name)))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/presentation-defs.lisp0000644000175000017500000025735611345155771021355 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2001,2002 by Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Definitions for the standard presentation types and generic functions (in-package :clim-internals) ;;; The presentation type for T is the built-in type T. The correspondence is ;;; established by hand in presentations.lisp. ;(define-presentation-type t ()) ;;; auto-activate is described in the Franz user guide; it controls whether an ;;; accepting an expression returns immediately after typing the closing ;;; delimiter -- a la Genera et Mac Lisp -- or if an activation gesture is ;;; required. ;;; preserve-whitespace controls whether the accept method uses read or ;;; read-preserving-whitespace. This is used in our redefinitions of read and ;;; read-preserving-whitespace that accept forms. (define-presentation-type expression () :options (auto-activate (preserve-whitespace t) (subform-read nil)) :inherit-from t) (define-presentation-type form () :options (auto-activate (preserve-whitespace t) (subform-read nil)) :inherit-from `((expression) :auto-activate ,auto-activate :preserve-whitespace ,preserve-whitespace :subform-read ,subform-read )) ;;; Actual definitions of presentation methods and types. They've ;;; been separated from the macro and presentation class definitions and ;;; helper functions in order to avoid putting all of presentations.lisp ;;; inside a (eval-when (compile) ...). (define-presentation-generic-function %presentation-typep presentation-typep (type-key parameters object type)) (define-default-presentation-method presentation-typep (object type) (declare (ignore object type)) nil) (defun presentation-typep (object type) (with-presentation-type-decoded (name parameters) type (when (null parameters) (let ((clos-class (find-class name nil))) ; Don't error out. (when (and clos-class (typep clos-class 'standard-class)) (return-from presentation-typep (typep object name))))) (funcall-presentation-generic-function presentation-typep object type))) ;;; Not defined as a generic function, but what the hell. (defgeneric presentation-type-of (object)) (defmethod presentation-type-of (object) (declare (ignore object)) 'expression) (defun get-ptype-from-class-of (object) (let* ((name (class-name (class-of object))) (ptype-entry (gethash name *presentation-type-table*))) (unless ptype-entry (return-from get-ptype-from-class-of nil)) ;; Does the type have required parameters? If so, we can't use it... (let ((parameter-ll (parameters-lambda-list ptype-entry))) (values name (if (eq (car parameter-ll) '&whole) (cddr parameter-ll) parameter-ll))))) (defmethod presentation-type-of ((object standard-object)) (multiple-value-bind (name lambda-list) (get-ptype-from-class-of object) (cond ((and name (or (null lambda-list) (member (first lambda-list) lambda-list-keywords))) name) (name 'standard-object) (t (let* ((class (class-of object)) (class-name (class-name class))) (or class-name class)))))) (defmethod presentation-type-of ((object structure-object)) (multiple-value-bind (name lambda-list) (get-ptype-from-class-of object) (if (and name (or (null lambda-list) (member lambda-list lambda-list-keywords))) name (call-next-method)))) (define-presentation-generic-function %map-over-presentation-type-supertypes map-over-presentation-type-supertypes (type-key function type)) ;;; Define the method for presentation and clos types (define-default-presentation-method map-over-presentation-type-supertypes (function type) (let ((type-name (presentation-type-name type))) (map-over-ptype-superclasses #'(lambda (super) (let ((super-name (type-name super))) (funcall function super-name (funcall (expansion-function super) (translate-specifier-for-type type-name super-name type))))) type-name))) (defun map-over-presentation-type-supertypes (function type) (funcall-presentation-generic-function map-over-presentation-type-supertypes function type)) (define-presentation-generic-function %presentation-subtypep presentation-subtypep (type-key type putative-supertype)) ;;; The semantics of the presentation method presentation-subtypep are truly ;;; weird; method combination is in effect disabled. So, the methods have to ;;; be eql methods. (defmacro define-subtypep-method (&rest args) (let ((gf (gethash 'presentation-subtypep *presentation-gf-table*))) (multiple-value-bind (qualifiers lambda-list decls body) (parse-method-body args) (let ((type-arg (nth (1- (type-arg-position gf)) lambda-list))) (unless (consp type-arg) (error "Type argument in presentation method must be specialized")) (unless (eq (car type-arg) 'type) (error "Type argument mismatch with presentation generic function definition")) (destructuring-bind (type-var type-name) type-arg (let ((method-ll `((,(type-key-arg gf) (eql (prototype-or-error ',type-name))) ,@(copy-list lambda-list)))) (setf (nth (type-arg-position gf) method-ll) type-var) `(defmethod %presentation-subtypep ,@qualifiers ,method-ll (declare (ignorable ,(type-key-arg gf)) ,@(cdr decls)) (block presentation-subtypep ,@body)))))))) ;;; PRESENTATION-SUBTYPEP suffers from some of the same problems as ;;; CL:SUBTYPEP, most (but sadly not all) of which were solved in ;;; H. Baker "A Decision Procedure for SUBTYPEP"; additionally, it ;;; suffers from the behaviour being underspecified, as CLIM ;;; documentation did not have the years of polish that CLtS did. ;;; ;;; So you might wonder why, instead of copying or using directly some ;;; decent Public Domain subtype code (such as that found in SBCL, ;;; implementing CL:SUBTYPEP), there's this slightly wonky ;;; implementation here. Well, some of the answer lies in the fact ;;; that the subtype relationships answered by this predicate are not ;;; in fact analogous to CL's type system. The major use of ;;; PRESENTATION-SUBTYPEP seems to be for determining whether a ;;; presentation is applicable as input to a translator (including the ;;; default translator, transforming an object to itself); actually, ;;; the first step is taken by STUPID-SUBTYPEP, but that I believe is ;;; simply intended to be a short-circuiting conservative version of ;;; PRESENTATION-SUBTYPEP. ;;; ;;; Most presentation types in CLIM are hierarchically arranged by ;;; single-inheritance, and SUBTYPEP relations on the hierarchy are ;;; easy to determine: simply walk up the hierarchy until you find the ;;; putative supertype (in which case the answer is T, T unless the ;;; type's parameters are wrong) or you find the universal supertype ;;; (in which case the answer is NIL, T. There are numerous wrinkles, ;;; however... ;;; ;;; (1) the NIL presentation type is the universal subtype, breaking ;;; the single-inheritance of the hierarchy. This isn't too bad, ;;; because it can be special-cased. ;;; ;;; (2) union types can be constructed, destroying the ;;; single-inheritance hierarchy (when used as a subtype). ;;; ;;; (3) union types can give rise to ambiguity. For example, is the ;;; NUMBER presentation type subtypep (OR REAL COMPLEX)? What ;;; about (INTEGER 3 6) subtypep (OR (INTEGER 3 4) (INTEGER 5 6))? ;;; Is (OR A B) subtypep (OR B A)? The answer to this last ;;; question is not obvious, as the two types have different ;;; ACCEPT behaviour if A and B have any Lisp objects in common, ;;; even if the presentation types are hierarchically unrelated... ;;; ;;; (4) intersection types can be constructed, destroying the ;;; single-inheritance hierarchy (when used as a supertype). This ;;; is partially mitigated by the explicit documentation that the ;;; first type in the AND type's parameters is privileged and ;;; treated specially by ACCEPT. ;;; ;;; Given these difficulties, I'm aiming for roughly expected ;;; behaviour from STUPID- and PRESENTATION-SUBTYPEP, rather than ;;; something which has a comprehensive understanding of presentation ;;; types and the Lisp object universe (as this would be unachievable ;;; anyway: the user can write arbitrary PRESENTATION-TYPEP ;;; functions); PRESENTATION-SUBTYPEP should not be thought of as a ;;; predicate over sets of Lisp objects, but simply a formal predicate ;;; over a graph of names. This gives rise to the implementation ;;; below for OR and AND types, and the hierarchical walk for all ;;; other types. CSR, 2007-01-10 (defun presentation-subtypep (type maybe-supertype) ;; special shortcuts: the universal subtype is privileged (and ;; doesn't in fact fit into a hierarchical lattice); the universal ;; supertype is easy to identify. (when (or (eql type nil) (eql maybe-supertype t)) (return-from presentation-subtypep (values t t))) (when (eql type maybe-supertype) (return-from presentation-subtypep (values t t))) (with-presentation-type-decoded (super-name super-parameters) maybe-supertype (with-presentation-type-decoded (type-name type-parameters) type (cond ;; DO NOT BE TEMPTED TO REARRANGE THESE CLAUSES ((eq type-name 'or) (dolist (or-type type-parameters (return-from presentation-subtypep (values t t))) (multiple-value-bind (yesp surep) (presentation-subtypep or-type maybe-supertype) (unless yesp (return-from presentation-subtypep (values yesp surep)))))) ((eq super-name 'and) (let ((result t)) (dolist (and-type super-parameters (return-from presentation-subtypep (values result result))) (cond ((and (consp and-type) (eq (car and-type) 'satisfies)) (setq result nil)) ((and (consp and-type) (eq (car and-type) 'not)) (multiple-value-bind (yp sp) (presentation-subtypep type (cadr and-type)) (if yp (return-from presentation-subtypep (values nil t)) (setq result nil)))) (t (multiple-value-bind (yp sp) (presentation-subtypep type and-type) (unless yp (if sp (return-from presentation-subtypep (values nil t)) (setq result nil))))))))) ((eq super-name 'or) (assert (not (eq type-name 'or))) ;; FIXME: this would be the right method were it not for the ;; fact that there can be unions 'in disguise' in the ;; subtype; examples: ;; (PRESENTATION-SUBTYPEP 'NUMBER '(OR REAL COMPLEX)) ;; (PRESENTATION-SUBTYPEP '(INTEGER 3 6) ;; '(OR (INTEGER 2 5) (INTEGER 4 7))) ;; Sorry about that. (let ((surep t)) (dolist (or-type super-parameters (return-from presentation-subtypep (values nil surep))) (multiple-value-bind (yp sp) (presentation-subtypep type or-type) (cond (yp (return-from presentation-subtypep (values t t))) ((not sp) (setq surep nil))))))) ((eq type-name 'and) (assert (not (eq super-name 'and))) (multiple-value-bind (yp sp) (presentation-subtypep (car type-parameters) maybe-supertype) (return-from presentation-subtypep (values yp yp)))))) (map-over-presentation-type-supertypes #'(lambda (name massaged) (when (eq name super-name) (return-from presentation-subtypep (funcall-presentation-generic-function presentation-subtypep massaged maybe-supertype)))) type)) (values nil t)) (define-default-presentation-method presentation-subtypep (type maybe-supertype) (with-presentation-type-decoded (name params) type (declare (ignore name)) (with-presentation-type-decoded (super-name super-params) maybe-supertype (declare (ignore super-name)) (if (equal params super-params) (values t t) (values nil nil))))) (define-presentation-generic-function %presentation-type-specifier-p presentation-type-specifier-p (type-class type)) (define-default-presentation-method presentation-type-specifier-p (type) t) (defun presentation-type-specifier-p (object) "Return true if `object' is a valid presentation type specifier, otherwise return false." ;; Apparently, this funtion has to handle arbitrary objects. (let ((name (presentation-type-name object))) (when (and (typep name '(or symbol class)) (get-ptype-metaclass name)) (funcall-presentation-generic-function presentation-type-specifier-p object)))) (defun default-describe-presentation-type (description stream plural-count) (if (symbolp description) (setq description (make-default-description (symbol-name description)))) (cond ((eql 1 plural-count) (format stream "~:[a~;an~] ~A" (find (char description 0) "aeiouAEIOU") description)) ((numberp plural-count) (format stream "~D ~A~P" plural-count description plural-count)) (plural-count (format stream "~As" description)) (t (write-string description stream)))) (define-presentation-generic-function %describe-presentation-type describe-presentation-type (type-key parameters options type stream plural-count )) ;;; Support for the default method on describe-presentation-type: if a CLOS ;;; class has been defined as a presentation type, get description out of the ;;; presentation type. (defmethod description ((class standard-class)) (let* ((name (class-name class)) (ptype-entry (gethash name *presentation-type-table*))) (if ptype-entry (description ptype-entry) (make-default-description name)))) (define-default-presentation-method describe-presentation-type (type stream plural-count) (with-presentation-type-decoded (name parameters options) type (declare (ignore name parameters)) (let ((description (or (getf options :description) (description (class-of type-key))))) (default-describe-presentation-type description stream plural-count)))) (defun describe-presentation-type (type &optional (stream *standard-output*) (plural-count 1)) (flet ((describe-it (stream) (funcall-presentation-generic-function describe-presentation-type type stream plural-count))) (if stream (describe-it stream) (with-output-to-string (s) (describe-it s))))) (define-presentation-generic-function %presentation-default-processor presentation-default-processor (type-key parameters default type &key default-type)) (define-default-presentation-method presentation-default-processor (default type &key (default-type nil default-type-p)) (values default (if default-type-p default-type type))) ;;; XXX The spec calls out that the presentation generic function has keyword ;;; arguments acceptably and for-context-type, but the examples I've seen don't ;;; mention them at all in the methods defined for present. So, leave them out ;;; of the generic function lambda list... (define-presentation-generic-function %present present (type-key parameters options object type stream view &key &allow-other-keys)) (defun present (object &optional (type (presentation-type-of object)) &key (stream *standard-output*) (view (stream-default-view stream)) modifier acceptably (for-context-type type) single-box (allow-sensitive-inferiors t) (sensitive t) (record-type 'standard-presentation)) (let* ((real-type (expand-presentation-type-abbreviation type)) (context-type (if (eq for-context-type type) real-type (expand-presentation-type-abbreviation for-context-type)))) (stream-present stream object real-type :view view :modifier modifier :acceptably acceptably :for-context-type context-type :single-box single-box :allow-sensitive-inferiors allow-sensitive-inferiors :sensitive sensitive :record-type record-type))) (defgeneric stream-present (stream object type &key view modifier acceptably for-context-type single-box allow-sensitive-inferiors sensitive record-type)) (defmethod stream-present ((stream output-recording-stream) object type &key (view (stream-default-view stream)) modifier acceptably (for-context-type type) single-box (allow-sensitive-inferiors t) (sensitive t) (record-type 'standard-presentation)) ;; *allow-sensitive-inferiors* controls whether or not ;; with-output-as-presentation will emit a presentation (let ((*allow-sensitive-inferiors* (and *allow-sensitive-inferiors* sensitive))) (with-output-as-presentation (stream object type :view view :modifier modifier :single-box single-box :allow-sensitive-inferiors allow-sensitive-inferiors :record-type record-type) (funcall-presentation-generic-function present object type stream view :acceptably acceptably :for-context-type for-context-type)))) ;;; Should work well enough on non-CLIM streams... (defmethod stream-present (stream object type &key (view +textual-view+) modifier acceptably (for-context-type type) single-box (allow-sensitive-inferiors t) (sensitive t) (record-type 'standard-presentation)) (declare (ignore modifier single-box allow-sensitive-inferiors sensitive record-type)) (funcall-presentation-generic-function present object type stream view :acceptably acceptably :for-context-type for-context-type) nil) (defun present-to-string (object &optional (type (presentation-type-of object)) &key (view +textual-view+) acceptably (for-context-type type) (string nil stringp) (index 0 indexp)) (let* ((real-type (expand-presentation-type-abbreviation type)) (context-type (if (eq for-context-type type) real-type (expand-presentation-type-abbreviation for-context-type)))) (when (and stringp indexp) (setf (fill-pointer string) index)) (flet ((do-present (s) (stream-present s object real-type :view view :acceptably acceptably :for-context-type context-type))) (declare (dynamic-extent #'do-present)) (let ((result (if stringp (with-output-to-string (stream string) (do-present stream)) (with-output-to-string (stream) (do-present stream))))) (if stringp (values string (fill-pointer string)) result))))) ;;; I believe this obsolete... --moore (defmethod presentation-replace-input ((stream input-editing-stream) object type view &key (buffer-start nil buffer-start-supplied-p) (rescan nil rescan-supplied-p) query-identifier (for-context-type type)) (declare (ignore query-identifier)) (let ((result (present-to-string object type :view view :acceptably nil :for-context-type for-context-type))) (apply #'replace-input stream result `(,@(and buffer-start-supplied-p `(:buffer-start ,buffer-start)) ,@(and rescan-supplied-p `(:rescan ,rescan)))))) ;;; Presentation histories. ;;; This allocates a hash table even if the frame doesn't support ;;; histories! I'm over it already. -- moore (defclass presentation-history-mixin () ((presentation-history :accessor frame-presentation-history :initform (make-hash-table :test #'eq))) (:documentation "Mixin class for frames that implements presentation type histories")) (define-presentation-generic-function %presentation-type-history presentation-type-history (type-key parameters type)) ;;; This function should exist for convenience even if not mentioned in the ;;; spec. (defun presentation-type-history (type) (funcall-presentation-generic-function presentation-type-history type)) (defclass presentation-history () ((stack :accessor presentation-history-array :initform (make-array 1 :fill-pointer 0 :adjustable t) :documentation "The history, with the newest objects at the end of the array. Should contain conses with the car being the object and the cdr being the type.") (pointer :accessor presentation-history-pointer :initform nil :documentation "The index of the \"current\" object, used when navigating the history. If NIL, means that no navigation has yet been performed.")) (:documentation "Class for objects that contain the history for a specific type.")) (define-default-presentation-method presentation-type-history (type) (if (and *application-frame* (frame-maintain-presentation-histories *application-frame*)) (with-presentation-type-decoded (name) type (let* ((ptype (get-ptype-metaclass name)) (history (history ptype))) (case history ((t) (let* ((history-table (frame-presentation-history *application-frame*)) (history-object (gethash name history-table))) (unless history-object (setf history-object (make-instance 'presentation-history) (gethash name history-table) history-object)) history-object)) (nil nil) (otherwise (funcall-presentation-generic-function presentation-type-history type))))))) ;;; Not in the spec, but I think this is necessary (or at any rate, the easiest ;;; way) to control whether or not to use histories in a given context. (define-presentation-generic-function %presentation-type-history-for-stream presentation-type-history-for-stream (type-key parameters type stream) (:documentation "Returns a type history or nil for a presentation TYPE and STREAM. This is used by McCLIM to decide whether or not to use histories in a given situation. A primary method specialized on just the type should call-next-method to get the \"real\" answer based on the stream type.")) (define-default-presentation-method presentation-type-history-for-stream (type stream) (declare (ignore stream)) nil) ;;; method for clim-stream-pane in panes.lisp (define-presentation-method presentation-type-history-for-stream ((type t) (stream input-editing-stream)) ;; What is the purpose of this? Makes stuff harder to do, so ;; commented out... ;;(if (not (stream-rescanning-p stream)) ;; (funcall-presentation-generic-function presentation-type-history type) ;; nil) (funcall-presentation-generic-function presentation-type-history type)) (defun presentation-history-insert (history object ptype) "Unconditionally insert `object' as an input of presentation type `type' at the top of the presentation history `history', as the most recently added object." (vector-push-extend (cons object ptype) (presentation-history-array history))) (defun presentation-history-top (history ptype) "Find the topmost (most recently added object) of `history' that is of the presentation type `ptype' or a subtype. Two values will be returned, the object and the presentation type of the object. If no applicable object can be found, these values will both be NIL." (loop with array = (presentation-history-array history) for index from (1- (fill-pointer array)) downto 0 for (object . object-ptype) = (aref array index) do (when (presentation-subtypep object-ptype ptype) (return (aref array index))) finally (return (values nil nil)))) (defun presentation-history-reset-pointer (history) "Set the pointer to point at the object most recently added object." (setf (presentation-history-pointer history) nil)) (defun presentation-history-next (history ptype) "Go to the next input (forward in time) in `history' that is a presentation-subtype of `ptype', respective to the pointer in `history'. Returns two values: the found object and its presentation type, both of which will be NIL if no applicable object can be found." (with-accessors ((pointer presentation-history-pointer) (array presentation-history-array)) history ;; If no navigation has been performed, we have no object to go ;; forwards to. (if (or (null pointer) (>= (1+ pointer) (length array))) (values nil nil) (progn (incf pointer) (destructuring-bind (object . object-ptype) (aref array pointer) (if object-ptype (if (presentation-subtypep object-ptype ptype) (values object object-ptype) (presentation-history-next history ptype)) (values nil nil))))))) (defun presentation-history-previous (history ptype) "Go to the previous input (backward in time) in `history' that is a presentation-subtype of `ptype', respective to the pointer in `history'. Returns two values: the found object and its presentation type, both of which will be NIL if no applicable object can be found." (with-accessors ((pointer presentation-history-pointer) (array presentation-history-array)) history (if (and (numberp pointer) (zerop pointer)) (values nil nil) (progn (cond ((and (numberp pointer) (plusp pointer)) (decf pointer)) ((plusp (length array)) (setf pointer (1- (fill-pointer array))))) (if (and (numberp pointer) (array-in-bounds-p array pointer)) (destructuring-bind (object . object-ptype) (aref array pointer) (if object-ptype (if (presentation-subtypep object-ptype ptype) (values object object-ptype) (progn (presentation-history-previous history ptype))) (values nil nil))) (values nil nil)))))) (defmacro with-object-on-history ((history object ptype) &body body) "Evaluate `body' with `object' as `ptype' as the head (most recently added object) on `history', and remove it again after `body' has run. If `body' as `ptype' is already the head, the history will be unchanged." (with-gensyms (added) `(let ((,added (presentation-history-add ,history ,object ,ptype))) (unwind-protect (progn ,@body) (when ,added (decf (fill-pointer (presentation-history-array ,history)))))))) (defun presentation-history-add (history object ptype) "Add OBJECT and PTYPE to the HISTORY unless they are already at the head of HISTORY" (multiple-value-bind (top-object top-ptype) (presentation-history-top history ptype) (unless (and top-ptype (eql object top-object) (equal ptype top-ptype)) (presentation-history-insert history object ptype)))) (define-presentation-generic-function %accept accept (type-key parameters options type stream view &key)) (defvar *recursive-accept-p* nil) (defvar *recursive-accept-1-p* nil) (defvar *active-history-type* nil) ;;; The spec says "default-type most be a presentation type specifier", but the ;;; examples we have imply that default-type is optional, so we'll be liberal ;;; in what we accept. (defun accept (type &rest rest-args &key (stream *standard-input*) (view nil viewp) (default nil defaultp) (default-type nil default-type-p) provide-default insert-default replace-input (history nil historyp) ; true default supplied below active-p ; Don't think this will be used prompt prompt-mode display-default query-identifier activation-gestures additional-activation-gestures delimiter-gestures additional-delimiter-gestures) (declare (ignore insert-default replace-input active-p prompt prompt-mode display-default query-identifier activation-gestures additional-activation-gestures delimiter-gestures additional-delimiter-gestures)) (handler-bind ((abort-gesture (lambda (condition) (signal condition) ;; to give outer handlers a chance to say "I know how to handle this" (abort condition)))) (let* ((real-type (expand-presentation-type-abbreviation type)) (real-default-type (cond (default-type-p (expand-presentation-type-abbreviation default-type)) ((or defaultp provide-default) real-type) (t nil))) (real-history-type (cond ((null historyp) real-type) ((null history) nil) (t (expand-presentation-type-abbreviation history)))) (*recursive-accept-p* *recursive-accept-1-p*) (*recursive-accept-1-p* t)) (with-keywords-removed (rest-args (:stream)) (when (or default-type-p defaultp) (setf rest-args (list* :default-type real-default-type rest-args))) (when historyp (setf rest-args (list* :history real-history-type rest-args))) (cond ((and viewp (symbolp view)) (setf rest-args (list* :view (funcall #'make-instance view) rest-args))) ((consp view) (setf rest-args (list* :view (apply #'make-instance view) rest-args)))) ;; Presentation type history interaction. According to the spec, ;; if provide-default is true, we take the default from the ;; presentation history. In addition, we'll implement the Genera ;; behavior of temporarily putting the default on the history ;; stack so the user can conveniently suck it in. (labels ((get-history () (when real-history-type (funcall-presentation-generic-function presentation-type-history-for-stream real-history-type stream))) (do-accept (args) (apply #'stream-accept stream real-type args))) (let* ((default-from-history (and (not defaultp) provide-default)) (history (get-history)) (results (multiple-value-list (if history (unwind-protect (let ((*active-history-type* real-history-type)) (cond (defaultp (with-object-on-history (history default real-default-type) (do-accept rest-args))) (default-from-history (multiple-value-bind (history-default history-type) (presentation-history-top history real-default-type) (do-accept (if history-type (list* :default history-default :default-type history-type rest-args) rest-args)))) (t (do-accept rest-args)))) (unless *recursive-accept-p* (presentation-history-reset-pointer (get-history)))) (do-accept rest-args)))) (results-history (get-history))) (when results-history (presentation-history-add results-history (car results) real-type)) (values-list results))))))) (defmethod stream-accept ((stream standard-extended-input-stream) type &rest args &key (view (stream-default-view stream)) &allow-other-keys) (apply #'prompt-for-accept stream type view args) (apply #'accept-1 stream type args)) (defmethod stream-accept ((stream #.*string-input-stream-class*) type &key (view (stream-default-view stream)) (default nil defaultp) (default-type nil default-type-p) (activation-gestures nil activationsp) (additional-activation-gestures nil additional-activations-p) (delimiter-gestures nil delimitersp) (additional-delimiter-gestures nil additional-delimiters-p) &allow-other-keys) (with-activation-gestures ((if additional-activations-p additional-activation-gestures activation-gestures) :override activationsp) (with-delimiter-gestures ((if additional-delimiters-p additional-delimiter-gestures delimiter-gestures) :override delimitersp) (multiple-value-bind (object object-type) (apply-presentation-generic-function accept type stream view `(,@(and defaultp `(:default ,default)) ,@(and default-type-p `(:default-type ,default-type)))) (values object (or object-type type)))))) (defun accept-1 (stream type &key (view (stream-default-view stream)) (default nil defaultp) (default-type nil default-type-p) provide-default insert-default (replace-input t) history active-p prompt prompt-mode display-default query-identifier (activation-gestures nil activationsp) (additional-activation-gestures nil additional-activations-p) (delimiter-gestures nil delimitersp) (additional-delimiter-gestures nil additional-delimiters-p)) (declare (ignore provide-default history active-p prompt prompt-mode display-default query-identifier)) (when (and defaultp (not default-type-p)) (error ":default specified without :default-type")) (when (and activationsp additional-activations-p) (error "only one of :activation-gestures or ~ :additional-activation-gestures may be passed to accept.")) (unless (or activationsp additional-activations-p *activation-gestures*) (setq activation-gestures *standard-activation-gestures*)) (let ((sensitizer-object nil) (sensitizer-type nil)) (with-input-editing (stream :input-sensitizer #'(lambda (stream cont) (with-output-as-presentation (stream sensitizer-object sensitizer-type) (declare (ignore stream)) (funcall cont)))) (with-input-position (stream) ; support for calls to replace-input (when (and insert-default (not (stream-rescanning-p stream))) ;; Insert the default value to the input stream. It should ;; become fully keyboard-editable. We do not want to insert ;; the default if we're rescanning, only during initial ;; setup. (presentation-replace-input stream default default-type view)) (setf (values sensitizer-object sensitizer-type) (with-input-context (type) (object object-type event options) (with-activation-gestures ((if additional-activations-p additional-activation-gestures activation-gestures) :override activationsp) (with-delimiter-gestures ((if additional-delimiters-p additional-delimiter-gestures delimiter-gestures) :override delimitersp) (let ((accept-results nil)) (handle-empty-input (stream) (setq accept-results (multiple-value-list (if defaultp (funcall-presentation-generic-function accept type stream view :default default :default-type default-type) (funcall-presentation-generic-function accept type stream view)))) ;; User entered activation or delimiter ;; gesture without any input. (if defaultp (progn (presentation-replace-input stream default default-type view :rescan nil)) (simple-parse-error "Empty input for type ~S with no supplied default" type)) (setq accept-results (list default default-type))) ;; Eat trailing activation gesture ;; XXX what about pointer gestures? ;; XXX and delimiter gestures? (unless *recursive-accept-p* (let ((ag (read-char-no-hang stream nil stream t))) (unless (or (null ag) (eq ag stream)) (unless (activation-gesture-p ag) (unread-char ag stream))))) (values (car accept-results) (if (cdr accept-results) (cadr accept-results) type))))) ;; A presentation was clicked on, or something (t (when (and replace-input (getf options :echo t) (not (stream-rescanning-p stream))) (presentation-replace-input stream object object-type view :rescan nil)) (values object object-type)))) ;; Just to make it clear that we're returning values (values sensitizer-object sensitizer-type))))) (defmethod prompt-for-accept ((stream t) type view &rest accept-args &key &allow-other-keys) (declare (ignore view)) (apply #'prompt-for-accept-1 stream type accept-args)) (defun prompt-for-accept-1 (stream type &key (default nil defaultp) (default-type type) (insert-default nil) (prompt t) (prompt-mode :normal) (display-default prompt) &allow-other-keys) (flet ((display-using-mode (stream prompt default) (ecase prompt-mode (:normal (if *recursive-accept-p* (input-editor-format stream "(~A~@[[~A]~]) " prompt default) (input-editor-format stream "~A~@[[~A]~]: " prompt default))) (:raw (input-editor-format stream "~A" prompt))))) (let ((prompt-string (if (eq prompt t) (format nil "~:[Enter ~;~]~A" *recursive-accept-p* (describe-presentation-type type nil nil)) prompt)) ;; Don't display the default in the prompt if it is to be ;; inserted into the input stream. (default-string (and defaultp (not insert-default) display-default (present-to-string default default-type)))) (cond ((null prompt) nil) (t (display-using-mode stream prompt-string default-string)))))) (defmethod prompt-for-accept ((stream #.*string-input-stream-class*) type view &rest other-args &key &allow-other-keys) (declare (ignore type view other-args)) nil) ;;; For ACCEPT-FROM-STRING, use this barebones input-editing-stream. (defclass string-input-editing-stream (input-editing-stream fundamental-character-input-stream) ((input-buffer :accessor stream-input-buffer) (insertion-pointer :accessor stream-insertion-pointer :initform 0 :documentation "This is not used for anything at any point.") (scan-pointer :accessor stream-scan-pointer :initform 0 :documentation "This is not used for anything at any point.")) (:documentation "An implementation of the input-editing stream protocol retrieving gestures from a provided string.")) (defmethod initialize-instance :after ((stream string-input-editing-stream) &key (string (error "A string must be provided")) (start 0) (end (length string)) &allow-other-keys) (setf (stream-input-buffer stream) (replace (make-array (- end start) :fill-pointer (- end start)) string :start2 start :end2 end))) (defmethod stream-element-type ((stream string-input-editing-stream)) 'character) (defmethod close ((stream string-input-editing-stream) &key abort) (declare (ignore abort))) (defmethod stream-peek-char ((stream string-input-editing-stream)) (or (stream-read-gesture stream :peek-p t) :eof)) (defmethod stream-read-char-no-hang ((stream string-input-editing-stream)) (if (> (stream-scan-pointer stream) (length (stream-input-buffer stream))) :eof (stream-read-gesture stream))) (defmethod stream-read-char ((stream string-input-editing-stream)) (stream-read-gesture stream)) (defmethod stream-listen ((stream string-input-editing-stream)) (< (stream-scan-pointer stream) (length (stream-input-buffer stream)))) (defmethod stream-unread-char ((stream string-input-editing-stream) char) (stream-unread-gesture stream char)) (defmethod invoke-with-input-editor-typeout ((stream string-input-editing-stream) continuation &key erase) (declare (ignore erase))) (defmethod input-editor-format ((stream string-input-editing-stream) format-string &rest args) (declare (ignore args))) (defmethod stream-rescanning-p ((stream string-input-editing-stream)) t) (defmethod reset-scan-pointer ((stream string-input-editing-stream) &optional scan-pointer) (declare (ignore scan-pointer))) (defmethod immediate-rescan ((stream string-input-editing-stream))) (defmethod queue-rescan ((stream string-input-editing-stream))) (defmethod rescan-if-necessary ((stream string-input-editing-stream) &optional inhibit-activation) (declare (ignore inhibit-activation))) (defmethod erase-input-buffer ((stream string-input-editing-stream) &optional start-position) (declare (ignore start-position))) (defmethod redraw-input-buffer ((stream string-input-editing-stream) &optional start-position) (declare (ignore start-position))) (defmethod stream-process-gesture ((stream string-input-editing-stream) gesture type) (when (characterp gesture) (values gesture type))) (defmethod stream-read-gesture ((stream string-input-editing-stream) &key peek-p &allow-other-keys) (unless (> (stream-scan-pointer stream) (length (stream-input-buffer stream))) (prog1 (if (= (stream-scan-pointer stream) (length (stream-input-buffer stream))) (second (first (gethash (first *activation-gestures*) climi::*gesture-names*))) ; XXX - will always be non-NIL? (aref (stream-input-buffer stream) (stream-scan-pointer stream))) (unless peek-p (incf (stream-scan-pointer stream)))))) (defmethod stream-unread-gesture ((stream string-input-editing-stream) gesture) (decf (stream-scan-pointer stream))) (defmethod stream-accept ((stream string-input-editing-stream) type &rest args) (apply #'accept-1 stream type args)) ;;; XXX This needs work! It needs to do everything that accept does for ;;; expanding ptypes and setting up recursive call procesusing (defun accept-from-string (type string &rest args &key view (default nil defaultp) (default-type nil default-type-p) (activation-gestures nil activationsp) (additional-activation-gestures nil additional-activations-p) (delimiter-gestures nil delimitersp) (additional-delimiter-gestures nil additional-delimiters-p) (start 0) (end (length string))) (declare (ignore view)) ;; XXX work in progress here. (with-activation-gestures ((if additional-activations-p additional-activation-gestures activation-gestures) :override activationsp) (with-delimiter-gestures ((if additional-delimiters-p additional-delimiter-gestures delimiter-gestures) :override delimitersp))) (when (zerop (- end start)) (if defaultp (return-from accept-from-string (values default (if default-type-p default-type type) 0)) (simple-parse-error "Empty string"))) (let ((stream (make-instance 'string-input-editing-stream :string string :start start :end end))) (multiple-value-bind (val ptype) (with-keywords-removed (args (:start :end)) (apply #'stream-accept stream type :history nil :view +textual-view+ args)) (values val ptype (+ (stream-scan-pointer stream) start))))) (define-presentation-generic-function %presentation-refined-position-test presentation-refined-position-test (type-key parameters options type record x y)) (define-default-presentation-method presentation-refined-position-test (type record x y) (declare (ignore type)) ;;; output-record-hit-detection-rectangle* has already been called (let ((single-box (presentation-single-box record))) (if (or (eq single-box t) (eq single-box :position)) t (labels ((tester (record) (typecase record (displayed-output-record (return-from presentation-refined-position-test t)) (compound-output-record (map-over-output-records-containing-position #'tester record x y)) (t nil)))) (tester record) nil)))) (defun presentation-contains-position (record x y) (let ((single-box (presentation-single-box record))) (multiple-value-bind (min-x min-y max-x max-y) (output-record-hit-detection-rectangle* record) (if (and (<= min-x x max-x) (<= min-y y max-y)) (if (or (null single-box) (eq single-box :highlighting)) (funcall-presentation-generic-function presentation-refined-position-test (presentation-type record) record x y) t) nil)))) (define-presentation-generic-function %highlight-presentation highlight-presentation (type-key parameters options type record stream state)) ;;; Internal function to highlight just one presentation (defun highlight-presentation-1 (presentation stream state) (with-output-recording-options (stream :record nil) (funcall-presentation-generic-function highlight-presentation (presentation-type presentation) presentation stream state))) (defgeneric highlight-output-record-tree (record stream state)) (defmethod highlight-output-record-tree (record stream state) (declare (ignore record stream state)) (values)) (defmethod highlight-output-record-tree ((record compound-output-record) stream state) (map-over-output-records (lambda (record) (highlight-output-record-tree record stream state)) record)) (defmethod highlight-output-record-tree ((record displayed-output-record) stream state) (highlight-output-record record stream state)) (define-default-presentation-method highlight-presentation (type record stream state) (declare (ignore type)) (if (or (eq (presentation-single-box record) t) (eq (presentation-single-box record) :highlighting)) (highlight-output-record record stream state) (highlight-output-record-tree record stream state))) (define-default-presentation-method present (object type stream (view textual-view) &key acceptably for-context-type) (declare (ignore for-context-type type)) (if acceptably (let ((*print-readably* t)) (prin1 object stream)) (princ object stream))) (defun accept-using-read (stream ptype &key ((:read-eval *read-eval*) nil)) (let* ((token (read-token stream))) (let ((result (handler-case (read-from-string token) (error (c) (declare (ignore c)) (simple-parse-error "Error parsing ~S for presentation type ~S" token ptype))))) (if (presentation-typep result ptype) (values result ptype) (input-not-of-required-type result ptype))))) (defun accept-using-completion (type stream func &rest complete-with-input-key-args) "A wrapper around complete-with-input that returns the presentation type with the completed object." (multiple-value-bind (object success input) (apply #'complete-input stream func complete-with-input-key-args) (if success (values object type) (simple-parse-error "Error parsing ~S for presentation type ~S" input type)))) ;;; When no accept method has been defined for a type, allow some kind of ;;; input. The accept can be satisfied with pointer input, of course, and this ;;; allows the clever user a way to input the type at the keyboard, using #. or ;;; some other printed representation. ;;; ;;; XXX Once we "go live" we probably want to disable this, probably with a ;;; beep and warning that input must be clicked on. (define-default-presentation-method accept (type stream (view textual-view) &key default default-type) (declare (ignore default default-type)) (accept-using-read stream type :read-eval t)) ;;; The presentation types (define-presentation-method presentation-typep (object (type t)) (declare (ignore object)) t) (define-presentation-method present (object (type t) stream (view textual-view) &key acceptably for-context-type) (declare (ignore for-context-type)) (let ((*print-readably* acceptably)) (if acceptably (prin1 object stream) (princ object stream)))) (define-presentation-type nil ()) (define-presentation-method presentation-typep (object (type nil)) (declare (ignore object)) nil) (define-presentation-type null () :inherit-from t) (define-presentation-method presentation-typep (object (type null)) (eq object nil)) (define-presentation-method present (object (type null) stream (view textual-view) &key acceptably for-context-type) (declare (ignore object acceptably for-context-type)) (write-string "None" stream)) (define-presentation-method accept ((type null) stream (view textual-view) &key) (values (completing-from-suggestions (stream) (suggest "None" nil) (suggest "" nil)))) (define-presentation-type boolean () :inherit-from t) (define-presentation-method presentation-typep (object (type boolean)) (or (eq object t) (eq object nil))) (define-presentation-method present (object (type boolean) stream (view textual-view) &key acceptably for-context-type) (declare (ignore acceptably for-context-type)) (if object (write-string "Yes" stream) (write-string "No" stream))) (define-presentation-method accept ((type boolean) stream (view textual-view) &key) (accept-using-completion 'boolean stream #'(lambda (input-string mode) (complete-from-possibilities input-string '(("yes" t) ("no" nil)) nil :action mode)))) (define-presentation-type symbol () :inherit-from 't) (define-presentation-method presentation-typep (object (type symbol)) (symbolp object)) (define-presentation-method present (object (type symbol) stream (view textual-view) &key acceptably for-context-type) (declare (ignore for-context-type)) (if acceptably (prin1 object stream) (princ object stream))) (define-presentation-method accept ((type symbol) stream (view textual-view) &key) (accept-using-read stream type)) (define-presentation-type keyword () :inherit-from 'symbol) (define-presentation-method presentation-typep (object (type keyword)) (keywordp object)) (define-presentation-method present (object (type keyword) stream (view textual-view) &key acceptably for-context-type) (declare (ignore acceptably for-context-type)) (prin1 object stream)) (defmethod presentation-type-of ((object symbol)) (if (eq (symbol-package object) (find-package :keyword)) 'keyword 'symbol)) (define-presentation-type blank-area () :inherit-from t) (define-presentation-method highlight-presentation ((type blank-area) record stream state) (declare (ignore record stream state)) nil) ;;; Do other slots of this have to be bound in order for this to be useful? ;;; Guess we'll see. (defparameter *null-presentation* (make-instance 'standard-presentation :object nil :type 'blank-area :view +textual-view+)) (define-presentation-type number () :inherit-from 't) (define-presentation-method presentation-typep (object (type number)) (numberp object)) (defmethod presentation-type-of ((object number)) 'number) (define-presentation-type complex (&optional (type 'real)) :inherit-from 'number) (define-presentation-method presentation-typep (object (type complex)) (and (complexp object) (typep (realpart object) type) (typep (imagpart object) type))) (define-presentation-method presentation-subtypep ((type complex) maybe-supertype) (with-presentation-type-parameters (complex type) (let ((component-type type)) ;i.e., the parameter named "type" (with-presentation-type-parameters (complex maybe-supertype) (let ((super-component-type type)) (presentation-subtypep component-type super-component-type)))))) (defmethod presentation-type-of ((object complex)) 'complex) (define-presentation-method present (object (type complex) stream (view textual-view) &key acceptably for-context-type) (declare (ignore acceptably for-context-type)) (present (realpart object) (presentation-type-of (realpart object)) :stream stream :view view :sensitive nil) (write-char #\Space stream) (present (imagpart object) (presentation-type-of (imagpart object)) :stream stream :view view :sensitive nil)) (define-presentation-type real (&optional low high) :options ((base 10) radix) :inherit-from 'number) (define-presentation-method presentation-typep (object (type real)) (and (realp object) (or (eq low '*) (<= low object)) (or (eq high '*) (<= object high)))) (defmethod presentation-type-of ((object real)) 'real) (define-presentation-method present (object (type real) stream (view textual-view) &key acceptably for-context-type) (declare (ignore acceptably for-context-type)) (let ((*print-base* base) (*print-radix* radix)) (princ object stream))) (define-presentation-method accept ((type real) stream (view textual-view) &key) (let ((*read-base* base)) (accept-using-read stream type))) ;;; Define a method that will do the comparision for all real types. It's ;;; already determined that that the numeric class of type is a subtype of ;;;supertype. (defun number-subtypep (low high super-low super-high) (if (eq low '*) (unless (eq super-low '*) (return-from number-subtypep nil)) (unless (or (eq super-low '*) (>= low super-low)) (return-from number-subtypep nil))) (if (eq high '*) (unless (eq super-high '*) (return-from number-subtypep nil)) (unless (or (eq super-high '*) (<= high super-high)) (return-from number-subtypep nil))) t) (define-presentation-type rational (&optional low high) :options ((base 10) radix) :inherit-from `((real ,low ,high) :base ,base :radix ,radix)) (define-presentation-method presentation-typep (object (type rational)) (and (rationalp object) (or (eq low '*) (<= low object)) (or (eq high '*) (<= object high)))) (defmethod presentation-type-of ((object rational)) 'rational) (define-presentation-method present (object (type rational) stream (view textual-view) &key acceptably for-context-type) (declare (ignore acceptably for-context-type)) (let ((*print-base* base) (*print-radix* radix)) (princ object stream))) (define-presentation-type integer (&optional low high) :options ((base 10) radix) :inherit-from `((rational ,low ,high) :base ,base :radix ,radix)) (define-presentation-method presentation-typep (object (type integer)) (and (integerp object) (or (eq low '*) (<= low object)) (or (eq high '*) (<= object high)))) (defmethod presentation-type-of ((object integer)) 'integer) (define-presentation-method present (object (type integer) stream (view textual-view) &key acceptably for-context-type) (declare (ignore acceptably for-context-type)) (let ((*print-base* base) (*print-radix* radix)) (princ object stream))) (define-presentation-type ratio (&optional low high) :options ((base 10) radix) :inherit-from `((rational ,low ,high) :base ,base :radix ,radix)) (define-presentation-method presentation-typep (object (type ratio)) (and (not (integerp object)) (rationalp object) (or (eq low '*) (<= low object)) (or (eq high '*) (<= object high)))) (defmethod presentation-type-of ((object ratio)) 'ratio) (define-presentation-method present (object (type ratio) stream (view textual-view) &key acceptably for-context-type) (declare (ignore acceptably for-context-type)) (let ((*print-base* base) (*print-radix* radix)) (princ object stream))) (define-presentation-type float (&optional low high) :options ((base 10) radix) :inherit-from `((real ,low ,high) :base ,base :radix ,radix)) (define-presentation-method presentation-typep (object (type float)) (and (floatp object) (or (eq low '*) (<= low object)) (or (eq high '*) (<= object high)))) (defmethod presentation-type-of ((object float)) 'float) (define-presentation-method present (object (type float) stream (view textual-view) &key acceptably for-context-type) (declare (ignore acceptably for-context-type)) (let ((*print-base* base) (*print-radix* radix)) (princ object stream))) (macrolet ((frob (num-type) `(define-presentation-method presentation-subtypep ((type ,num-type) maybe-supertype) (with-presentation-type-parameters (,num-type maybe-supertype) (let ((super-low low) (super-high high)) (with-presentation-type-parameters (,num-type type) (values (number-subtypep low high super-low super-high) t))))))) (frob real) (frob rational) (frob ratio) (frob float)) (define-presentation-type character () :inherit-from 't) (define-presentation-method presentation-typep (object (type character)) (characterp object)) (defmethod presentation-type-of ((object character)) 'character) (define-presentation-method present (object (type character) stream (view textual-view) &key acceptably for-context-type) (declare (ignore acceptably for-context-type)) (princ object stream)) (define-presentation-type string (&optional length) :inherit-from 't) (define-presentation-method presentation-typep (object (type string)) (and (stringp object) (or (eq length '*) (eql (length object) length)))) (define-presentation-method presentation-subtypep ((type string) maybe-supertype) (with-presentation-type-parameters (string maybe-supertype) (let ((super-length length)) (with-presentation-type-parameters (string type) (values (or (eq super-length '*) (eql length super-length)) t))))) ;;; `(string ,length) would be more specific, but is not "likely to be useful ;;; to the programmer." (defmethod presentation-type-of ((object string)) 'string) (define-presentation-method present (object (type string) stream (view textual-view) &key acceptably for-context-type) (declare (ignore for-context-type)) (if acceptably (prin1 object stream) (princ object stream))) (define-presentation-method accept ((type string) stream (view textual-view) &key (default nil defaultp) (default-type type)) (let ((result (read-token stream))) (cond ((numberp length) (if (eql length (length result)) (values result type) (input-not-of-required-type result type))) ((and (zerop (length result)) defaultp) (values default default-type)) (t (values result type))))) (define-presentation-type pathname () :options ((default-version :newest) default-type (merge-default t)) :inherit-from 't) (define-presentation-method presentation-typep (object (type pathname)) (pathnamep object)) (define-presentation-method present ((object pathname) (type pathname) stream (view textual-view) &key) ;; XXX: We can only visually represent the pathname if it has a name ;; - making it wild is a compromise. If the pathname is completely ;; blank, we leave it as-is, though. ;; The above comment was meant to indicate that if the pathname had ;; neither a name NOR a directory, then it couldn't be visually ;; represented. Some discussion has ensued on the possbility of ;; emitting something like "A pathname of type " ;; [2007/01/08:rpg] (let ((pathname (if (equal object #.(make-pathname)) object (merge-pathnames object (make-pathname :name :wild))))) (princ object stream)) ) (define-presentation-method present ((object string) (type pathname) stream (view textual-view) &rest args &key) (apply-presentation-generic-function present (pathname object) type stream view args)) (defmethod presentation-type-of ((object pathname)) 'pathname) (defun filename-completer (so-far mode) (let* ((directory-prefix (if (and (plusp (length so-far)) (eql (aref so-far 0) #\/)) "" (namestring #+sbcl *default-pathname-defaults* #+cmu (ext:default-directory) #-(or sbcl cmu) *default-pathname-defaults*))) (full-so-far (concatenate 'string directory-prefix so-far)) (pathnames (loop with length = (length full-so-far) and wildcard = (format nil "~A*.*" (loop for start = 0 ; Replace * -> \* for occurence = (position #\* so-far :start start) until (= start (length so-far)) until (null occurence) do (replace so-far "\\*" :start1 occurence) (setf start (+ occurence 2)) finally (return so-far))) for path in #+(or sbcl cmu lispworks) (directory wildcard) #+openmcl (directory wildcard :directories t) #+allegro (directory wildcard :directories-are-files nil) #+cormanlisp (nconc (directory wildcard) (cl::directory-subdirs dirname)) #-(or sbcl cmu lispworks openmcl allegro cormanlisp) (directory wildcard) when (let ((mismatch (mismatch (namestring path) full-so-far))) (or (null mismatch) (= mismatch length))) collect path)) (strings (mapcar #'namestring pathnames)) (first-string (car strings)) (length-common-prefix nil) (completed-string nil) (full-completed-string nil) (input-is-directory-p (when (plusp (length so-far)) (char= (aref so-far (1- (length so-far))) #\/)))) (unless (null pathnames) (setf length-common-prefix (loop with length = (length first-string) for string in (cdr strings) do (setf length (min length (or (mismatch string first-string) length))) finally (return length)))) (unless (null pathnames) (setf completed-string (subseq first-string (length directory-prefix) (if (null (cdr pathnames)) nil length-common-prefix))) (setf full-completed-string (concatenate 'string directory-prefix completed-string))) (case mode ((:complete-limited :complete-maximal) (cond ((null pathnames) (values so-far nil nil 0 nil)) ((null (cdr pathnames)) (values completed-string (plusp (length so-far)) (car pathnames) 1 nil)) (input-is-directory-p (values completed-string t (parse-namestring so-far) (length pathnames) nil)) (t (values completed-string nil nil (length pathnames) nil)))) (:complete ;; This is reached when input is activated, if we did ;; completion, that would mean that an input of "foo" would ;; be expanded to "foobar" if "foobar" exists, even if the ;; user actually *wants* the "foo" pathname (to create the ;; file, for example). (values so-far t so-far 1 nil)) (:possibilities (values nil nil nil (length pathnames) (loop with length = (length directory-prefix) for name in pathnames collect (list (subseq (namestring name) length nil) name))))))) (define-presentation-method accept ((type pathname) stream (view textual-view) &key (default *default-pathname-defaults* defaultp) ((:default-type accept-default-type) type)) (multiple-value-bind (pathname success string) (complete-input stream #'filename-completer :allow-any-input t) (cond ((and pathname success) (values (if merge-default (progn (unless (or (pathname-type pathname) (null default-type)) (setf pathname (make-pathname :defaults pathname :type default-type))) (merge-pathnames pathname default default-version)) pathname) type)) ((and (zerop (length string)) defaultp) (values default accept-default-type)) (t (values string 'string))))) (defmethod presentation-replace-input :around ((stream input-editing-stream) (object pathname) (type (eql 'pathname)) view &rest args &key &allow-other-keys) ;; This is fully valid and compliant, but it still smells slightly ;; like a hack. (let ((name (pathname-name object)) (directory (when (pathname-directory object) (directory-namestring object))) (type (pathname-type object)) (string "") (old-insp (stream-insertion-pointer stream))) (setf string (or directory string)) (setf string (concatenate 'string string (cond ((and name type) (file-namestring object)) (name name) (type (subseq (namestring (make-pathname :name " " :type type)) 1))))) (apply #'replace-input stream string args) (when directory (setf (stream-insertion-pointer stream) (+ old-insp (if directory (length directory) 0))) ;; If we moved the insertion pointer, this might be a good idea. (redraw-input-buffer stream old-insp)))) (defgeneric default-completion-name-key (item)) (defmethod default-completion-name-key ((item string)) item) (defmethod default-completion-name-key ((item null)) "NIL") (defmethod default-completion-name-key ((item cons)) (string (car item))) (defmethod default-completion-name-key ((item symbol)) (string-capitalize (symbol-name item))) (defmethod default-completion-name-key (item) (princ-to-string item)) (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +completion-options+ '((name-key 'default-completion-name-key) documentation-key (partial-completers '(#\Space))))) (define-presentation-type completion (sequence &key (test 'eql) (value-key 'identity)) :options #.+completion-options+ :inherit-from t) (define-presentation-method presentation-typep (object (type completion)) (map nil #'(lambda (obj) (when (funcall test object (funcall value-key obj)) (return-from presentation-typep t))) sequence) nil) ;;; Useful for subtype comparisons for several of the "member" style types (defun sequence-subset-p (seq1 test1 value-key1 seq2 test2 value-key2) (let ((test-fun (if (eq test1 test2) test1 ;; The object has to pass both type's equality test #'(lambda (obj1 obj2) (and (funcall test1 obj1 obj2) (funcall test2 obj1 obj2)))))) (map nil #'(lambda (type-obj) (unless (find (funcall value-key1 type-obj) seq2 :test test-fun :key value-key2) (return-from sequence-subset-p nil))) seq1) t)) (define-presentation-method presentation-subtypep ((type completion) maybe-supertype) (with-presentation-type-parameters (completion maybe-supertype) (let ((super-sequence sequence) (super-test test) (super-value-key value-key)) (with-presentation-type-parameters (completion type) (values (sequence-subset-p sequence test value-key super-sequence super-test super-value-key) t))))) (define-presentation-method present (object (type completion) stream (view textual-view) &key acceptably for-context-type) (declare (ignore acceptably for-context-type)) (let ((obj-pos (position object sequence :test test :key value-key))) (if obj-pos (write-string (funcall name-key (elt sequence obj-pos)) stream) ;; Should define a condition type here. (error "~S is not of presentation type ~S" object type)))) (define-presentation-method accept ((type completion) stream (view textual-view) &key) (accept-using-completion (make-presentation-type-specifier `(completion ,@parameters) options) stream #'(lambda (input-string mode) (complete-from-possibilities input-string sequence partial-completers :action mode :name-key name-key :value-key value-key)) :partial-completers partial-completers)) (define-presentation-type-abbreviation member (&rest elements) (make-presentation-type-specifier `(completion ,elements) :name-key name-key :documentation-key documentation-key :partial-completers partial-completers) :options #.+completion-options+) (define-presentation-type-abbreviation member-sequence (sequence &key (test 'eql testp)) (make-presentation-type-specifier `(completion ,sequence ,@(and testp `(:test ,test))) :name-key name-key :documentation-key documentation-key :partial-completers partial-completers) :options #.+completion-options+) (defun member-alist-value-key (element) (cond ((atom element) element) ((atom (cdr element)) (cdr element)) ((null (cddr element)) (cadr element)) (t (getf (cdr element) :value)))) (defun member-alist-doc-key (element) (if (and (consp element) (consp (cdr element)) (consp (cddr element))) (getf (cdr element) :documentation))) (define-presentation-type-abbreviation member-alist (alist &key (test 'eql testp)) (make-presentation-type-specifier `(completion ,alist ,@(and testp `(:test ,test)) :value-key member-alist-value-key) :name-key name-key :documentation-key documentation-key :partial-completers partial-completers) :options ((name-key 'default-completion-name-key) (documentation-key 'member-alist-doc-key) (partial-completers '(#\Space)))) (define-presentation-type subset-completion (sequence &key (test 'eql) (value-key 'identity)) :options ((name-key 'default-completion-name-key) documentation-key (partial-completers '(#\Space)) (separator #\,) (echo-space t)) :inherit-from t) (define-presentation-method presentation-typep (object (type subset-completion)) (map nil #'(lambda (obj) (unless (find obj sequence :test test :key value-key) (return-from presentation-typep nil))) object) t) (define-presentation-method presentation-subtypep ((type subset-completion) maybe-supertype) (with-presentation-type-parameters (subset-completion maybe-supertype) (let ((super-sequence sequence) (super-test test) (super-value-key value-key)) (with-presentation-type-parameters (subset-completion type) (values (sequence-subset-p sequence test value-key super-sequence super-test super-value-key) t))))) (define-presentation-method present ((object list) (type subset-completion) stream (view textual-view) &key acceptably for-context-type) (declare (ignore for-context-type)) (loop for tail on object for (obj) = tail do (progn (present obj (presentation-type-of object) :stream stream :view view :acceptably acceptably :sensitive nil) (when (cdr tail) (if acceptably (princ separator stream) (terpri stream)))))) (define-presentation-method present ((object vector) (type subset-completion) stream (view textual-view) &key acceptably for-context-type) (declare (ignore for-context-type)) (loop for i from 0 below (length object) for obj = (aref object i) do (progn (present obj (presentation-type-of object) :stream stream :view view :acceptably acceptably :sensitive nil) (when (< i (1- (length object))) (if acceptably (princ separator stream) (terpri stream)))))) ;;; XXX is it a typo in the spec that subset, subset-sequence and subset-alist ;;; have the same options as completion, and not subset-completion? (define-presentation-type-abbreviation subset (&rest elements) (make-presentation-type-specifier `(subset-completion ,elements) :name-key name-key :documentation-key documentation-key :partial-completers partial-completers) :options #.+completion-options+) (define-presentation-type-abbreviation subset-sequence (sequence &key (test 'eql testp)) (make-presentation-type-specifier `(subset-completion ,sequence ,@(and testp `(:test ,test))) :name-key name-key :documentation-key documentation-key :partial-completers partial-completers) :options #.+completion-options+) (define-presentation-type-abbreviation subset-alist (alist &key (test 'eql testp)) (make-presentation-type-specifier `(subset-completion ,@(and testp `(:test ,test)) :value-key member-alist-value-key) :name-key name-key :documentation-key documentation-key :partial-completers partial-completers) :options ((name-key 'default-completion-name-key) (documentation-key 'member-alist-doc-key) (partial-completers '(#\Space)))) (define-presentation-type sequence (type) :options ((separator #\,) (echo-space t)) :inherit-from 't :parameters-are-types t) (define-presentation-method presentation-type-specifier-p ((type sequence)) (and (listp type) (consp (rest type)) (presentation-type-specifier-p (second type)))) (define-presentation-method presentation-typep (object (type sequence)) ;; XXX TYPE here is the sequence element type, not the whole type specifier (unless (or (listp object) (vectorp object)) (return-from presentation-typep nil)) (let ((real-type (expand-presentation-type-abbreviation type))) (map nil #'(lambda (obj) (unless (presentation-typep obj real-type) (return-from presentation-typep nil))) object) t)) (define-presentation-method presentation-subtypep ((type sequence) maybe-supertype) (with-presentation-type-parameters (sequence type) ;; now TYPE is bound to the parameter TYPE (let ((real-type (expand-presentation-type-abbreviation type))) (with-presentation-type-parameters (sequence maybe-supertype) (let ((real-super-type (expand-presentation-type-abbreviation type))) (presentation-subtypep real-type real-super-type)))))) (defmethod presentation-type-of ((object cons)) '(sequence t)) ;;; Do something interesting with the array-element-type (defmethod presentation-type-of ((object vector)) '(sequence t)) (define-presentation-method present ((object list) (type sequence) stream (view textual-view) &key acceptably for-context-type) (declare (ignore for-context-type)) (loop for tail on object for (obj) = tail do (progn (present obj type ; i.e., the type parameter :stream stream :view view :acceptably acceptably :sensitive nil) (when (cdr tail) (write-char separator stream))))) (define-presentation-method present ((object vector) (type sequence) stream (view textual-view) &key acceptably for-context-type) (declare (ignore for-context-type)) (loop for i from 0 below (length object) for obj = (aref object i) do (progn (present obj type ; i.e., the type parameter :stream stream :view view :acceptably acceptably :sensitive nil) (when (< i (1- (length object))) (write-char separator stream))))) (define-presentation-method accept ((type sequence) stream (view textual-view) &key) (loop with separators = (list separator) for element = (accept type ; i.e., the type parameter :stream stream :view view :prompt nil :additional-delimiter-gestures separators) collect element do (progn (when (not (eql (peek-char nil stream nil nil) separator)) (loop-finish)) (read-char stream) (when echo-space ;; Make the space a noise string (input-editor-format stream " "))))) (define-presentation-type sequence-enumerated (&rest types) :options ((separator #\,) (echo-space t)) :inherit-from 't :parameters-are-types t) (define-presentation-method presentation-typep (object (type sequence-enumerated)) (unless (or (listp object) (vectorp object)) (return-from presentation-typep nil)) (map nil #'(lambda (obj type) (let ((real-type (expand-presentation-type-abbreviation type))) (unless (presentation-typep obj real-type) (return-from presentation-typep nil)))) object types) t) (define-presentation-method presentation-subtypep ((type sequence-enumerated) maybe-supertype) (with-presentation-type-parameters (sequence-enumerated maybe-supertype) (let ((supertypes types)) (with-presentation-type-parameters (sequence-enumerated type) (unless (eql (length supertypes) (length types)) (return-from presentation-subtypep (values nil t))) (map nil #'(lambda (element-type element-supertype) (let ((real-type (expand-presentation-type-abbreviation element-type)) (real-supertype (expand-presentation-type-abbreviation element-supertype))) (multiple-value-bind (subtypep determined) (presentation-subtypep real-type real-supertype) (cond ((not determined) (return-from presentation-subtypep (values nil nil))) ((not subtypep) (return-from presentation-subtypep (values nil t))))))) types supertypes) (values t t))))) (define-presentation-method present ((object list) (type sequence-enumerated) stream (view textual-view) &key acceptably for-context-type) (declare (ignore for-context-type)) (loop for tail on object for (obj) = tail for obj-type in types do (progn (present obj obj-type :stream stream :view view :acceptably acceptably :sensitive nil) (when (cdr tail) (if acceptably (princ separator stream) (terpri stream)))))) (define-presentation-method present ((object vector) (type sequence-enumerated) stream (view textual-view) &key acceptably for-context-type) (declare (ignore for-context-type)) (loop for i from 0 below (length object) for obj = (aref object i) for obj-type in types do (progn (present obj obj-type :stream stream :view view :acceptably acceptably :sensitive nil) (when (< i (1- (length object))) (if acceptably (princ separator stream) (terpri stream)))))) (define-presentation-method accept ((type sequence-enumerated) stream (view textual-view) &key) (loop with element = nil and element-type = nil and separators = (list separator) for type-tail on types for (this-type) = type-tail do (setf (values element element-type) (accept this-type :stream stream :view view :prompt t :display-default nil :additional-delimiter-gestures separators)) collect element into sequence-val do (progn (when (not (eql (peek-char nil stream nil nil) separator)) (loop-finish)) (read-char stream) (when echo-space ;; Make the space a noise string (input-editor-format stream " "))) finally (if (cdr type-tail) (simple-parse-error "Input ~S too short for ~S." sequence-val types) (return sequence-val)))) (define-presentation-type or (&rest types) :inherit-from t :parameters-are-types t) (define-presentation-method presentation-typep (object (type or)) (loop for type in types for real-type = (expand-presentation-type-abbreviation type) do (when (presentation-typep object real-type) (return-from presentation-typep t))) nil) (define-presentation-method present (object (type or) stream (view textual-view) &key acceptably for-context-type) (loop for or-type in types for expanded-type = (expand-presentation-type-abbreviation or-type) do (when (presentation-typep object expanded-type) (present object expanded-type :stream stream :view view :acceptably acceptably :for-context-type for-context-type) (loop-finish)))) (define-presentation-method accept ((type or) (stream input-editing-stream) (view textual-view) &key) (let ((scan-begin (stream-scan-pointer stream))) (loop for or-type in types do (handler-case (return (accept or-type :stream stream :view view :prompt nil)) (parse-error () (setf (stream-scan-pointer stream) scan-begin))) finally (simple-parse-error "Input type is not one of ~S" types)))) ;;; What does and inherit from? Maybe we'll punt on that for the moment. ;;; Unless it inherits from its arguments... (define-presentation-type and (&rest types) :parameters-are-types t) (define-presentation-method presentation-typep (object (type and)) (loop for type in types for real-type = (expand-presentation-type-abbreviation type) do (with-presentation-type-decoded (name parameters) real-type (cond ((eq name 'satisfies) (unless (funcall (car parameters) object) (return-from presentation-typep nil))) ((eq name 'not) (unless (not (presentation-typep object (car parameters))) (return-from presentation-typep nil))) (t (unless (presentation-typep object real-type) (return-from presentation-typep nil)))))) t) (define-presentation-method present (object (type and) stream (view textual-view) &key acceptably for-context-type) (present object (expand-presentation-type-abbreviation (car types)) :stream stream :view view :acceptably acceptably :for-context-type for-context-type)) (define-presentation-method accept ((type and) (stream input-editing-stream) (view textual-view) &rest args &key) (let ((subtype (first types))) (multiple-value-bind (obj ptype) (apply-presentation-generic-function accept subtype stream view args) (unless (presentation-typep obj type) (simple-parse-error "Input object ~S is not of type ~S" obj type)) obj))) (define-presentation-type-abbreviation token-or-type (tokens type) `(or (member-alist ,tokens) ,type)) (define-presentation-type-abbreviation null-or-type (type) `(or null ,type)) (define-presentation-type-abbreviation type-or-string (type) `(or ,type string)) (define-presentation-method presentation-typep (object (type expression)) (declare (ignore object)) t) (define-presentation-method present (object (type expression) stream (view textual-view) &key acceptably for-context-type) (declare (ignore for-context-type)) (let ((*print-readably* acceptably)) (prin1 object stream))) (define-presentation-generic-function %accept-present-default accept-present-default (type-key parameters options type stream view default default-supplied-p present-p query-identifier)) ;;; All the expression and form reading stuff is in builtin-commands.lisp ;;; drag-n-drop fun (defclass drag-n-drop-translator (presentation-translator) ((destination-ptype :reader destination-ptype :initarg :destination-ptype) (feedback :reader feedback :initarg :feedback) (highlighting :reader highlighting :initarg :highlighting) (destination-translator :reader destination-translator :initarg :destination-translator))) (defvar *dragged-presentation* nil "Bound to the presentation dragged in a drag-and-drop context") (defvar *dragged-object* nil "Bound to the object dragged in a drag-and-drop context") () ;;; According to the Franz User's guide, the destination object is ;;; available in the tester, documentation, and translator function ;;; as destination-object. Therefore OBJECT is the dragged object. In ;;; our scheme the tester function, translator function etc. is ;;; really called on the destination object. So, we do a little ;;; shuffling of arguments here. We don't do that for the destination ;;; translator because we can call that ourselves in frame-drag-and-drop. ;;; ;;; Also, in Classic CLIM the destination presentation is passed as a ;;; destination-presentation keyword argument; hence the presentation argument ;;; is the dragged presentation. (defmethod initialize-instance :after ((obj drag-n-drop-translator) &key documentation pointer-documentation destination-translator) ;; This is starting to smell... (flet ((make-adapter (func) (lambda (object &rest args &key presentation &allow-other-keys) (if *dragged-presentation* (apply func *dragged-object* :presentation *dragged-presentation* :destination-object object :destination-presentation presentation args) (apply func object args))))) (setf (slot-value obj 'documentation) (make-adapter documentation)) (when pointer-documentation (setf (slot-value obj 'pointer-documentation) (make-adapter pointer-documentation))))) (defmacro define-drag-and-drop-translator (name (from-type to-type destination-type command-table &rest args &key (gesture :select) (tester 'default-translator-tester) documentation (pointer-documentation nil pointer-doc-p) (menu t) (priority 0) (feedback 'frame-drag-and-drop-feedback) (highlighting 'frame-drag-and-drop-highlighting)) arglist &body body) (declare (ignore tester gesture documentation pointer-documentation menu priority)) (let* ((real-dest-type (expand-presentation-type-abbreviation destination-type)) (name-string (command-name-from-symbol name)) (drag-string (format nil "Drag to ~A" name-string)) (pointer-doc (if pointer-doc-p nil `(:pointer-documentation ((object destination-object stream) (declare (ignore object)) (write-string (if destination-object ,name-string ,drag-string) stream)))))) (with-keywords-removed (args (:feedback :highlighting)) `(progn (define-presentation-translator ,name (,from-type ,to-type ,command-table :tester-definitive t ,@args ,@pointer-doc :feedback #',feedback :highlighting #',highlighting :destination-ptype ',real-dest-type :destination-translator #',(make-translator-fun arglist body) :translator-class drag-n-drop-translator) (presentation context-type frame event window x y) (frame-drag-and-drop ',name ',command-table presentation context-type frame event window x y)))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/incremental-redisplay.lisp0000644000175000017500000014034111345155771022177 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2002 by Michael McDonald (mikemac@mikemac.com) ;;; (c) copyright 2002-2004 by Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) #| Incremental Redisplay Theory of Operation Incremental redisplay compares the tree of output records before and after calling REDISPLAY and updates those parts of the screen that are different. UPDATING-OUTPUT forms in the code create UPDATING-OUTPUT-RECORDs in the record tree. These records hold the before and after snapshots of the tree. When the display code is first run, the bodies of all the UPDATING-OUTPUT forms are captured as closures. Usually only the closure in the top-level output record will ever get called, but the programmer can call REDISPLAY on any updating output record, so we have to be prepared for that. Redisplay proceeds thus: All the updating output records are visited. Their state is changed to :UPDATING and the OLD-CHILDREN slot is set to the current children. The closure of the root updating output record is called. None of the closures the child updating output records are called because any free variables captured in the UPDATING-OUTPUT forms need to see the fresh bindings from this run of the code.As UPDATING-OUTPUT forms are encountered, several things can happen: * The cache value of the form compares to the value stored in the record. The record, and all the updating output records below it, are marked :clean. The body of UPDATING-OUTPUT isn't run. * The cache value doesn't compare. The record is marked :UPDATED, and the body is run. * There isn't an existing UPDATING-OUTPUT-RECORD for this UPDATING-OUTPUT form. One is created in state :UPDATED. The body is run. Before the top level UPDATING-OUTPUT closure returns, various output records in the history tree might be mutated e.g., be moved. The most common case of this is in table layout, where the records for each cell are first created and then assigned a final location based on the dimensions of the table. But these nodes may be children of an updating output record that has been marked :CLEAN. Therefore, they have to be treated specially so that the rest of incremental redisplay will consider them and not leave the screen in a trashed state. An around method on (SETF OUTPUT-RECORD-POSITION) for display records checks if incremental redisplay is in progress; if so, it stores the mutated record in its closest parent UPDATING-OUTPUT record (if any). If that parent is :CLEAN then it and any other clean parent updating output records are marked as :UPDATED. Next, COMPUTE-DIFFERENCE-SET compares the old and new trees. New output records that aren't in the old tree need to be drawn. Old records not in the new tree need to be erased. Display records that were moved need are erased and redrawn. COMPUTE-DIFFERENCE-SET only compares display output records that are direct descendents (i.e., no intervening UPDATING-OUTPUT record) of an updating output record; Compute-difference-set is called recursively on any children updating output records. As an optimization, COMPUTE-DIFFERENCE-SET ignores records that are outside of the pane's visible regin. Finally, the old tree is walked. All updating output records in state :UPDATING were not visited at all and thus are deleted from their parent caches. Problems / Future work The complete traversals of the output history tree could be avoided by keeping a generation number in the updating output record and updating that everytime the node is visited. The search for equal display nodes is expensive in part because we have no spatially organized data structure. |# ;;; The map from unique values to output records. Unfortunately the :ID-TEST ;;; is specified in the child updating output records, not in the record that ;;; holds the cache! So, the map lookup code jumps through some hoops to use a ;;; hash table if the child id tests allow that and if there enough records in ;;; the map to make that worthwhile. (defclass updating-output-map-mixin () ((id-map :accessor id-map :initform nil) (id-counter :accessor id-counter :documentation "The counter used to assign unique ids to updating output records without one.") (tester-function :accessor tester-function :initform 'none :documentation "The function used to lookup updating output records in this map if unique; otherwise, :mismatch.") (element-count :accessor element-count :initform 0))) ;;; Complete guess... (defparameter *updating-map-threshold* 10 "The limit at which the id map in an updating output record switches to a hash table.") ;;; ((eq map-test-func :mismatch) ;;; nil) (defun function-matches-p (map func) (let ((map-test-func (tester-function map))) (cond ((eq map-test-func func) t) ((and (symbolp map-test-func) (symbolp func)) ; not eq nil) ((and (symbolp map-test-func) (fboundp map-test-func)) (eq (symbol-function map-test-func) func)) ((and (symbolp func) (fboundp func)) (eq map-test-func (symbol-function func))) (t nil)))) (defun ensure-test (map test) (unless (function-matches-p map test) (explode-map-hash map) (setf (tester-function map) :mismatch))) (defgeneric clear-map (map)) (defmethod clear-map ((map updating-output-map-mixin)) (setf (id-map map) nil) (setf (id-counter map) 0) (setf (element-count map) 0)) ;;; Perhaps these should be generic functions, but in the name of premature ;;; optimization they're not :) (defun get-from-map (map value test) (when (eq (tester-function map) 'none) (return-from get-from-map nil)) (ensure-test map test) (let ((map (id-map map))) (if (hash-table-p map) (gethash value map) (cdr (assoc value map :test test))))) (defun maybe-convert-to-hash (map) (let ((test (tester-function map))) (when (and (not (eq test :mismatch)) (> (element-count map) *updating-map-threshold*) (or (case test ((eq eql equal equalp) t)) (eq test #'eq) (eq test #'eql) (eq test #'equal) (eq test #'equalp))) (let ((new-map (make-hash-table :test test))) (loop for (key . value) in (id-map map) do (setf (gethash key new-map) value)) (setf (id-map map) new-map))))) (defun explode-map-hash (map) (let ((hash-map (id-map map))) (when (hash-table-p hash-map) (loop for key being each hash-key of hash-map using (hash-value record) collect (cons key record) into alist finally (setf (id-map map) alist))))) (defun add-to-map (map record value test replace) (if (eq (tester-function map) 'none) (setf (tester-function map) test) (ensure-test map test)) (let ((val-map (id-map map))) (if (hash-table-p val-map) (multiple-value-bind (existing-value in-table) (if replace (gethash value val-map) (values nil nil)) (declare (ignore existing-value)) (setf (gethash value val-map) record) (unless in-table (incf (element-count map)))) (let ((val-cons (if replace (assoc value val-map :test test) nil))) (if val-cons (setf (cdr val-cons) record) (progn (setf (id-map map) (acons value record val-map)) (incf (element-count map)) (maybe-convert-to-hash map))))))) (defun delete-from-map (map value test) (ensure-test map test) (let ((val-map (id-map map)) (deleted nil)) (if (hash-table-p val-map) (setf deleted (remhash value val-map)) (setf (values (id-map map) deleted) (delete-1 value val-map :test test :key #'car))) (when deleted (decf (element-count map))))) ;;; Reset the ID counter so that updating output records without explicit IDs ;;; can be assigned one during a run of the code. I'm not sure about using ;;; reinitialize-instance for this... (defmethod shared-initialize :after ((obj updating-output-map-mixin) slot-names &key) (declare (ignore slot-names)) (setf (id-counter obj) 0)) ;;; Should this have a more complete CPL, to pull in the fact that it needs a ;;; medium for graphics state? (defclass updating-output-stream-mixin (updating-output-map-mixin extended-output-stream) ((redisplaying-p :reader stream-redisplaying-p :initform nil) (do-note-output-record :accessor do-note-output-record :initform t) (incremental-redisplay :initform nil :initarg :incremental-redisplay :accessor pane-incremental-redisplay) (updating-record :accessor updating-record :initarg :updating-record :initform nil :documentation "For incremental output, holds the top level updating-output-record."))) (defgeneric redisplayable-stream-p (stream)) (defmethod redisplayable-stream-p ((stream t)) nil) (defmethod redisplayable-stream-p ((stream updating-output-stream-mixin)) t) (defmethod pane-needs-redisplay :around ((pane updating-output-stream-mixin)) (let ((redisplayp (call-next-method))) (values redisplayp (and (not (eq redisplayp :no-clear)) (not (pane-incremental-redisplay pane)))))) (defmethod window-clear :after ((pane updating-output-stream-mixin)) "Get rid of any updating output records stored in the stream; they're gone from the screen." (clear-map pane)) ;;; INCREMENTAL-DISPLAY takes as input the difference set computed by ;;; COMPUTE-DIFFERENCE-SET and updates the screen. The 5 kinds of updates are ;;; not very well defined in the spec. I understand their semantics thus: ;;; ;;; Erases, moves, and draws refer to records that don't overlap *with other ;;; records that survive in the current rendering*. In other words, they don't ;;; overlap with records that were not considered by COMPUTE-DIFFRENCE-SET, ;;; either because they are children of a clean updating output node or they ;;; are in another part of the output history that is not being ;;; redisplayed. Also, moves and draws can not overlap each other. It is fine ;;; for erases and draws to overlap. Another way to think about erases, moves ;;; and draws is in terms of a possible implementation: they could be handled ;;; using only operations on the screen itself. First all the erase regions ;;; would be erased, the moves would be blitted, and then the individual draws ;;; records would be redisplayed. ;;; ;;; Records in erase-overlapping and move-overlapping might overlap with any ;;; other record. They need to be implemented by erasing their region on the ;;; screen and then replaying the output history for that region. Thus, any ;;; ordering issues implied by overlapping records is handled correctly. Note ;;; that draw records that overlap are included in erase-overlapping; the draw ;;; operation itself occurs when the screen is refreshed from the output ;;; history. -- moore (defgeneric incremental-redisplay (stream position erases moves draws erase-overlapping move-overlapping)) (defmethod incremental-redisplay ((stream updating-output-stream-mixin) position erases moves draws erase-overlapping move-overlapping) (declare (ignore position)) (let ((history (stream-output-history stream))) (with-output-recording-options (stream :record nil :draw t) (loop for (nil br) in erases do (erase-rectangle stream br)) (loop for (nil old-bounding) in moves do (erase-rectangle stream old-bounding)) (loop for (nil br) in erase-overlapping do (erase-rectangle stream br)) (loop for (nil old-bounding) in move-overlapping do (erase-rectangle stream old-bounding))) (loop for (r) in moves do (replay r stream)) (loop for (r) in draws do (replay r stream)) (let ((res +nowhere+)) (loop for (r) in erase-overlapping do (setf res (region-union res r))) (loop for (r) in move-overlapping do (setf res (region-union res r))) (replay history stream res)))) ;;; FIXME: although this inherits from COMPLETE-MEDIUM-STATE, in fact ;;; it needn't, as we only ever call SET-MEDIUM-CURSOR-POSITION on it. ;;; Until 2006-05-28, we did also use the various medium attributes, ;;; but with the reworking of REPLAY-OUTPUT-RECORD ;;; (STANDARD-DISPLAYED-OUTPUT-RECORD) to use around methods and ;;; WITH-DRAWING-OPTIONS, they are no longer necessary. (defclass updating-stream-state (complete-medium-state) ((cursor-x :accessor cursor-x :initarg :cursor-x :initform 0) (cursor-y :accessor cursor-y :initarg :cursor-y :initform 0))) (defmethod initialize-instance :after ((obj updating-stream-state) &key (stream nil)) (when stream (setf (values (slot-value obj 'cursor-x) (slot-value obj 'cursor-y)) (stream-cursor-position stream)))) (defmethod match-output-records-1 and ((state updating-stream-state) &key (cursor-x 0 x-supplied-p) (cursor-y 0 y-supplied-p)) (and (or (not x-supplied-p) (coordinate= (slot-value state 'cursor-x) cursor-x)) (or (not y-supplied-p) (coordinate= (slot-value state 'cursor-y) cursor-y)))) (defmethod set-medium-cursor-position ((state updating-stream-state) (stream updating-output-stream-mixin)) (setf (stream-cursor-position stream) (values (cursor-x state) (cursor-y state)))) (defmethod medium-graphics-state ((stream updating-output-stream-mixin) &optional state) (if (and state (subtypep state 'updating-stream-state)) (reinitialize-instance state :stream stream) (make-instance 'updating-stream-state :stream stream))) ;;; XXX Add to values we test, obviously. ;;; ;;;Well, maybe not. The goal is to support output records that have moved ;;;but that are otherwise clean. I.e., some previous part of the output has ;;;changed (lines added or deleted, for example). If the stream cursor ;;;position is different, I'm not sure now that the code for the updating ;;;output record needs to be rerun; I think we could use only the difference ;;;in cursor position to move the record. Any other graphics state change -- ;;;like a different foreground color -- should probably be handled by the ;;;programmer forcing all new output. (defun state-matches-stream-p (state stream) (multiple-value-bind (cx cy) (stream-cursor-position stream) (with-sheet-medium (medium stream) ;; Note: We don't match the y coordinate. (declare (ignore cy)) (match-output-records state :cursor-x cx)))) (defclass updating-output-record-mixin (updating-output-map-mixin standard-sequence-output-record) ((unique-id :reader output-record-unique-id :initarg :unique-id) (id-test :reader output-record-id-test :initarg :id-test :initform #'eql) (cache-value :reader output-record-cache-value :initarg :cache-value) (cache-test :reader output-record-cache-test :initarg :cache-test :initform #'eql) (fixed-position :reader output-record-fixed-position :initarg :fixed-position :initform nil) (displayer :reader output-record-displayer :initarg :displayer) ;; Start and end cursor (start-graphics-state :accessor start-graphics-state :initarg :start-graphics-state :documentation "Graphics state needed to render record") (end-graphics-state :accessor end-graphics-state :initarg :end-graphics-state :documentation "Graphics state after rendering record; used to render non updating-output-records that follow") (old-children :accessor old-children :documentation "Contains the output record tree for the current display.") (output-record-dirty :accessor output-record-dirty :initform :updating :documentation ":updating :updated :clean") (parent-cache :accessor parent-cache :initarg :parent-cache :documentation "The parent cache in which this updating output record is stored.") (stream :accessor updating-output-stream :initarg :stream :initform nil :documentation "Capture the screen in order to restrict update to visible records") (parent-updating-output :accessor parent-updating-output :initarg :parent-updating-output :initform nil :documentation "A backlink to the updating-output-parent above this one in the tree.") ;; Results of (setf output-record-position) while updating (explicit-moves :accessor explicit-moves) (old-bounds :accessor old-bounds :initform (make-bounding-rectangle 0.0d0 0.0d0 0.0d0 0.0d0) :documentation "Holds the old bounds of an updating output record if that can no longer be determined from the old-children.") ;; on-screen state? )) (defgeneric sub-record (record) (:method ((record updating-output-record-mixin)) (let ((children (output-record-children record))) (if (zerop (length children)) nil (aref children 0))))) (defmethod shared-initialize :after ((obj updating-output-record-mixin) slot-names &key (x-position 0.0d0) (y-position 0.0d0)) (declare (ignore x-position y-position)) (declare (ignore slot-names)) (setf (explicit-moves obj) nil)) (defmethod output-record-start-cursor-position ((record updating-output-record-mixin)) (let ((state (start-graphics-state record))) (values (cursor-x state) (cursor-y state)))) (defmethod* (setf output-record-start-cursor-position) (x y (record updating-output-record-mixin)) (let ((state (start-graphics-state record))) (setf (values (cursor-x state) (cursor-y state)) (values x y)))) (defmethod output-record-end-cursor-position ((record updating-output-record-mixin)) (let ((state (end-graphics-state record))) (values (cursor-x state) (cursor-y state)))) (defmethod* (setf output-record-end-cursor-position) (x y (record updating-output-record-mixin)) (let ((state (end-graphics-state record))) (setf (values (cursor-x state) (cursor-y state)) (values x y)))) ;;; Prevent deleted output records from coming back from the dead. (defmethod delete-output-record :after ((child updating-output-record-mixin) record &optional errorp) (declare (ignore record errorp)) (let ((pcache (parent-cache child))) (delete-from-map pcache (output-record-unique-id child) (output-record-id-test child)))) (defclass standard-updating-output-record (updating-output-record-mixin updating-output-record) ()) (defmethod print-object ((obj standard-updating-output-record) stream) (print-unreadable-object (obj stream :type t :identity t) (with-standard-rectangle (x1 y1 x2 y2) obj (format stream "X ~S:~S Y ~S:~S " x1 x2 y1 y2)) (when (slot-boundp obj 'unique-id) (let ((*print-length* 10) (*print-level* 3)) (format stream " ~S" (output-record-unique-id obj)))))) ;;; Helper function for visiting updating-output records in a tree (defgeneric map-over-updating-output (function root use-old-records)) (defmethod map-over-updating-output (function (record standard-updating-output-record) use-old-records) (funcall function record) (let ((children (cond (use-old-records (when (slot-boundp record 'old-children) (old-children record))) (t (sub-record record))))) (when children (map-over-updating-output function children use-old-records)))) (defmethod map-over-updating-output (function (record compound-output-record) use-old-records) (flet ((mapper (r) (map-over-updating-output function r use-old-records))) (declare (dynamic-extent #'mapper)) (map-over-output-records #'mapper record))) (defmethod map-over-updating-output (function record use-old-records) (declare (ignore function record use-old-records)) nil) ;;; (defvar *current-updating-output* nil) (defgeneric compute-new-output-records (record stream)) (defgeneric compute-new-output-records-1 (record stream displayer) (:documentation "Like compute-new-output-records with an explicit displayer function.")) (defmethod compute-new-output-records ((record standard-updating-output-record) stream) (with-output-recording-options (stream :record t :draw nil) (map-over-updating-output #'(lambda (r) (let ((sub-record (sub-record r))) (setf (old-children r) sub-record) (setf (output-record-dirty r) :updating) (setf (rectangle-edges* (old-bounds r)) (rectangle-edges* sub-record)))) record nil) (force-output stream) ;; Why is this binding here? We need the "environment" in this call that ;; computes the new records of an outer updating output record to resemble ;; that when a record's contents are computed in invoke-updating-output. (letf (((stream-current-output-record stream) (output-record-parent record))) (compute-new-output-records-1 record stream (output-record-displayer record))))) ;;; Create the sub-record that holds the new contents of the updating output ;;; record. (defun %invoke-updating (record stream displayer) (letf (((stream-current-output-record stream) record)) (with-new-output-record (stream) (funcall displayer stream)))) (defmethod compute-new-output-records-1 ((record standard-updating-output-record) stream displayer) (multiple-value-bind (x y) (output-record-position record) (let ((sub-record (sub-record record))) (when sub-record (delete-output-record sub-record record))) ;; Don't add this record repeatedly to a parent updating-output-record. (unless (eq (output-record-parent record) (stream-current-output-record stream)) (setf (output-record-parent record) nil) (add-output-record record (stream-current-output-record stream))) (reinitialize-instance record :x-position x :y-position y)) (%invoke-updating record stream displayer) (setf (output-record-dirty record) :updated)) (defgeneric find-child-output-record (record use-old-elements record-type &rest initargs &key unique-id unique-id-test)) (defgeneric map-over-displayed-output-records (function root use-old-elements clean clip-region) (:documentation "Call function on all displayed-output-records in ROOT's tree. If USE-OLD-ELEMENTS is true, descend the old branch of updating output records. If CLEAN is true, descend into clean updating output records. ")) (defmethod map-over-displayed-output-records :around (function root use-old-elements clean (clip-rectangle bounding-rectangle)) (declare (ignore function use-old-elements clean)) (when (region-intersects-region-p root clip-rectangle) (call-next-method))) (defmethod map-over-displayed-output-records (function (root standard-updating-output-record) use-old-elements clean clip-rectangle) (cond ((and (not clean) (eq (output-record-dirty root) :clean)) nil) ((and use-old-elements (slot-boundp root 'old-children)) (map-over-displayed-output-records function (old-children root) use-old-elements clean clip-rectangle)) ((not use-old-elements) (map-over-displayed-output-records function (sub-record root) use-old-elements clean clip-rectangle)) (t nil))) (defmethod map-over-displayed-output-records (function (root compound-output-record) use-old-elements clean clip-rectangle) (flet ((mapper (record) (map-over-displayed-output-records function record use-old-elements clean clip-rectangle))) (declare (dynamic-extent #'mapper)) (map-over-output-records #'mapper root))) (defmethod map-over-displayed-output-records (function (root displayed-output-record) use-old-elements clean clip-rectangle) (declare (ignore clean use-old-elements clip-rectangle)) (funcall function root)) (defgeneric compute-difference-set (record &optional check-overlapping offset-x offset-y old-offset-x old-offset-y)) ;;; Helper functions for visiting only the highest level updating ;;; output records in a tree and only those display records that are ;;; not under updating output records. Do not pass these the parent ;;; updating output record; pass sub-record or old-children (defgeneric map-over-child-updating-output (function record clip-rectangle) (:documentation "Apply FUNCTION to updating-output records that are children of record, but don't recurse into them.") (:method (function (record standard-updating-output-record) clip-rectangle) (declare (ignore clip-rectangle)) (funcall function record)) (:method (function (record compound-output-record) clip-rectangle) (flet ((mapper (r) (map-over-child-updating-output function r clip-rectangle))) (declare (dynamic-extent #'mapper)) (map-over-output-records #'mapper record))) (:method (function record clip-rectangle) (declare (ignore function record clip-rectangle)) nil) (:method :around (function record (clip-rectangle bounding-rectangle)) (declare (ignore function)) (when (region-intersects-region-p record clip-rectangle) (call-next-method)))) (defgeneric map-over-child-display (function record clip-rectangle) (:documentation "Apply function to display records in RECORD's tree that are not under updating-output records") (:method (function (record displayed-output-record) clip-rectangle) (declare (ignore clip-rectangle)) (funcall function record)) (:method (function (record compound-output-record) clip-rectangle) (flet ((mapper (r) (map-over-child-display function r clip-rectangle))) (declare (dynamic-extent #'mapper)) (map-over-output-records #'mapper record))) (:method (function (record standard-updating-output-record) clip-rectangle) (declare (ignore function record clip-rectangle)) nil) (:method (function record clip-rectangle) (declare (ignore function record clip-rectangle)) nil) (:method :around (function record (clip-rectangle bounding-rectangle)) (declare (ignore function)) (when (region-intersects-region-p record clip-rectangle) (call-next-method)))) ;;; Variation on a theme. Refactor, refactor... (defgeneric map-over-obsolete-display (function record clip-rectangle) (:method (function (record displayed-output-record) clip-rectangle) (declare (ignore clip-rectangle)) (funcall function record)) (:method (function (record compound-output-record) clip-rectangle) (flet ((mapper (r) (map-over-obsolete-display function r clip-rectangle))) (declare (dynamic-extent #'mapper)) (map-over-output-records #'mapper record))) (:method (function (record standard-updating-output-record) clip-rectangle) (when (eq (output-record-dirty record) :updating) (map-over-obsolete-display function (sub-record record) clip-rectangle))) (:method (function record clip-rectangle) (declare (ignore function record clip-rectangle)) nil) (:method :around (function record (clip-rectangle bounding-rectangle)) (declare (ignore function)) (when (region-intersects-region-p record clip-rectangle) (call-next-method)))) (defun find-existing-record (display-record root visible-region) "Returns a display record that is output-record-equal to display-record within visible-region and not under an updating-output record" (map-over-child-display #'(lambda (r) (when (output-record-equal display-record r) (return-from find-existing-record r))) root visible-region) nil) (defun copy-bounding-rectange (rect) (with-bounding-rectangle* (min-x min-y max-x max-y) rect (make-bounding-rectangle min-x min-y max-x max-y))) ;;; work in progress (defvar *existing-output-records* nil) ;;; (defgeneric output-record-hash (record) (:documentation "Produce a value that can be used to hash the output record in an equalp hash table")) (defmethod output-record-hash ((record standard-bounding-rectangle)) (slot-value record 'coordinates)) (defconstant +fixnum-bits+ (integer-length most-positive-fixnum)) (declaim (inline hash-coords)) (defun hash-coords (x1 y1 x2 y2) (declare (type coordinate x1 y1 x2 y2)) (let ((hash-val 0)) (declare (type fixnum hash-val)) (labels ((rot4 (val) (dpb (ldb (byte 4 0) val) (byte 4 (- +fixnum-bits+ 4 1)) (ash val -4))) (mix-it-in (val) (let ((xval (sxhash val))) (declare (type fixnum xval)) (when (minusp val) (setq xval (rot4 xval))) (setq hash-val (logxor (rot4 hash-val) xval))))) (declare (inline rot4 mix-it-in)) (mix-it-in x1) (mix-it-in y1) (mix-it-in x2) (mix-it-in y2) hash-val))) (defmethod output-record-hash ((record output-record)) (with-bounding-rectangle* (x1 y1 x2 y2) record (hash-coords x1 y1 x2 y2))) (defmethod compute-difference-set ((record standard-updating-output-record) &optional (check-overlapping t) offset-x offset-y old-offset-x old-offset-y) (declare (ignore offset-x offset-y old-offset-x old-offset-y)) ;; (declare (values erases moves draws erase-overlapping move-overlapping)) (let (was is stay come (everywhere (or +everywhere+ (pane-viewport-region (updating-output-stream record)))) (was-table (make-hash-table :test #'equalp)) (is-table (make-hash-table :test #'equalp))) (labels ((collect-1-was (record) (push record was) (push record (gethash (output-record-hash record) was-table))) (collect-1-is (record) (push record is) (push record (gethash (output-record-hash record) is-table)) ;; come = is \ was ;; stay = is ^ was (cond ((updating-output-record-p record) (if (eq :clean (output-record-dirty record)) (push record stay) (push record come))) (t (let ((q (gethash (output-record-hash record) was-table))) (if (some #'(lambda (x) (output-record-equal record x)) q) (push record stay) (push record come))))))) ;; Collect what was there (labels ((gather-was (record) (cond ((displayed-output-record-p record) (collect-1-was record)) ((updating-output-record-p record) (cond ((eq :clean (output-record-dirty record)) (collect-1-was record)) ((eq :moved (output-record-dirty record)) (collect-1-was (slot-value record 'old-bounds))) (t (map-over-output-records-overlapping-region #'gather-was (old-children record) everywhere)))) (t (map-over-output-records-overlapping-region #'gather-was record everywhere))))) (gather-was record)) ;; Collect what still is there (labels ((gather-is (record) (cond ((displayed-output-record-p record) (collect-1-is record)) ((updating-output-record-p record) (cond ((eq :clean (output-record-dirty record)) (collect-1-is record)) ((eq :moved (output-record-dirty record)) (collect-1-is record)) (t (map-over-output-records-overlapping-region #'gather-is (sub-record record) everywhere)))) (t (map-over-output-records-overlapping-region #'gather-is record everywhere) )))) (gather-is record))) ;; (let (gone) ;; gone = was \ is (loop for w in was do (cond ((updating-output-record-p w) (unless (eq :clean (output-record-dirty w)) (push (old-children w) gone))) (t (let ((q (gethash (output-record-hash w) is-table))) (unless (some #'(lambda (x) (output-record-equal w x)) q) (push w gone)))))) ;; Now we essentially want 'gone', 'stay', 'come' (let ((gone-overlap nil) (come-overlap nil)) (when check-overlapping (setf (values gone gone-overlap) (loop for k in gone if (some (lambda (x) (region-intersects-region-p k x)) stay) collect (list k k) into gone-overlap* else collect (list k k) into gone* finally (return (values gone* gone-overlap*)))) (setf (values come come-overlap) (loop for k in come if (some (lambda (x) (region-intersects-region-p k x)) stay) collect (list k k) into come-overlap* else collect (list k k) into come* finally (return (values come* come-overlap*))))) ;; Hmm, we somehow miss come-overlap ... (values ;; erases gone ;; moves nil ;; draws come ;; erase overlapping (append gone-overlap come-overlap) ;; move overlapping nil))))) (defvar *trace-updating-output* nil) (defvar *no-unique-id* (cons nil nil)) (defun move-output-record (record dx dy) (multiple-value-bind (sx sy) (output-record-start-cursor-position record) (multiple-value-bind (ex ey) (output-record-end-cursor-position record) (setf (output-record-position record) (values (+ (nth-value 0 (output-record-position record)) dx) (+ (nth-value 1 (output-record-position record)) dy))) (setf (output-record-start-cursor-position record) (values (+ sx dx) (+ sy dy))) (setf (output-record-end-cursor-position record) (values (+ ex dx) (+ ey dy)))))) (defmethod invoke-updating-output ((stream updating-output-stream-mixin) continuation record-type unique-id id-test cache-value cache-test &key (fixed-position nil) (all-new nil) (parent-cache nil)) (force-output stream) (let ((parent-cache (or parent-cache *current-updating-output* stream))) (when (eq unique-id *no-unique-id*) (setq unique-id (incf (id-counter parent-cache)))) (let* ((record (get-from-map parent-cache unique-id id-test)) ;; For debugging state-mismatch) (cond ((or all-new (null record)) ;; This case covers the outermost updating-output too. (with-new-output-record (stream record-type *current-updating-output* :unique-id unique-id :id-test id-test :cache-value cache-value :cache-test cache-test :fixed-position fixed-position :displayer continuation :parent-cache parent-cache :stream stream :parent-updating-output *current-updating-output*) (setq record *current-updating-output*) (when *trace-updating-output* (format *trace-output* "Creating ~S~%" record)) (setf (start-graphics-state record) (medium-graphics-state stream)) (%invoke-updating record stream continuation) (setf (end-graphics-state record) (medium-graphics-state stream)) (add-to-map parent-cache record unique-id id-test all-new))) ((or (setq state-mismatch (not (state-matches-stream-p (start-graphics-state record) stream))) (not (funcall cache-test cache-value (output-record-cache-value record)))) (when *trace-updating-output* (format *trace-output* "~:[cache test~;stream state~] ~S~%" state-mismatch record)) (let ((*current-updating-output* record)) (setf (start-graphics-state record) (medium-graphics-state stream)) (compute-new-output-records-1 record stream continuation) (setf (slot-value record 'cache-value) cache-value) (setf (end-graphics-state record) (medium-graphics-state stream)) (setf (parent-cache record) parent-cache))) (t ;; It doesn't need to be updated, but it does go into the ;; parent's sequence of records ;; (multiple-value-bind (cx cy) (stream-cursor-position stream) (multiple-value-bind (sx sy) (output-record-start-cursor-position record) (let ((dx (- cx sx)) (dy (- cy sy))) (unless (zerop dy) (move-output-record record dx dy) ) (let ((tag (cond ((= dx dy 0) (when *trace-updating-output* (format *trace-output* "clean ~S~%" record)) :clean) (t (when *trace-updating-output* (format *trace-output* "moved ~S~%" record)) :moved)))) (setf (output-record-dirty record) tag) (setf (output-record-parent record) nil) (map-over-updating-output #'(lambda (r) (unless (eq r record) (incf (slot-value (start-graphics-state r) 'cursor-x) dx) (incf (slot-value (start-graphics-state r) 'cursor-y) dy) (incf (slot-value (end-graphics-state r) 'cursor-x) dx) (incf (slot-value (end-graphics-state r) 'cursor-y) dy)) (setf (output-record-dirty r) tag)) record nil) (add-output-record record (stream-current-output-record stream)) (set-medium-cursor-position (end-graphics-state record) stream) (setf (parent-cache record) parent-cache) )) )))) record))) ;;; The Franz user guide says that updating-output does ;;; &allow-other-keys, and some code I've encountered does mention ;;; other magical arguments, so we'll do the same. -- moore (defun force-update-cache-test (a b) (declare (ignore a b)) nil) (defmacro updating-output ((stream &key (unique-id '*no-unique-id*) (id-test '#'eql) (cache-value ''no-cache-value cache-value-supplied-p) (cache-test '#'eql) (fixed-position nil fixed-position-p) (all-new nil all-new-p) (parent-cache nil parent-cache-p) (record-type ''standard-updating-output-record) &allow-other-keys) &body body) (when (eq stream t) (setq stream '*standard-output*)) (unless cache-value-supplied-p (setq cache-test '#'force-update-cache-test)) (let ((func (gensym "UPDATING-OUTPUT-CONTINUATION"))) `(flet ((,func (,stream) (declare (ignorable ,stream)) ,@body)) (invoke-updating-output ,stream #',func ,record-type ,unique-id ,id-test ,cache-value ,cache-test ,@ (and fixed-position-p `(:fixed-position ,fixed-position)) ,@(and all-new-p `(:all-new ,all-new)) ,@(and parent-cache-p `(:parent-cache ,parent-cache)))))) (defun redisplay (record stream &key (check-overlapping t)) (redisplay-output-record record stream check-overlapping)) ;;; Take the spec at its word that the x/y and parent-x/parent-y arguments are ;;; "entirely bogus." (defvar *dump-updating-output* nil) (defgeneric redisplay-output-record (record stream &optional check-overlapping)) (defmethod redisplay-output-record ((record updating-output-record) (stream updating-output-stream-mixin) &optional (check-overlapping t)) (letf (((slot-value stream 'redisplaying-p) t)) (let ((*current-updating-output* record) (current-graphics-state (medium-graphics-state stream))) (unwind-protect (progn (letf (((do-note-output-record stream) nil)) (set-medium-cursor-position (start-graphics-state record) stream) (compute-new-output-records record stream) (when *dump-updating-output* (dump-updating record :both *trace-output*))) (multiple-value-bind (erases moves draws erase-overlapping move-overlapping) (compute-difference-set record check-overlapping) (when *trace-updating-output* (let ((*print-pretty* t)) (format *trace-output* "erases: ~S~%moves: ~S~%draws: ~S~%erase ~ overlapping: ~S~%move overlapping: ~S~%" erases moves draws erase-overlapping move-overlapping))) (incremental-redisplay stream nil erases moves draws erase-overlapping move-overlapping)) (delete-stale-updating-output record)) (set-medium-cursor-position current-graphics-state stream))))) (defun erase-rectangle (stream bounding) (with-bounding-rectangle* (x1 y1 x2 y2) bounding (draw-rectangle* stream x1 y1 x2 y2 :ink +background-ink+))) (defun clear-moved-record (stream new-bounding old-bounding) (with-bounding-rectangle* (x1 y1 x2 y2) new-bounding (draw-rectangle* stream x1 y1 x2 y2 :ink +background-ink+)) (with-bounding-rectangle* (x1 y1 x2 y2) old-bounding (draw-rectangle* stream x1 y1 x2 y2 :ink +background-ink+))) ;;; Suppress the got-sheet/lost-sheet notices during redisplay. (defmethod note-output-record-lost-sheet :around (record (sheet updating-output-stream-mixin)) (declare (ignore record)) (when (do-note-output-record sheet) (call-next-method))) (defmethod note-output-record-got-sheet :around (record (sheet updating-output-stream-mixin)) (declare (ignore record)) (when (do-note-output-record sheet) (call-next-method))) (defun delete-stale-updating-output (record) (map-over-updating-output #'(lambda (r) (when (eq (output-record-dirty r) :updating) (delete-from-map (parent-cache r) (output-record-unique-id r) (output-record-id-test r)))) record t)) (defun convert-from-relative-to-absolute-coordinates (stream record) (declare (ignore stream record)) "This compatibility function returns offsets that are suitable for drawing records that are the children of `record'. In McCLIM this is a noop because output records are kept in stream coordinates." (values 0 0)) ;;; Support for explicitly changing output records (defun mark-updating-output-changed (record) (let ((state (output-record-dirty record))) (cond ((or (eq record *current-updating-output*) (eq state :updated) (eq state :updating)) nil) ((eq state :clean) (setf (output-record-dirty record) :updated) (let ((parent (parent-updating-output record))) (if (null parent) (error "parent of ~S null" record) (mark-updating-output-changed parent)))) (t nil)))) (defgeneric propagate-to-updating-output (record child mode old-bounding-rectangle) (:method ((record updating-output-record-mixin) child mode old-bounding-rectangle) (when (eq (output-record-dirty record) :clean) (case mode (:move (push (list child old-bounding-rectangle nil) (explicit-moves record)) (mark-updating-output-changed record))))) (:method ((record output-record) child mode old-bounding-rectangle) (let ((parent (output-record-parent record))) (when parent (propagate-to-updating-output parent child mode old-bounding-rectangle))))) (defgeneric note-output-record-child-changed (record child mode old-position old-bounding-rectangle stream &optional erases moves draws erase-overlapping move-overlapping &key check-overlapping)) ;;; The default - do nothing (defmethod note-output-record-child-changed (record child mode old-position old-bounding-rectangle stream &optional erases moves draws erase-overlapping move-overlapping &key check-overlapping) (declare (ignore record child mode old-position old-bounding-rectangle stream erases moves draws erase-overlapping move-overlapping check-overlapping)) nil) (defmethod note-output-record-child-changed (record (child displayed-output-record) (mode (eql :move)) old-position old-bounding-rectangle (stream updating-output-stream-mixin) &optional erases moves draws erase-overlapping move-overlapping &key (check-overlapping t)) (declare (ignore old-position erases moves draws erase-overlapping move-overlapping check-overlapping)) (when (stream-redisplaying-p stream) (propagate-to-updating-output record child mode old-bounding-rectangle))) (defmethod* (setf output-record-position) :around (nx ny (record displayed-output-record)) (with-bounding-rectangle* (x y max-x max-y) record (multiple-value-prog1 (call-next-method) ;; coordinate= here instead? (unless (and (= x nx) (= y ny)) (let ((stream (and (slot-exists-p record 'stream) (slot-value record 'stream))) (parent (output-record-parent record))) (when (and stream parent) (note-output-record-child-changed parent record :move (make-point x y) (make-bounding-rectangle x y max-x max-y) stream))))))) ;;; Debugging hacks (defun dump-updating (record old-records &optional (stream *standard-output*)) (let ((*print-circle* t) (*print-pretty* t)) (fresh-line stream) (dump-updating-aux record old-records stream))) (defgeneric dump-updating-aux (record old-records stream)) (defmethod dump-updating-aux ((record standard-updating-output-record) old-records stream) (pprint-logical-block (stream nil) (print-unreadable-object (record stream :type t) (let ((old-printed nil)) (format stream "~S " (output-record-dirty record)) (pprint-indent :block 2 stream) (pprint-newline :linear stream) (when (and (or (eq old-records :old) (eq old-records :both)) (slot-boundp record 'old-children)) (format stream ":old ~@_") (dump-updating-aux (old-children record) old-records stream) (setq old-printed t)) (when (or (eq old-records :new) (eq old-records :both) (not old-records)) (when old-printed (pprint-newline :linear stream)) (format stream ":new ~@_") (dump-updating-aux (sub-record record) old-records stream)))))) (defmethod dump-updating-aux ((record compound-output-record) old-records stream) (pprint-logical-block (stream nil) (print-unreadable-object (record stream :type t) (write-char #\Space stream) (pprint-newline :linear stream) (pprint-indent :block 2 stream) (pprint-logical-block (stream nil :prefix "#(" :suffix ")") (loop with children = (output-record-children record) for i from 1 below (length children) for child across children do (progn (pprint-pop) (dump-updating-aux child old-records stream) (write-char #\Space stream) (pprint-newline :fill stream)) finally (when (> (length children) 0) (pprint-pop) (dump-updating-aux (elt children (1- i)) old-records stream))))))) (defmethod dump-updating-aux (record old-records stream) (declare (ignore old-records)) (write record :stream stream)) (defmethod redisplay-frame-pane ((frame application-frame) (pane updating-output-stream-mixin) &key force-p) (setf (id-counter pane) 0) (let ((incremental-redisplay (pane-incremental-redisplay pane))) (cond ((not incremental-redisplay) (call-next-method)) ((or (null (updating-record pane)) force-p) (setf (updating-record pane) (updating-output (pane :unique-id 'top-level) (call-next-method frame pane :force-p force-p)))) ;; Implements the extension to the :incremental-redisplay ;; pane argument found in the Franz User Guide. (t (let ((record (updating-record pane))) (if (consp incremental-redisplay) (apply #'redisplay record pane incremental-redisplay) (redisplay record pane))) )))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/medium.lisp0000644000175000017500000007134411345155771017172 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;;; TODO ;;; Text Styles ;; - *UNDEFINED-TEXT-STYLE* is missing ;; - Why is (EQ (MAKE-TEXT-STYLE NIL NIL 10) (MAKE-TEXT-STYLE NIL NIL 10.0005)) = T? ;; Does it matter? ;; - Don't we want a weak hash-table for *TEXT-STYLE-HASH-TABLE* ;; ;; --GB 2002-02-26 ;;; Notes ;; The text-style protocol is kind of useless for now. How is an ;; application programmer expected to implement new text-styles? I ;; think we would need something like: ;; ;; TEXT-STYLE-CHARACTER-METRICS text-style character[1] ;; -> width, ascent, descent, left-bearing, right-bearing ;; ;; TEXT-STYLE-DRAW-TEXT text-style medium string x y ;; Or even better: ;; DESIGN-FROM-TEXT-STYLE-CHARACTER text-style character ;; ;; ;; And when you start to think about it, text-styles are not fonts. So ;; we need two protocols: A text style protocol and a font protocol. ;; ;; A text style is then something, which maps a sequence of characters ;; into a couple of drawing commands, while probably using some font. ;; ;; While a font is something, which maps a _glyph index_ into a design. ;; ;; Example: Underlined with extra word spacing is a text style, while ;; Adobe Times Roman 12pt is a font. ;; ;; And [it can't be said too often] unicode is not a glyph encoding ;; but more a kind of text formating. ;; ;; [1] or even a code position ;; --GB (in-package :clim-internals) ;;;; ;;;; 11 Text Styles ;;;; (eval-when (:compile-toplevel :load-toplevel :execute) (defgeneric text-style-equalp (style1 style2)) (defmethod text-style-equalp ((style1 text-style) (style2 text-style)) nil) (defclass standard-text-style (text-style) ((family :initarg :text-family :initform :fix :reader text-style-family) (face :initarg :text-face :initform :roman :reader text-style-face) (size :initarg :text-size :initform :normal :reader text-style-size))) (defmethod make-load-form ((obj standard-text-style) &optional env) (declare (ignore env)) (with-slots (family face size) obj `(make-text-style ',family ',face ',size))) (defun family-key (family) (ecase family ((nil) 0) ((:fix :fixed) 1) ((:serif) 2) ((:sans-serif) 3))) (defun face-key (face) (if (equal face '(:bold :italic)) 4 (ecase face ((nil) 0) ((:roman) 1) ((:bold) 2) ((:italic) 3)))) (defun size-key (size) (if (numberp size) (+ 10 (round (* 256 size))) (ecase size ((nil) 0) ((:tiny) 1) ((:very-small) 2) ((:small) 3) ((:normal) 4) ((:large) 5) ((:very-large) 6) ((:huge) 7) ((:smaller) 8) ((:larger) 9)))) (defun text-style-key (family face size) (+ (* 256 (size-key size)) (* 16 (face-key face)) (family-key family))) (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *text-style-hash-table* (make-hash-table :test #'eql))) (defun make-text-style (family face size) (if (and (symbolp family) (or (symbolp face) (and (listp face) (every #'symbolp face)))) ;; Portable text styles have always been cached in McCLIM like this: ;; (as permitted by the CLIM spec for immutable objects, section 2.4) (let ((key (text-style-key family face size))) (declare (type fixnum key)) (or (gethash key *text-style-hash-table*) (setf (gethash key *text-style-hash-table*) (make-text-style-1 family face size)))) ;; Extended text styles using string components could be cached using ;; an appropriate hash table, but for now we just re-create them: (make-text-style-1 family face size))) (defun make-text-style-1 (family face size) (make-instance 'standard-text-style :text-family family :text-face face :text-size size)) ) ; end eval-when (defmethod print-object ((self standard-text-style) stream) (print-unreadable-object (self stream :type t :identity nil) (format stream "~{~S~^ ~}" (multiple-value-list (text-style-components self))))) (defmethod text-style-equalp ((style1 standard-text-style) (style2 standard-text-style)) (and (equal (text-style-family style1) (text-style-family style2)) (equal (text-style-face style1) (text-style-face style2)) (eql (text-style-size style1) (text-style-size style2)))) (defconstant *default-text-style* (make-text-style :sans-serif :roman :normal)) (defconstant *undefined-text-style* *default-text-style*) (defconstant *smaller-sizes* '(:huge :very-large :large :normal :small :very-small :tiny :tiny)) (defconstant *font-scaling-factor* 4/3) (defconstant *font-min-size* 6) (defconstant *font-max-size* 48) (defun find-smaller-size (size) (if (numberp size) (max (round (/ size *font-scaling-factor*)) *font-min-size*) (cadr (member size *smaller-sizes*)))) (defconstant *larger-sizes* '(:tiny :very-small :small :normal :large :very-large :huge :huge)) (defun find-larger-size (size) (if (numberp size) (min (round (* size *font-scaling-factor*)) *font-max-size*) (cadr (member size *larger-sizes*)))) (defmethod text-style-components ((text-style standard-text-style)) (values (text-style-family text-style) (text-style-face text-style) (text-style-size text-style))) ;;; Device-Font-Text-Style class (defclass device-font-text-style (text-style) ((display-device :initarg :display-device :accessor display-device) (device-font-name :initarg :device-font-name :accessor device-font-name))) (defmethod print-object ((self device-font-text-style) stream) (print-unreadable-object (self stream :type t :identity nil) (format stream "~S on ~S" (device-font-name self) (display-device self)))) (defun device-font-text-style-p (s) (typep s 'device-font-text-style)) (defmethod text-style-equalp ((style1 device-font-text-style) (style2 device-font-text-style)) (eq style1 style2)) (defmethod text-style-mapping ((port basic-port) text-style &optional character-set) (declare (ignore character-set)) (if (keywordp text-style) (gethash (parse-text-style text-style) (port-text-style-mappings port)) (gethash text-style (port-text-style-mappings port)))) (defmethod (setf text-style-mapping) (mapping (port basic-port) text-style &optional character-set) (declare (ignore character-set)) (setf (text-style-mapping port (parse-text-style text-style)) mapping)) (defmethod (setf text-style-mapping) (mapping (port basic-port) (text-style text-style) &optional character-set) (declare (ignore character-set)) (when (listp mapping) (error "Delayed mapping is not supported.")) ; FIXME (setf (gethash text-style (port-text-style-mappings port)) mapping)) (defgeneric make-device-font-text-style (port font-name)) (defmethod make-device-font-text-style (port font-name) (let ((text-style (make-instance 'device-font-text-style :display-device port :device-font-name font-name))) (setf (text-style-mapping port text-style) font-name) text-style)) ;;; Text-style utilities (defmethod merge-text-styles (s1 s2) (when (and (typep s1 'text-style) (typep s2 'text-style) (eq s1 s2)) (return-from merge-text-styles s1)) (setq s1 (parse-text-style s1)) (setq s2 (parse-text-style s2)) (if (and (not (device-font-text-style-p s1)) (not (device-font-text-style-p s2))) (let* ((family (or (text-style-family s1) (text-style-family s2))) (face1 (text-style-face s1)) (face2 (text-style-face s2)) (face (if (subsetp '(:bold :italic) (list face1 face2)) '(:bold :italic) (or face1 face2))) (size1 (text-style-size s1)) (size2 (text-style-size s2)) (size (case size1 ((nil) size2) (:smaller (find-smaller-size size2)) (:larger (find-larger-size size2)) (t size1)))) (make-text-style family face size)) s1)) (defun parse-text-style (style) (cond ((text-style-p style) style) ((null style) (make-text-style nil nil nil)) ; ? ((and (listp style) (<= 3 (length style) 4)) (apply #'make-text-style style)) (t (error "Invalid text style specification ~S." style)))) (defmacro with-text-style ((medium text-style) &body body) (when (eq medium t) (setq medium '*standard-output*)) (check-type medium symbol) (with-gensyms (cont) `(flet ((,cont (,medium) ,(declare-ignorable-form* medium) ,@body)) (declare (dynamic-extent #',cont)) (invoke-with-text-style ,medium #',cont (parse-text-style ,text-style))))) (defmethod invoke-with-text-style ((sheet sheet) continuation text-style) (let ((medium (sheet-medium sheet))) ; FIXME: WITH-SHEET-MEDIUM (with-text-style (medium text-style) (funcall continuation sheet)))) (defmethod invoke-with-text-style ((medium medium) continuation text-style) (letf (((medium-text-style medium) (merge-text-styles text-style (medium-merged-text-style medium)))) (funcall continuation medium))) ;;; For compatibility with real CLIM, which apparently lets you call this ;;; on non-CLIM streams. (defmethod invoke-with-text-style ((medium t) continuation text-style) (declare (ignore text-style)) (funcall continuation medium)) (defmacro with-text-family ((medium family) &body body) (declare (type symbol medium)) (when (eq medium t) (setq medium '*standard-output*)) (with-gensyms (cont) `(flet ((,cont (,medium) ,(declare-ignorable-form* medium) ,@body)) (declare (dynamic-extent #',cont)) (invoke-with-text-style ,medium #',cont (make-text-style ,family nil nil))))) (defmacro with-text-face ((medium face) &body body) (declare (type symbol medium)) (when (eq medium t) (setq medium '*standard-output*)) (with-gensyms (cont) `(flet ((,cont (,medium) ,(declare-ignorable-form* medium) ,@body)) (declare (dynamic-extent #',cont)) (invoke-with-text-style ,medium #',cont (make-text-style nil ,face nil))))) (defmacro with-text-size ((medium size) &body body) (declare (type symbol medium)) (when (eq medium t) (setq medium '*standard-output*)) (with-gensyms (cont) `(flet ((,cont (,medium) ,(declare-ignorable-form* medium) ,@body)) (declare (dynamic-extent #',cont)) (invoke-with-text-style ,medium #',cont (make-text-style nil nil ,size))))) ;;; MEDIUM class (defclass transform-coordinates-mixin () ;; This class is reponsible for transforming coordinates in an ;; :around method on medium-draw-xyz. It is currently mixed in into ;; basic-medium and clim-stream-pane. This probably is not the right ;; thing todo. Either clim-stream-pane becomes a basic-medium too or ;; the medium of a stream becomes not the stream itself. So consider ;; this as a hotfix. ;; --GB 2003-05-25 ()) (defclass basic-medium (transform-coordinates-mixin medium) ((foreground :initarg :foreground :initform +black+ :accessor medium-foreground) (background :initarg :background :initform +white+ :accessor medium-background) (ink :initarg :ink :initform +foreground-ink+ :accessor medium-ink) (transformation :type transformation :initarg :transformation :initform +identity-transformation+ :accessor medium-transformation) (clipping-region :type region :initarg :clipping-region :initform +everywhere+ :documentation "Clipping region in the SHEET coordinates.") ;; always use this slot through its accessor, since there may ;; be secondary methods on it -RS 2001-08-23 (line-style :initarg :line-style :initform (make-line-style) :accessor medium-line-style) ;; always use this slot through its accessor, since there may ;; be secondary methods on it -RS 2001-08-23 (text-style :initarg :text-style :initform *default-text-style* :accessor medium-text-style) (default-text-style :initarg :default-text-style :initform *default-text-style* :accessor medium-default-text-style) (sheet :initarg :sheet :initform nil ; this means that medium is not linked to a sheet :reader medium-sheet :writer (setf %medium-sheet) )) (:documentation "The basic class, on which all CLIM mediums are built.")) (defclass ungrafted-medium (basic-medium) ()) (defmethod initialize-instance :after ((medium basic-medium) &rest args) (declare (ignore args)) ;; Initial CLIPPING-REGION is in coordinates, given by initial ;; TRANSFORMATION, but we store it in SHEET's coords. (with-slots (clipping-region) medium (setf clipping-region (transform-region (medium-transformation medium) clipping-region)))) (defmethod medium-clipping-region ((medium medium)) (untransform-region (medium-transformation medium) (slot-value medium 'clipping-region))) (defmethod (setf medium-clipping-region) (region (medium medium)) (setf (slot-value medium 'clipping-region) (transform-region (medium-transformation medium) region))) (defmethod (setf medium-clipping-region) :after (region (medium medium)) (declare (ignore region)) (let ((sheet (medium-sheet medium))) (when sheet (invalidate-cached-regions sheet)))) (defmethod (setf medium-transformation) :after (transformation (medium medium)) (declare (ignore transformation)) (let ((sheet (medium-sheet medium))) (when sheet (invalidate-cached-transformations sheet)))) (defmethod medium-merged-text-style ((medium medium)) (merge-text-styles (medium-text-style medium) (medium-default-text-style medium))) ;; with-sheet-medium moved to output.lisp. --GB ;; with-sheet-medium-bound moved to output.lisp. --GB (defmacro with-pixmap-medium ((medium pixmap) &body body) (let ((old-medium (gensym)) (old-pixmap (gensym))) `(let* ((,old-medium (pixmap-medium ,pixmap)) (,medium (or ,old-medium (make-medium (port ,pixmap) ,pixmap))) (,old-pixmap (medium-sheet ,medium))) (setf (pixmap-medium ,pixmap) ,medium) (setf (%medium-sheet ,medium) ,pixmap) ;is medium a basic medium? --GB (unwind-protect (progn ,@body) (setf (pixmap-medium ,pixmap) ,old-medium) (setf (%medium-sheet ,medium) ,old-pixmap))))) ;;; Medium Device functions (defmethod medium-device-transformation ((medium medium)) (sheet-device-transformation (medium-sheet medium))) (defmethod medium-device-region ((medium medium)) (sheet-device-region (medium-sheet medium))) ;;; Line-Style class (defgeneric line-style-equalp (arg1 arg2)) (defclass standard-line-style (line-style) ((unit :initarg :line-unit :initform :normal :reader line-style-unit :type (member :normal :point :coordinate)) (thickness :initarg :line-thickness :initform 1 :reader line-style-thickness :type real) (joint-shape :initarg :line-joint-shape :initform :miter :reader line-style-joint-shape :type (member :miter :bevel :round :none)) (cap-shape :initarg :line-cap-shape :initform :butt :reader line-style-cap-shape :type (member :butt :square :round :no-end-point)) (dashes :initarg :line-dashes :initform nil :reader line-style-dashes :type (or (member t nil) sequence)) )) (defun make-line-style (&key (unit :normal) (thickness 1) (joint-shape :miter) (cap-shape :butt) (dashes nil)) (make-instance 'standard-line-style :line-unit unit :line-thickness thickness :line-joint-shape joint-shape :line-cap-shape cap-shape :line-dashes dashes)) (defmethod print-object ((self standard-line-style) stream) (print-unreadable-object (self stream :type t :identity nil) (format stream "~{~S ~S~^ ~}" (mapcan (lambda (slot) (when (slot-boundp self slot) (list (intern (symbol-name slot) :keyword) (slot-value self slot)))) '(unit thickness joint-shape cap-shape dashes))))) (defmethod line-style-effective-thickness (line-style medium) ;; FIXME (declare (ignore medium)) (line-style-thickness line-style)) (defmethod medium-miter-limit ((medium medium)) #.(* 2 single-float-epsilon)) (defmethod line-style-equalp ((style1 standard-line-style) (style2 standard-line-style)) (and (eql (line-style-unit style1) (line-style-unit style2)) (eql (line-style-thickness style1) (line-style-thickness style2)) (eql (line-style-joint-shape style1) (line-style-joint-shape style2)) (eql (line-style-cap-shape style1) (line-style-cap-shape style2)) (eql (line-style-dashes style1) (line-style-dashes style2)))) ;;; Misc ops (defmacro with-output-buffered ((medium &optional (buffer-p t)) &body body) (declare (type symbol medium)) (when (eq medium t) (setq medium '*standard-output*)) (let ((old-buffer (gensym))) `(let ((,old-buffer (medium-buffering-output-p ,medium))) (setf (medium-buffering-output-p ,medium) ,buffer-p) (unwind-protect (progn ,@body) (setf (medium-buffering-output-p ,medium) ,old-buffer))))) ;;; BASIC-MEDIUM class (defmacro with-transformed-position ((transformation x y) &body body) `(multiple-value-bind (,x ,y) (transform-position ,transformation ,x ,y) ,@body)) (defmacro with-transformed-distance ((transformation dx dy) &body body) `(multiple-value-bind (,dx ,dy) (transform-distance ,transformation ,dx ,dy) ,@body)) (defmacro with-transformed-positions ((transformation coord-seq) &body body) `(let ((,coord-seq (transform-positions ,transformation ,coord-seq))) ,@body)) ;;; Pixmaps (defmethod medium-copy-area ((from-drawable basic-medium) from-x from-y width height to-drawable to-x to-y) (declare (ignore from-x from-y width height to-drawable to-x to-y)) (error "MEDIUM-COPY-AREA is not implemented for basic MEDIUMs")) (defmethod medium-copy-area (from-drawable from-x from-y width height (to-drawable basic-medium) to-x to-y) (declare (ignore from-drawable from-x from-y width height to-x to-y)) (error "MEDIUM-COPY-AREA is not implemented for basic MEDIUMs")) ;;; Medium-specific Drawing Functions (defmethod medium-draw-point* :around ((medium transform-coordinates-mixin) x y) (let ((tr (medium-transformation medium))) (with-transformed-position (tr x y) (call-next-method medium x y)))) (defmethod medium-draw-points* :around ((medium transform-coordinates-mixin) coord-seq) (let ((tr (medium-transformation medium))) (with-transformed-positions (tr coord-seq) (call-next-method medium coord-seq)))) (defmethod medium-draw-line* :around ((medium transform-coordinates-mixin) x1 y1 x2 y2) (let ((tr (medium-transformation medium))) (with-transformed-position (tr x1 y1) (with-transformed-position (tr x2 y2) (call-next-method medium x1 y1 x2 y2))))) (defmethod medium-draw-lines* :around ((medium transform-coordinates-mixin) coord-seq) (let ((tr (medium-transformation medium))) (with-transformed-positions (tr coord-seq) (call-next-method medium coord-seq)))) (defmethod medium-draw-polygon* :around ((medium transform-coordinates-mixin) coord-seq closed filled) (let ((tr (medium-transformation medium))) (with-transformed-positions (tr coord-seq) (call-next-method medium coord-seq closed filled)))) (defun expand-rectangle-coords (left top right bottom) "Expand the two corners of a rectangle into a polygon coord-seq" (vector left top right top right bottom left bottom)) (defmethod medium-draw-rectangle* :around ((medium transform-coordinates-mixin) left top right bottom filled) (let ((tr (medium-transformation medium))) (if (rectilinear-transformation-p tr) (multiple-value-bind (left top right bottom) (transform-rectangle* tr left top right bottom) (call-next-method medium left top right bottom filled)) (medium-draw-polygon* medium (expand-rectangle-coords left top right bottom) t filled))) ) (defmethod medium-draw-rectangles* :around ((medium transform-coordinates-mixin) position-seq filled) (let ((tr (medium-transformation medium))) (if (rectilinear-transformation-p tr) (call-next-method medium (transform-positions tr position-seq) filled) (do-sequence ((left top right bottom) position-seq) (medium-draw-polygon* medium (vector left top left bottom right bottom right top) t filled))))) (defmethod medium-draw-ellipse* :around ((medium transform-coordinates-mixin) center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy start-angle end-angle filled) (let* ((ellipse (make-elliptical-arc* center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy :start-angle start-angle :end-angle end-angle)) (transformed-ellipse (transform-region (medium-transformation medium) ellipse)) (start-angle (ellipse-start-angle transformed-ellipse)) (end-angle (ellipse-end-angle transformed-ellipse))) (multiple-value-bind (center-x center-y) (ellipse-center-point* transformed-ellipse) (multiple-value-bind (radius-1-dx radius-1-dy radius-2-dx radius-2-dy) (ellipse-radii transformed-ellipse) (call-next-method medium center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy start-angle end-angle filled))))) (defmethod medium-draw-circle* :around ((medium transform-coordinates-mixin) center-x center-y radius start-angle end-angle filled) (let* ((ellipse (make-elliptical-arc* center-x center-y radius 0 0 radius :start-angle start-angle :end-angle end-angle)) (transformed-ellipse (transform-region (medium-transformation medium) ellipse)) (start-angle (ellipse-start-angle transformed-ellipse)) (end-angle (ellipse-end-angle transformed-ellipse))) (multiple-value-bind (center-x center-y) (ellipse-center-point* transformed-ellipse) (call-next-method medium center-x center-y radius start-angle end-angle filled)))) (defmethod medium-draw-text* :around ((medium transform-coordinates-mixin) string x y start end align-x align-y toward-x toward-y transform-glyphs) ;;!!! FIX ME! (let ((tr (medium-transformation medium))) (with-transformed-position (tr x y) (call-next-method medium string x y start end align-x align-y toward-x toward-y transform-glyphs)))) (defmethod medium-draw-glyph :around ((medium transform-coordinates-mixin) element x y align-x align-y toward-x toward-y transform-glyphs) (let ((tr (medium-transformation medium))) (with-transformed-position (tr x y) (call-next-method medium element x y align-x align-y toward-x toward-y transform-glyphs)))) (defmethod medium-copy-area :around ((from-drawable transform-coordinates-mixin) from-x from-y width height to-drawable to-x to-y) (with-transformed-position ((medium-transformation from-drawable) from-x from-y) (call-next-method from-drawable from-x from-y width height to-drawable to-x to-y))) (defmethod medium-copy-area :around (from-drawable from-x from-y width height (to-drawable transform-coordinates-mixin) to-x to-y) (with-transformed-position ((medium-transformation to-drawable) to-x to-y) (call-next-method from-drawable from-x from-y width height to-drawable to-x to-y))) ;;; Fall-through Methods For Multiple Objects Drawing Functions (defmethod medium-draw-points* ((medium transform-coordinates-mixin) coord-seq) (let ((tr (invert-transformation (medium-transformation medium)))) (with-transformed-positions (tr coord-seq) (do-sequence ((x y) coord-seq) (medium-draw-point* medium x y))))) (defmethod medium-draw-lines* ((medium transform-coordinates-mixin) position-seq) (let ((tr (invert-transformation (medium-transformation medium)))) (with-transformed-positions (tr position-seq) (do-sequence ((x1 y1 x2 y2) position-seq) (medium-draw-line* medium x1 y1 x2 y2))))) (defmethod medium-draw-rectangles* ((medium transform-coordinates-mixin) coord-seq filled) (let ((tr (invert-transformation (medium-transformation medium)))) (with-transformed-positions (tr coord-seq) (do-sequence ((x1 y1 x2 y2) coord-seq) (medium-draw-rectangle* medium x1 y1 x2 y2 filled))))) ;;; Other Medium-specific Output Functions (defmethod medium-finish-output ((medium basic-medium)) nil) (defmethod medium-force-output ((medium basic-medium)) nil) (defmethod medium-clear-area ((medium basic-medium) left top right bottom) (draw-rectangle* medium left top right bottom :ink +background-ink+)) (defmethod medium-beep ((medium basic-medium)) nil) ;;;;;;;;; (defmethod engraft-medium ((medium basic-medium) port sheet) (declare (ignore port)) (setf (%medium-sheet medium) sheet) #|| (medium-foreground medium) (medium-foreground sheet) (medium-background medium) (medium-background sheet) (medium-ink medium) (medium-ink sheet) (medium-transformation medium) (medium-transformation sheet) (medium-clipping-region medium) (medium-clipping-region sheet) (medium-line-style medium) (medium-line-style sheet) (medium-text-stle medium) (medium-text-stle sheet) ||# ) (defmethod degraft-medium ((medium basic-medium) port sheet) (declare (ignore port sheet)) (setf (%medium-sheet medium) nil)) (defmethod allocate-medium ((port port) sheet) (make-medium port sheet)) (defmethod deallocate-medium ((port port) medium) (declare (ignorable port medium)) nil) (defmethod port ((medium basic-medium)) (and (medium-sheet medium) (port (medium-sheet medium)))) (defmethod graft ((medium basic-medium)) (and (medium-sheet medium) (graft (medium-sheet medium)))) (defmacro with-special-choices ((medium) &body body) "Macro for optimizing drawing with graphical system dependant mechanisms." (with-gensyms (fn) `(flet ((,fn (,medium) ,(declare-ignorable-form* medium) ,@body)) (declare (dynamic-extent #',fn)) (invoke-with-special-choices #',fn ,medium)))) (defgeneric invoke-with-special-choices (continuation sheet)) (defmethod invoke-with-special-choices (continuation (medium t)) (funcall continuation medium)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/stream-output.lisp0000644000175000017500000004753611345155772020552 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 1998,1999,2000,2001 by Michael McDonald (mikemac@mikemac.com) ;;; (c) copyright 2000 by ;;; Robert Strandh (strandh@labri.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) ;;; Note: in the methods defined on output streams, I often use ;;; the sheet's medium as the argument to the draw-* routines. ;;; This is so that they don't get recorded if the stream also ;;; happens to be an output-recording-stream. - MikeMac 1/7/99 ;;; Standard-Output-Stream class (defclass standard-output-stream (fundamental-character-output-stream) ()) (defmethod stream-recording-p ((stream t)) nil) (defmethod stream-drawing-p ((stream t)) t) #+ignore(defmethod stream-write-char ((stream standard-output-stream) char) (multiple-value-bind (cx cy) (stream-cursor-position stream) (cond ((eq char #\Newline) (setf (stream-cursor-position stream) (value 0 (+ cy (stream-line-height stream) (stream-vertical-spacing stream))))) (t (draw-text* (sheet-medium stream) char cx (+ cy (stream-baseline stream))) (setf (stream-cursor-position stream) (values (+ cx (stream-character-width stream char)) cy)))))) ;;; Cursor class (defgeneric* (setf cursor-position) (x y cursor)) ;;; Cursor-Mixin class (defclass cursor-mixin () ((sheet :initarg :sheet :reader cursor-sheet) (x :initform 0 :initarg :x-position) (y :initform 0 :initarg :y-position) (width :initform 8) (appearance :type (member :solid :hollow) :initarg :appearance :initform :hollow :accessor cursor-appearance) ;; XXX what does "cursor is active" mean? ;; It means that the sheet (stream) updates the cursor, though ;; currently the cursor appears to be always updated after stream ;; text operations. -- moore (cursor-active :initform nil :accessor cursor-active) (cursor-state :initform nil :accessor cursor-state))) (defgeneric cursor-height (cursor)) (defmethod print-object ((cursor cursor-mixin) stream) (with-slots (x y) cursor (print-unreadable-object (cursor stream :type t :identity t) (format stream "~D ~D " x y)))) ;;; XXX What to do when we can't draw the cursor immediately (like, ;;; we're not drawing?) The whole flip-screen-cursor idea breaks down. (defmethod (setf cursor-state) :around (state (cursor cursor-mixin)) (unless (eq state (slot-value cursor 'cursor-state)) (flip-screen-cursor cursor)) (call-next-method)) (defun decode-cursor-visibility (visibility) "Given :on, :off, or nil, returns the needed active and state attributes for the cursor." (ecase visibility ((:on t) (values t t)) (:off (values t nil)) ((nil) (values nil nil)))) (defmethod cursor-visibility ((cursor cursor-mixin)) (let ((a (cursor-active cursor)) (s (cursor-state cursor))) (cond ((and a s) :on) ((and a (not s)) :off) (t nil)))) (defmethod (setf cursor-visibility) (nv (cursor cursor-mixin)) (multiple-value-bind (active state) (decode-cursor-visibility nv) (setf (cursor-state cursor) state (cursor-active cursor) active))) (defmethod cursor-position ((cursor cursor-mixin)) (with-slots (x y) cursor (values x y))) (defmethod* (setf cursor-position) (nx ny (cursor cursor-mixin)) (with-slots (x y) cursor (letf (((cursor-state cursor) nil)) (multiple-value-prog1 (setf (values x y) (values nx ny)))) (when (and (cursor-active cursor) (output-recording-stream-p (cursor-sheet cursor))) (stream-close-text-output-record (cursor-sheet cursor))))) (defmethod flip-screen-cursor ((cursor cursor-mixin)) (when (stream-drawing-p (cursor-sheet cursor)) (with-slots (x y sheet width) cursor (let ((height (cursor-height cursor))) (draw-rectangle* (sheet-medium (cursor-sheet cursor)) x y (+ x width) (+ y height) :filled (ecase (cursor-appearance cursor) (:solid t) (:hollow nil)) :ink +flipping-ink+))))) (defmethod display-cursor ((cursor cursor-mixin) state) (unless (stream-drawing-p (cursor-sheet cursor)) (return-from display-cursor nil)) (with-slots (x y sheet width) cursor (let ((height (cursor-height cursor))) (case state (:draw (draw-rectangle* (sheet-medium (cursor-sheet cursor)) x y (+ x width) (+ y height) :filled (ecase (cursor-appearance cursor) (:solid t) (:hollow nil)) :ink +foreground-ink+ )) (:erase ;; This is how I'd like this to work, as painting over with the background ;; ink is repugnant. I leave this disabled because I'm concerned about ;; infinite recursion if replay-output-record calls here (which Goatee ;; does currently). --Hefner #+nil (repaint-sheet (cursor-sheet cursor) (make-bounding-rectangle x y (+ 1 x width) (+ 1 y height))) (draw-rectangle* (sheet-medium (cursor-sheet cursor)) x y (+ x width) (+ y height) :filled (ecase (cursor-appearance cursor) (:solid t) (:hollow nil)) :ink +background-ink+)))))) ;;; Standard-Text-Cursor class (defclass standard-text-cursor (cursor-mixin cursor) ()) (defmethod cursor-height ((cursor standard-text-cursor)) (slot-value (cursor-sheet cursor) 'height)) ;;; Extended-Output-Stream class (defgeneric* (setf stream-cursor-position) (x y stream)) ;;; Standard-Extended-Output-Stream class (defclass standard-extended-output-stream (extended-output-stream standard-output-stream) ((cursor :accessor stream-text-cursor) (foreground :initarg :foreground :reader stream-foreground) (background :initarg :background :reader stream-background) (text-style :initarg :text-style :reader stream-text-style) (vspace :initarg :vertical-spacing :reader stream-vertical-spacing) (margin :initarg :text-margin :writer (setf stream-text-margin)) (eol :initarg :end-of-line-action :accessor stream-end-of-line-action) (eop :initarg :end-of-page-action :accessor stream-end-of-page-action) (view :initarg :default-view :accessor stream-default-view) (baseline :initform 0 :reader stream-baseline) ;; What is this? --GB (height :initform 0) ;; When the stream takes part in the space alloction protocol, this ;; remembers our demand: (seos-current-width :initform 0) (seos-current-height :initform 0)) (:default-initargs :foreground +black+ :background +white+ :text-style *default-text-style* :vertical-spacing 2 :text-margin nil :end-of-line-action :wrap :end-of-page-action :scroll :default-view +textual-view+)) (defmethod stream-force-output :after ((stream standard-extended-output-stream)) (with-sheet-medium (medium stream) (medium-force-output medium))) (defmethod stream-finish-output :after ((stream standard-extended-output-stream)) (with-sheet-medium (medium stream) (medium-finish-output medium))) (defmethod compose-space ((pane standard-extended-output-stream) &key width height) (declare (ignorable width height)) (with-slots (seos-current-width seos-current-height) pane (make-space-requirement :width seos-current-width :height seos-current-height))) (defmethod initialize-instance :after ((stream standard-extended-output-stream) &rest args) (declare (ignore args)) (setf (stream-text-cursor stream) (make-instance 'standard-text-cursor :sheet stream)) (setf (cursor-active (stream-text-cursor stream)) t)) (defmethod stream-cursor-position ((stream standard-extended-output-stream)) (cursor-position (stream-text-cursor stream))) (defmethod* (setf stream-cursor-position) (x y (stream standard-extended-output-stream)) (setf (cursor-position (stream-text-cursor stream)) (values x y))) (defmethod stream-set-cursor-position ((stream standard-extended-output-stream) x y) (setf (stream-cursor-position stream) (values x y))) (defmethod stream-increment-cursor-position ((stream standard-extended-output-stream) dx dy) (multiple-value-bind (x y) (cursor-position (stream-text-cursor stream)) (let ((dx (or dx 0)) (dy (or dy 0))) (setf (cursor-position (stream-text-cursor stream)) (values (+ x dx) (+ y dy)))))) ;;; (defmethod handle-repaint :around ((stream standard-extended-output-stream) region) (declare (ignorable region)) (let ((cursor (stream-text-cursor stream))) (if (cursor-state cursor) ;; Erase the cursor so that the subsequent flip operation will make a ;; cursor, whether or not the next-method erases the location of the ;; cursor. ;; XXX clip to region? No one else seems to... ;; Sure clip to region! --GB (letf (((cursor-state cursor) nil)) (call-next-method)) (call-next-method)))) (defmethod scroll-vertical ((stream standard-extended-output-stream) dy) (multiple-value-bind (tx ty) (bounding-rectangle-position (sheet-region stream)) (scroll-extent stream tx (+ ty dy)))) (defmethod scroll-horizontal ((stream standard-extended-output-stream) dx) (multiple-value-bind (tx ty) (bounding-rectangle-position (sheet-region stream)) (scroll-extent stream (+ tx dx) ty))) (defmacro with-cursor-off (stream &body body) `(letf (((cursor-visibility (stream-text-cursor ,stream)) nil)) ,@body)) (defmethod stream-wrap-line ((stream standard-extended-output-stream)) (let ((margin (stream-text-margin stream))) (multiple-value-bind (cx cy) (stream-cursor-position stream) (declare (ignore cx)) (draw-rectangle* (sheet-medium stream) margin cy (+ margin 4) (+ cy (slot-value stream 'height)) :ink +foreground-ink+ :filled t))) (stream-write-char stream #\newline)) (defun seos-write-string (stream string &optional (start 0) end) (let* ((medium (sheet-medium stream)) (text-style (medium-text-style medium)) (new-baseline (text-style-ascent text-style medium)) (new-height (text-style-height text-style medium)) (margin (stream-text-margin stream)) (end (or end (length string)))) (flet ((find-split (delta) ;; FIXME: This can be done smarter. (loop for i from (1+ start) upto end as sub-width = (stream-string-width stream string :start start :end i :text-style text-style) while (<= sub-width delta) finally (return (1- i))))) (when (eql end 0) (return-from seos-write-string)) (with-slots (baseline height vspace) stream (multiple-value-bind (cx cy) (stream-cursor-position stream) (when (> new-baseline baseline) ;;(when (or (> baseline 0) ;; (> height 0)) ;; (scroll-vertical stream (- new-baseline baseline)) ;; ) ; the beginning of the line should be moved down, but not the whole stream -- APD, 2002-06-18 (setq baseline new-baseline)) (if (> new-height height) (setq height new-height)) (let ((width (stream-string-width stream string :start start :end end :text-style text-style)) (split end)) (when (>= (+ cx width) margin) (ecase (stream-end-of-line-action stream) (:wrap ;; Let's prevent infinite recursion if there isn't ;; room for even a single character. (setq split (max (find-split (- margin cx)) (1+ start)))) (:scroll (scroll-horizontal stream width)) (:allow))) (unless (= start split) (stream-write-output stream string nil start split) (setq cx (+ cx width)) (with-slots (x y) (stream-text-cursor stream) (setf x cx y cy))) (when (/= split end) (let ((current-baseline baseline)) (setf baseline current-baseline)) ; (stream-wrap-line stream) ; (multiple-value-bind (new-cx new-cy) (stream-cursor-position stream) ; (setf cx new-cx ; cy new-cy ; baseline current-baseline) ; (setf (stream-cursor-position stream) (values cx cy)))) (stream-wrap-line stream) (seos-write-string stream string split end)) )))))) (defun seos-write-newline (stream) (let ((medium (sheet-medium stream)) (%view-height (bounding-rectangle-height (or (pane-viewport stream) stream))) (view-height (bounding-rectangle-height stream))) (with-slots (baseline height vspace) stream (multiple-value-bind (cx cy) (stream-cursor-position stream) (setf height (max height (text-style-height (medium-text-style medium) medium))) (setf cx 0 cy (+ cy height vspace)) (when (> (+ cy height) view-height) (ecase (stream-end-of-page-action stream) ((:scroll :allow) (change-space-requirements stream :width (bounding-rectangle-width stream) :height (+ cy height)) ;;(scroll-vertical stream (+ height vspace)) ) (:wrap (setq cy 0)))) (unless (eq :allow (stream-end-of-page-action stream)) (scroll-extent stream 0 (max 0 (- (+ cy height) %view-height)))) ;; mikemac says that this "erase the new line" behavior is ;; required by the stream text protocol, but I don't see ;; it. I'm happy to put this back in again, but in the ;; meantime it makes debugging of updating-output a bit easier ;; not to have "extra" records laying around. If/When it goes ;; back in... the draw-rectangle has to happen on the stream, ;; not the medium. -- moore #+nil(draw-rectangle* medium cx cy (+ margin 4) (+ cy height) :ink +background-ink+ :filled t) (setq baseline 0 height 0) (setf (stream-cursor-position stream) (values cx cy)))))) (defgeneric stream-write-output (stream line string-width &optional start end) (:documentation "Writes the character or string LINE to STREAM. This function produces no more than one line of output i.e., doesn't wrap. If STRING-WIDTH is non-nil, that is used as the width where needed; otherwise STREAM-STRING-WIDTH will be called.")) ;;; The cursor is in stream coordinates. (defmethod stream-write-output (stream line string-width &optional (start 0) end) (declare (ignore string-width)) (with-slots (baseline vspace) stream (multiple-value-bind (cx cy) (stream-cursor-position stream) (draw-text* (sheet-medium stream) line cx (+ cy baseline) :transformation +identity-transformation+ :start start :end end)))) (defmethod stream-write-char ((stream standard-extended-output-stream) char) (with-cursor-off stream (if (char= #\Newline char) (seos-write-newline stream) (seos-write-string stream (string char))))) ;;; I added the (subseq string seg-start ...) forms. Under ACL, there is some ;;; wierd interaction with FORMAT. This shows up as overwritten text in the ;;; pointer documentation and in menus. It acts like a shared buffer is being corrupted ;;; but I can't narrow it down. Using SUBSEQ does fix this interaction that's been ;;; here since 4/16/03 - Mikemac 12/6/2003 (defmethod stream-write-string ((stream standard-extended-output-stream) string &optional (start 0) end) (let ((seg-start start) (end (or end (length string)))) (with-cursor-off stream (loop for i from start below end do (when (char= #\Newline (char string i)) (seos-write-string stream (subseq string seg-start i)) (seos-write-newline stream) (setq seg-start (1+ i)))) (seos-write-string stream (subseq string seg-start end))))) ;(defmethod stream-write-string ((stream standard-extended-output-stream) string ; &optional (start 0) end) ; (if (null end) ; (setq end (length string))) ; (with-room-for-line ; (loop for i from start below end ; for char = (aref string i) ; do (do-char)))) (defmethod stream-character-width ((stream standard-extended-output-stream) char &key (text-style nil)) (with-sheet-medium (medium stream) (text-style-character-width (or text-style (medium-text-style medium)) medium char))) (defmethod stream-string-width ((stream standard-extended-output-stream) string &key (start 0) (end nil) (text-style nil)) (with-sheet-medium (medium stream) (if (null text-style) (setq text-style (medium-text-style (sheet-medium stream)))) (multiple-value-bind (total-width total-height final-x final-y baseline) (text-size medium string :text-style text-style :start start :end end) (declare (ignore total-height final-y baseline)) (values final-x total-width)))) (defmethod stream-text-margin ((stream standard-extended-output-stream)) (with-slots (margin) stream (or margin (- (bounding-rectangle-width (or (pane-viewport stream) stream)) (text-size stream "O"))))) (defmethod stream-line-height ((stream standard-extended-output-stream) &key (text-style nil)) (+ (text-style-height (or text-style (medium-text-style (sheet-medium stream))) (sheet-medium stream)) (stream-vertical-spacing stream))) (defmethod stream-line-column ((stream standard-extended-output-stream)) (multiple-value-bind (x y) (stream-cursor-position stream) (declare (ignore y)) (floor x (stream-string-width stream " ")))) (defmethod stream-start-line-p ((stream standard-extended-output-stream)) (multiple-value-bind (x y) (stream-cursor-position stream) (declare (ignore y)) (zerop x))) (defmacro with-room-for-graphics ((&optional (stream t) &rest arguments &key (first-quadrant t) height (move-cursor t) (record-type ''standard-sequence-output-record)) &body body) (declare (ignore first-quadrant height move-cursor record-type)) (let ((cont (gensym "CONT.")) (stream (stream-designator-symbol stream '*standard-output*))) `(labels ((,cont (,stream) ,@body)) (declare (dynamic-extent #',cont)) (invoke-with-room-for-graphics #',cont ,stream ,@arguments)))) (defmacro with-end-of-line-action ((stream action) &body body) (when (eq stream t) (setq stream '*standard-output*)) (check-type stream symbol) `(letf (((stream-end-of-line-action ,stream) ,action)) ,@body)) (defmacro with-end-of-page-action ((stream action) &body body) (when (eq stream t) (setq stream '*standard-output*)) (check-type stream symbol) `(letf (((stream-end-of-page-action ,stream) ,action)) ,@body)) (defmethod beep (&optional medium) (if medium (medium-beep medium) (when (sheetp *standard-output*) (medium-beep (sheet-medium *standard-output*))))) (defmethod scroll-quantum ((sheet standard-extended-output-stream)) (stream-line-height sheet)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/graphics.lisp0000644000175000017500000014755211345155771017517 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 1998,1999,2000,2001 by Michael McDonald (mikemac@mikemac.com) ;;; (c) copyright 2001 by Arnaud Rouanet (rouanet@emi.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) ;;; Work in progress that reduces consing of rest arguments and keyword ;;; processing. (defmacro with-medium-and-options ((sheet &key ink clipping-region transformation line-unit line-thickness line-style line-style-p line-dashes dashes-p line-joint-shape line-cap-shape text-style text-style-p text-family text-family-p text-face text-face-p text-size text-size-p) (medium) &body body) (with-gensyms (continuation sheet-medium) `(flet ((,continuation (,medium) ,@body)) (declare (dynamic-extent #',continuation)) (with-sheet-medium (,sheet-medium ,sheet) (do-graphics-with-options-internal-1 ,sheet-medium #'continuation ,ink ,clipping-region ,transformation ,line-unit ,line-thickness ,line-style ,line-style-p ,line-dashes ,dashes-p ,line-joint-shape ,line-cap-shape ,text-style ,text-style-p ,text-family ,text-family-p ,text-face ,text-face-p ,text-size ,text-size-p)))) ) (defmethod do-graphics-with-options ((sheet sheet) func &rest options) (with-sheet-medium (medium sheet) (apply #'do-graphics-with-options-internal medium sheet func options))) (defmethod do-graphics-with-options ((medium medium) func &rest options) (apply #'do-graphics-with-options-internal medium medium func options)) (defmethod do-graphics-with-options ((sheet t) func &rest options) (declare (ignore options)) (if sheet (funcall func sheet))) (defmethod do-graphics-with-options ((pixmap pixmap) func &rest options) (with-pixmap-medium (medium pixmap) (apply #'do-graphics-with-options-internal medium medium func options))) (defmethod do-graphics-with-options-internal ((medium medium) orig-medium func &rest args &key ink clipping-region transformation line-unit line-thickness (line-style nil line-style-p) (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) &allow-other-keys) (declare (ignore args)) (let ((old-ink (medium-ink medium)) (old-clip (medium-clipping-region medium)) (old-transform (medium-transformation medium)) (old-line-style (medium-line-style medium)) (old-text-style (medium-text-style medium)) (changed-line-style line-style-p) (changed-text-style text-style-p)) (unwind-protect (progn (when (eq ink old-ink) (setf ink nil)) (when ink (setf (medium-ink medium) ink)) (when transformation (setf (medium-transformation medium) (compose-transformations old-transform transformation))) (when (and clipping-region old-clip (or (eq clipping-region +everywhere+) (eq clipping-region old-clip) (region-contains-region-p clipping-region old-clip)) #+NIL (region-equal clipping-region old-clip)) (setf clipping-region nil)) (when clipping-region (setf (medium-clipping-region medium) (region-intersection (if transformation (transform-region transformation old-clip) old-clip) clipping-region))) (when (null line-style) (setf line-style old-line-style)) (when (or line-unit line-thickness dashes-p line-joint-shape line-cap-shape) (setf changed-line-style t) (setf line-style (make-line-style :unit (or line-unit (line-style-unit line-style)) :thickness (or line-thickness (line-style-thickness line-style)) :dashes (or line-dashes (line-style-dashes line-style)) :joint-shape (or line-joint-shape (line-style-joint-shape line-style)) :cap-shape (or line-cap-shape (line-style-cap-shape line-style))))) (when changed-line-style (setf (medium-line-style medium) line-style)) (if text-style-p (setf text-style (merge-text-styles text-style (medium-merged-text-style medium))) (setf text-style (medium-merged-text-style medium))) (when (or text-family-p text-face-p text-size-p) (setf changed-text-style t) (setf text-style (merge-text-styles (make-text-style text-family text-face text-size) text-style))) (when changed-text-style (setf (medium-text-style medium) text-style)) (when orig-medium (funcall func orig-medium))) (when ink (setf (medium-ink medium) old-ink)) ;; First set transformation, then clipping! (when transformation (setf (medium-transformation medium) old-transform)) (when clipping-region (setf (medium-clipping-region medium) old-clip)) (when changed-line-style (setf (medium-line-style medium) old-line-style)) (when changed-text-style (setf (medium-text-style medium) old-text-style))))) (defmacro with-medium-options ((sheet args) &body body) `(flet ((graphics-op (medium) (declare (ignorable medium)) ,@body)) #-clisp (declare (dynamic-extent #'graphics-op)) (apply #'do-graphics-with-options ,sheet #'graphics-op ,args))) (defmacro with-drawing-options ((medium &rest drawing-options) &body body) (setq medium (stream-designator-symbol medium '*standard-output*)) (with-gensyms (gcontinuation cont-arg) `(flet ((,gcontinuation (,cont-arg) (declare (ignore ,cont-arg)) ,@body)) #-clisp (declare (dynamic-extent #',gcontinuation)) (apply #'invoke-with-drawing-options ,medium #',gcontinuation (list ,@drawing-options))))) (defmethod invoke-with-drawing-options ((medium medium) continuation &rest drawing-options &key ink transformation clipping-region line-style text-style &allow-other-keys) (declare (ignore ink transformation clipping-region line-style text-style)) (with-medium-options (medium drawing-options) (funcall continuation medium))) (defmethod invoke-with-drawing-options ((sheet sheet) continuation &rest drawing-options) (with-sheet-medium (medium sheet) (with-medium-options (medium drawing-options) (funcall continuation medium)))) ;;; Compatibility with real CLIM (defmethod invoke-with-drawing-options ((sheet t) continuation &rest drawing-options) (declare (ignore drawing-options)) (funcall continuation sheet)) (defmethod invoke-with-identity-transformation ((sheet sheet) continuation) (with-sheet-medium (medium sheet) (letf (((medium-transformation medium) +identity-transformation+)) (funcall continuation sheet)))) (defmethod invoke-with-identity-transformation ((destination pixmap) continuation) (with-pixmap-medium (medium destination) (letf (((medium-transformation medium) +identity-transformation+)) (funcall continuation destination)))) (defmethod invoke-with-identity-transformation ((medium medium) continuation) (letf (((medium-transformation medium) +identity-transformation+)) (funcall continuation medium))) (defmethod invoke-with-local-coordinates (medium cont x y) ;; For now we do as real CLIM does. ;; Default seems to be the cursor position. ;; Moore suggests we use (0,0) if medium is no stream. ;; ;; Further the specification is vague about possible scalings ... ;; (unless (and x y) (multiple-value-bind (cx cy) (if (extended-output-stream-p medium) (stream-cursor-position medium) (values 0 0)) (setf x (or x cx) y (or y cy)))) (multiple-value-bind (mxx mxy myy myx tx ty) (get-transformation (medium-transformation medium)) (declare (ignore tx ty)) (with-identity-transformation (medium) (with-drawing-options (medium :transformation (make-transformation mxx mxy myy myx x y)) (funcall cont medium))))) (defmethod invoke-with-first-quadrant-coordinates (medium cont x y) ;; First we do the same as invoke-with-local-coordinates but rotate and ;; deskew it so that it becomes first-quadrant. We do this ;; by simply measuring the length of the transfomed x and y "unit vectors". ;; [That is (0,0)-(1,0) and (0,0)-(0,1)] and setting up a transformation ;; which features an upward pointing y-axis and a right pointing x-axis with ;; a length equal to above measured vectors. (unless (and x y) (multiple-value-bind (cx cy) (if (extended-output-stream-p medium) (stream-cursor-position medium) (values 0 0)) (setf x (or x cx) y (or y cy)))) (let* ((tr (medium-transformation medium)) (xlen (multiple-value-bind (dx dy) (transform-distance tr 1 0) (sqrt (+ (expt dx 2) (expt dy 2))))) (ylen (multiple-value-bind (dx dy) (transform-distance tr 0 1) (sqrt (+ (expt dx 2) (expt dy 2)))))) (with-identity-transformation (medium) (with-drawing-options (medium :transformation (make-transformation xlen 0 0 (- ylen) x y)) (funcall cont medium))))) (defun draw-point (sheet point &rest args &key ink clipping-region transformation line-style line-thickness line-unit) (declare (ignore ink clipping-region transformation line-style line-thickness line-unit)) (with-medium-options (sheet args) (multiple-value-bind (x y) (point-position point) (medium-draw-point* medium x y)))) (defun draw-point* (sheet x y &rest args &key ink clipping-region transformation line-style line-thickness line-unit) (declare (ignore ink clipping-region transformation line-style line-thickness line-unit)) (with-medium-options (sheet args) (medium-draw-point* medium x y))) (defun expand-point-seq (point-seq) (let ((coord-seq nil)) (do-sequence (point point-seq) (multiple-value-bind (x y) (point-position point) (setq coord-seq (list* y x coord-seq)))) (nreverse coord-seq))) (defun draw-points (sheet point-seq &rest args &key ink clipping-region transformation line-style line-thickness line-unit) (declare (ignore ink clipping-region transformation line-style line-thickness line-unit)) (with-medium-options (sheet args) (medium-draw-points* medium (expand-point-seq point-seq)))) (defun draw-points* (sheet coord-seq &rest args &key ink clipping-region transformation line-style line-thickness line-unit) (declare (ignore ink clipping-region transformation line-style line-thickness line-unit)) (with-medium-options (sheet args) (medium-draw-points* medium coord-seq))) (defun draw-line (sheet point1 point2 &rest args &key ink clipping-region transformation line-style line-thickness line-unit line-dashes line-cap-shape) (declare (ignore ink clipping-region transformation line-style line-thickness line-unit line-dashes line-cap-shape)) (with-medium-options (sheet args) (multiple-value-bind (x1 y1) (point-position point1) (multiple-value-bind (x2 y2) (point-position point2) (medium-draw-line* medium x1 y1 x2 y2))))) (defun draw-line* (sheet x1 y1 x2 y2 &rest args &key ink clipping-region transformation line-style line-thickness line-unit line-dashes line-cap-shape) (declare (ignore ink clipping-region transformation line-style line-thickness line-unit line-dashes line-cap-shape)) (with-medium-options (sheet args) (medium-draw-line* medium x1 y1 x2 y2))) (defun draw-lines (sheet point-seq &rest args &key ink clipping-region transformation line-style line-thickness line-unit line-dashes line-cap-shape) (declare (ignore ink clipping-region transformation line-style line-thickness line-unit line-dashes line-cap-shape)) (with-medium-options (sheet args) (medium-draw-lines* medium (expand-point-seq point-seq)))) (defun draw-lines* (sheet coord-seq &rest args &key ink clipping-region transformation line-style line-thickness line-unit line-dashes line-cap-shape) (declare (ignore ink clipping-region transformation line-style line-thickness line-unit line-dashes line-cap-shape)) (with-medium-options (sheet args) (medium-draw-lines* medium coord-seq))) (defun draw-polygon (sheet point-seq &rest args &key (filled t) (closed t) ink clipping-region transformation line-style line-thickness line-unit line-dashes line-joint-shape line-cap-shape) (declare (ignore ink clipping-region transformation line-style line-thickness line-unit line-dashes line-joint-shape line-cap-shape)) (with-medium-options (sheet args) (medium-draw-polygon* medium (expand-point-seq point-seq) closed filled))) (defun draw-polygon* (sheet coord-seq &rest args &key (filled t) (closed t) ink clipping-region transformation line-style line-thickness line-unit line-dashes line-joint-shape line-cap-shape) (declare (ignore ink clipping-region transformation line-style line-thickness line-unit line-dashes line-joint-shape line-cap-shape)) (with-medium-options (sheet args) (medium-draw-polygon* medium coord-seq closed filled))) (defun draw-rectangle (sheet point1 point2 &rest args &key (filled t) ink clipping-region transformation line-style line-thickness line-unit line-dashes line-joint-shape) (declare (ignore ink clipping-region transformation line-style line-thickness line-unit line-dashes line-joint-shape)) (with-medium-options (sheet args) (multiple-value-bind (x1 y1) (point-position point1) (multiple-value-bind (x2 y2) (point-position point2) (medium-draw-rectangle* medium x1 y1 x2 y2 filled))))) (defun draw-rectangle* (sheet x1 y1 x2 y2 &rest args &key (filled t) ink clipping-region transformation line-style line-thickness line-unit line-dashes line-joint-shape) (declare (ignore ink clipping-region transformation line-style line-thickness line-unit line-dashes line-joint-shape)) (with-medium-options (sheet args) (medium-draw-rectangle* medium x1 y1 x2 y2 filled))) (defun draw-rectangles (sheet points &rest args &key (filled t) ink clipping-region transformation line-style line-thickness line-unit line-dashes line-joint-shape) (declare (ignore ink clipping-region transformation line-style line-thickness line-unit line-dashes line-joint-shape)) (with-medium-options (sheet args) (loop for point in points nconcing (multiple-value-bind (x y) (point-position point) (list x y)) into position-seq finally (medium-draw-rectangles* medium position-seq filled)))) (defun draw-rectangles* (sheet position-seq &rest args &key (filled t) ink clipping-region transformation line-style line-thickness line-unit line-dashes line-joint-shape) (declare (ignore ink clipping-region transformation line-style line-thickness line-unit line-dashes line-joint-shape)) (with-medium-options (sheet args) (medium-draw-rectangles* medium position-seq filled))) (defun draw-triangle (sheet point1 point2 point3 &rest args &key (filled t) ink clipping-region transformation line-style line-thickness line-unit line-dashes line-joint-shape) (declare (ignore ink clipping-region transformation line-style line-thickness line-unit line-dashes line-joint-shape)) (apply #'draw-polygon sheet (list point1 point2 point3) :filled filled :closed t args)) (defun draw-triangle* (sheet x1 y1 x2 y2 x3 y3 &rest args &key (filled t) ink clipping-region transformation line-style line-thickness line-unit line-dashes line-joint-shape) (declare (ignore ink clipping-region transformation line-style line-thickness line-unit line-dashes line-joint-shape)) (apply #'draw-polygon* sheet (list x1 y1 x2 y2 x3 y3) :filled filled :closed t args)) (defun draw-ellipse (sheet center-point radius-1-dx radius-1-dy radius-2-dx radius-2-dy &rest args &key (filled t) (start-angle 0.0) (end-angle (* 2.0 pi)) ink clipping-region transformation line-style line-thickness line-unit line-dashes line-cap-shape) (declare (ignore ink clipping-region transformation line-style line-thickness line-unit line-dashes line-cap-shape)) (with-medium-options (sheet args) (multiple-value-bind (center-x center-y) (point-position center-point) (medium-draw-ellipse* medium center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy start-angle end-angle filled)))) (defun draw-ellipse* (sheet center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy &rest args &key (filled t) (start-angle 0.0) (end-angle (* 2.0 pi)) ink clipping-region transformation line-style line-thickness line-unit line-dashes line-cap-shape) (declare (ignore ink clipping-region transformation line-style line-thickness line-unit line-dashes line-cap-shape)) (with-medium-options (sheet args) (medium-draw-ellipse* medium center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy start-angle end-angle filled))) (defun draw-circle (sheet center-point radius &rest args &key (filled t) (start-angle 0.0) (end-angle (* 2.0 pi)) ink clipping-region transformation line-style line-thickness line-unit line-dashes line-cap-shape) (declare (ignore ink clipping-region transformation line-style line-thickness line-unit line-dashes line-cap-shape)) (with-medium-options (sheet args) (multiple-value-bind (center-x center-y) (point-position center-point) (medium-draw-ellipse* medium center-x center-y radius 0 0 radius start-angle end-angle filled)))) (defun draw-circle* (sheet center-x center-y radius &rest args &key (filled t) (start-angle 0.0) (end-angle (* 2.0 pi)) ink clipping-region transformation line-style line-thickness line-unit line-dashes line-cap-shape) (declare (ignore ink clipping-region transformation line-style line-thickness line-unit line-dashes line-cap-shape)) (with-medium-options (sheet args) (medium-draw-ellipse* medium center-x center-y radius 0 0 radius start-angle end-angle filled))) (defun draw-text (sheet string point &rest args &key (start 0) (end nil) (align-x :left) (align-y :baseline) (toward-point nil toward-point-p) transform-glyphs ink clipping-region transformation text-style text-family text-face text-size) (declare (ignore ink clipping-region transformation text-style text-family text-face text-size)) (with-medium-options (sheet args) (multiple-value-bind (x y) (point-position point) (multiple-value-bind (toward-x toward-y) (if toward-point-p (point-position toward-point) (values (1+ x) y)) (medium-draw-text* medium string x y start end align-x align-y toward-x toward-y transform-glyphs))))) (defun draw-text* (sheet string x y &rest args &key (start 0) (end nil) (align-x :left) (align-y :baseline) (toward-x (1+ x)) (toward-y y) transform-glyphs ink clipping-region transformation text-style text-family text-face text-size) (declare (ignore ink clipping-region transformation text-style text-family text-face text-size)) (with-medium-options (sheet args) (medium-draw-text* medium string x y start end align-x align-y toward-x toward-y transform-glyphs))) ;; This function belong to the extensions package. (defun draw-glyph (sheet string x y &rest args &key (align-x :left) (align-y :baseline) toward-x toward-y transform-glyphs ink clipping-region transformation text-style text-family text-face text-size) "Draws a single character of filled text represented by the given element. element is a character or other object to be translated into a font index. The given x and y specify the left baseline position for the character." (declare (ignore ink clipping-region transformation text-style text-family text-face text-size)) (with-medium-options (sheet args) (medium-draw-glyph medium string x y align-x align-y toward-x toward-y transform-glyphs))) (defun draw-arrow (sheet point-1 point-2 &rest args &key ink clipping-region transformation line-style line-thickness line-unit line-dashes line-cap-shape (to-head t) from-head (head-length 10) (head-width 5)) (declare (ignore ink clipping-region transformation line-style line-thickness line-unit line-dashes line-cap-shape to-head from-head head-length head-width)) (multiple-value-bind (x1 y1) (point-position point-1) (multiple-value-bind (x2 y2) (point-position point-2) (apply #'draw-arrow* sheet x1 y1 x2 y2 args)))) (defun draw-arrow* (sheet x1 y1 x2 y2 &rest args &key ink clipping-region transformation line-style line-thickness line-unit line-dashes line-cap-shape (to-head t) from-head (head-length 10) (head-width 5)) (declare (ignore ink clipping-region transformation line-style line-thickness line-unit line-dashes line-cap-shape)) (with-medium-options (sheet args) (with-translation (sheet x2 y2) (with-rotation (sheet (atan* (- x1 x2) (- y1 y2))) (let* ((end 0.0) (start (sqrt (+ (expt (- x2 x1) 2) (expt (- y2 y1) 2)))) (p end) (q start) (line-style (medium-line-style sheet)) ;; FIXME: I believe this thickness is in "line-style-units", ;; which are only coincidentally the same as pixel coorindates ;; on screen backends, using :normal units. There is no function ;; documented for converting the units to stream coordinates. (thickness (multiple-value-bind (dx dy) (transform-distance (invert-transformation (medium-transformation sheet)) (line-style-thickness line-style) 0) (sqrt (+ (* dx dx) (* dy dy))))) (width/2 (/ head-width 2)) (a (atan (/ width/2 head-length))) (offset (if (and head-length (not (zerop head-length))) (/ thickness (* 2 (sin a ))) 0.0)) (tip-to-peak (+ head-length offset (- (* thickness 0.5 (sin a)))))) ;; okay, a guess.. (when to-head (incf p offset)) (when from-head (decf q offset)) (if (and to-head from-head (< (abs (- start end)) (* 2 tip-to-peak))) (let ((width (* 0.5 (+ head-width thickness) (/ (abs (- start end)) (* 2 tip-to-peak)) ))) (draw-polygon* sheet (list end 0 (/ start 2) width start 0 (/ start 2) (- width)) :filled t :line-thickness 0)) (progn (when to-head (draw-polygon* sheet (list (+ p head-length) (- width/2) p 0 (+ p head-length) width/2) :filled nil :closed nil)) (when from-head (draw-polygon* sheet (list (- q head-length) (- width/2) q 0 (- q head-length) width/2) :filled nil :closed nil)) (unless (< q p) (draw-line* sheet q 0 p 0)))) ))))) (defun draw-oval (sheet center-pt x-radius y-radius &rest args &key (filled t) ink clipping-region transformation line-style line-thickness line-unit line-dashes line-cap-shape) (declare (ignore filled ink clipping-region transformation line-style line-thickness line-unit line-dashes line-cap-shape)) (multiple-value-bind (x1 y1) (point-position center-pt) (apply #'draw-oval* sheet x1 y1 x-radius y-radius args))) (defun draw-oval* (sheet center-x center-y x-radius y-radius &rest args &key (filled t) ink clipping-region transformation line-style line-thickness line-unit line-dashes line-cap-shape) (declare (ignore ink clipping-region transformation line-style line-thickness line-unit line-dashes line-cap-shape)) (check-type x-radius (real 0)) (check-type y-radius (real 0)) (if (or (coordinate= x-radius 0) (coordinate= y-radius 0)) (draw-circle* sheet center-x center-y (max x-radius y-radius) :filled filled) (with-medium-options (sheet args) (if (coordinate<= y-radius x-radius) (let ((x1 (- center-x x-radius)) (x2 (+ center-x x-radius)) (y1 (- center-y y-radius)) (y2 (+ center-y y-radius))) (if filled ;; Kludge coordinates, sometimes due to rounding the lines don't connect. (draw-rectangle* sheet (floor x1) y1 (ceiling x2) y2) (draw-lines* sheet (list (floor x1) y1 (ceiling x2) y1 (floor x1) y2 (ceiling x2) y2))) (draw-circle* sheet x1 center-y y-radius :filled filled :start-angle (* pi 0.5) :end-angle (* pi 1.5)) (draw-circle* sheet x2 center-y y-radius :filled filled :start-angle (* pi 1.5) :end-angle (* pi 2.5))) (with-rotation (sheet (/ pi 2) (make-point center-x center-y)) (draw-oval* sheet center-x center-y y-radius x-radius :filled filled)) )))) ;;; Pixmap functions (defmethod copy-to-pixmap ((medium medium) medium-x medium-y width height &optional pixmap (pixmap-x 0) (pixmap-y 0)) (unless pixmap (setq pixmap (allocate-pixmap medium (+ pixmap-x width) (+ pixmap-y height)))) (medium-copy-area medium medium-x medium-y width height pixmap pixmap-x pixmap-y) pixmap) (defmethod copy-to-pixmap ((sheet sheet) sheet-x sheet-y width height &optional pixmap (pixmap-x 0) (pixmap-y 0)) (copy-to-pixmap (sheet-medium sheet) sheet-x sheet-y width height pixmap pixmap-x pixmap-y)) (defmethod copy-from-pixmap (pixmap pixmap-x pixmap-y width height (medium medium) medium-x medium-y) (medium-copy-area pixmap pixmap-x pixmap-y width height medium medium-x medium-y) pixmap) (defmethod copy-from-pixmap (pixmap pixmap-x pixmap-y width height (sheet sheet) sheet-x sheet-y) (medium-copy-area pixmap pixmap-x pixmap-y width height (sheet-medium sheet) sheet-x sheet-y)) (defmethod copy-area ((medium medium) from-x from-y width height to-x to-y) (medium-copy-area medium from-x from-y width height medium to-x to-y)) (defmethod copy-area ((sheet sheet) from-x from-y width height to-x to-y) (copy-area (sheet-medium sheet) from-x from-y width height to-x to-y)) (defmethod copy-area ((stream stream) from-x from-y width height to-x to-y) (if (sheetp stream) (copy-area (sheet-medium stream) from-x from-y width height to-x to-y) (error "COPY-AREA on a stream is not implemented"))) ;;; XXX The modification of the sheet argument to hold the pixmap medium seems ;;; completely incorrect here; the description of the macro in the spec says ;;; nothing about that. On the other hand, the spec talks about "medium-var" ;;; when that is clearly meant to be a stream (and an output-recording stream ;;; at that, if the example in the Franz user guide is to be believed). What a ;;; mess. I think we need a pixmap output recording stream in order to do this ;;; right. -- moore (defmacro with-output-to-pixmap ((medium-var sheet &key width height) &body body) (if (and width height) `(let* ((pixmap (allocate-pixmap ,sheet ,width ,height)) (,medium-var (make-medium (port ,sheet) pixmap)) (old-medium (sheet-medium ,sheet))) (setf (slot-value pixmap 'medium) ,medium-var) ; hmm, [seems to work] -- BTS (setf (%sheet-medium ,sheet) ,medium-var) ;is sheet a sheet-with-medium-mixin? --GB (unwind-protect (progn ,@body) (setf (%sheet-medium ,sheet) old-medium)) ;is sheet a sheet-with-medium-mixin? --GB pixmap) (let ((record (gensym "OUTPUT-RECORD-"))) ;; rudi (2005-09-05) What to do when only width or height are ;; given? And what's the meaning of medium-var? `(let* ((,medium-var ,sheet) (,record (with-output-to-output-record (,medium-var) ,@body))) (with-output-to-pixmap (,medium-var ,sheet :width ,(or width `(bounding-rectangle-width ,record)) :height ,(or height `(bounding-rectangle-height ,record))) (replay-output-record ,record ,sheet)))))) ;;; XXX This seems to be incorrect. ;;; This presumes that your drawing will completely fill the bounding rectangle ;;; of the sheet and will effectively randomize anything that isn't drawn ;;; within it. ;;; FIXME #+nil (defmacro with-double-buffering ((sheet) &body body) (let ((width (gensym)) (height (gensym)) (pixmap (gensym)) (sheet-mirror (gensym))) `(let* ((,width (round (bounding-rectangle-width (sheet-region ,sheet)))) (,height (round (bounding-rectangle-height (sheet-region ,sheet)))) (,(gensym) (progn (format *debug-io* "w-d-b ~A ~A~%" ,width ,height) (finish-output *debug-io*) 0)) (,pixmap (allocate-pixmap ,sheet ,width ,height)) (,sheet-mirror (sheet-direct-mirror ,sheet))) (unwind-protect (progn (setf (sheet-direct-mirror ,sheet) (pixmap-mirror ,pixmap)) ,@body (setf (sheet-direct-mirror ,sheet) ,sheet-mirror) ; v-- the sheet might have been degrafted while we weren't looking ; in which case, we shouldn't blit it back (copy-from-pixmap ,pixmap 0 0 ,width ,height ,sheet 0 0)) (deallocate-pixmap ,pixmap))))) ;;; Another attempt (defun invoke-with-double-buffering (sheet continuation x1 y1 x2 y2) (let* ((medium (sheet-medium sheet)) (sheet-transform (sheet-native-transformation sheet)) (medium-transform (medium-transformation (sheet-medium sheet))) (world-transform (compose-transformations sheet-transform medium-transform))) (multiple-value-bind (sheet-x1 sheet-y1) (transform-position world-transform x1 y1) (multiple-value-bind (sheet-x2 sheet-y2) (transform-position world-transform x2 y2) ;; Be conservative with the size of the pixmap, including all of ;; the pixels at the edges. (let* ((pixmap-x1 (floor sheet-x1)) (pixmap-y1 (floor sheet-y1)) (pixmap-x2 (ceiling sheet-x2)) (pixmap-y2 (ceiling sheet-y2)) (pixmap-width (- pixmap-x2 pixmap-x1)) (pixmap-height (- pixmap-y2 pixmap-y1)) (current-sheet-region (sheet-region sheet)) (sheet-native (compose-transformation-with-translation sheet-transform (- pixmap-x1) (- pixmap-y1))) (pixmap (allocate-pixmap sheet pixmap-width pixmap-height)) ) (unless pixmap (error "Couldn't allocate pixmap")) (multiple-value-bind (user-pixmap-x1 user-pixmap-y1) (untransform-position world-transform pixmap-x1 pixmap-y1) (multiple-value-bind (user-pixmap-x2 user-pixmap-y2) (untransform-position world-transform pixmap-x2 pixmap-y2) (flet ((set-native (transform region sheet) (%%set-sheet-native-transformation transform sheet) (setf (slot-value sheet 'region) region) (invalidate-cached-regions sheet) (invalidate-cached-transformations sheet))) ;; Assume that the scaling for the sheet-native ;; transformation for the pixmap will be the same as that of ;; the mirror . (unwind-protect (letf (((sheet-parent sheet) nil) ((sheet-direct-mirror sheet) (pixmap-mirror pixmap))) (unwind-protect (let ((pixmap-region (make-bounding-rectangle user-pixmap-x1 user-pixmap-y1 user-pixmap-x2 user-pixmap-y2))) (set-native sheet-native pixmap-region sheet) ;(break) (with-drawing-options (medium :ink (medium-background medium)) (medium-draw-rectangle* medium user-pixmap-x1 user-pixmap-y1 user-pixmap-x2 user-pixmap-y2 t)) (funcall continuation sheet user-pixmap-x1 user-pixmap-y1 user-pixmap-x2 user-pixmap-y2)) (set-native sheet-transform current-sheet-region sheet))) (copy-from-pixmap pixmap 0 0 pixmap-width pixmap-height sheet user-pixmap-x1 user-pixmap-y1) (deallocate-pixmap pixmap)))))))))) (defmacro with-double-buffering (((sheet &rest bounds-args) (&rest pixmap-args)) &body body) (with-gensyms (continuation) (let ((cont-form (case (length pixmap-args) (1 (with-gensyms (pixmap-x1 pixmap-y1 pixmap-x2 pixmap-y2) `(,continuation (,sheet ,pixmap-x1 ,pixmap-y1 ,pixmap-x2 ,pixmap-y2) (let ((,(car pixmap-args) (make-bounding-rectangle ,pixmap-x1 ,pixmap-y1 ,pixmap-x2 ,pixmap-y2))) ,@body)))) (4 `(,continuation (,sheet ,@pixmap-args) ,@body)) (otherwise (error "Invalid pixmap-args ~S" pixmap-args))))) (case (length bounds-args) (1 (with-gensyms (x1 y1 x2 y2) `(flet (,cont-form) (declare (dynamic-extent #',continuation)) (with-bounding-rectangle* (,x1 ,y1 ,x2 ,y2) ,(car bounds-args) (invoke-with-double-buffering ,sheet #',continuation ,x1 ,y1 ,x2 ,y2))))) (4 `(flet (,cont-form) (declare (dynamic-extent #',continuation)) (invoke-with-double-buffering ,sheet #',continuation ,@bounds-args))) (otherwise (error "invalid bounds-args ~S" bounds-args)))))) ;;; Generic graphic operation methods (defmacro def-graphic-op (name (&rest args)) (let ((method-name (symbol-concat '#:medium- name '*))) `(eval-when (:execute :load-toplevel :compile-toplevel) (defmethod ,method-name ((stream sheet) ,@args) (with-sheet-medium (medium stream) (,method-name medium ,@args)))))) (def-graphic-op draw-point (x y)) (def-graphic-op draw-points (coord-seq)) (def-graphic-op draw-line (x1 y1 x2 y2)) (def-graphic-op draw-lines (coord-seq)) (def-graphic-op draw-polygon (coord-seq closed filled)) (def-graphic-op draw-rectangle (left top right bottom filled)) (def-graphic-op draw-rectangles (position-seq filled)) (def-graphic-op draw-ellipse (center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy start-angle end-angle filled)) (def-graphic-op draw-circle (center-x center-y radius start-angle end-angle filled)) (def-graphic-op draw-text (string x y start end align-x align-y toward-x toward-y transform-glyphs)) ;;; Some image junk... (defmethod medium-free-image-design ((sheet sheet-with-medium-mixin) design) (medium-free-image-design (sheet-medium sheet) design)) (defmethod medium-draw-image-design* :before (current-medium design x y) (with-slots (medium medium-data) design (unless (eq medium current-medium) (when medium (medium-free-image-design medium design)) (setf medium current-medium) (setf medium-data nil)))) (defmethod medium-draw-image-design* ((medium sheet-with-medium-mixin) design x y) (medium-draw-image-design* (sheet-medium medium) design x y)) ;;;; ;;;; DRAW-DESIGN ;;;; (defmethod draw-design (medium (design point) &rest options &key &allow-other-keys) (apply #'draw-point* medium (point-x design) (point-y design) options)) (defmethod draw-design (medium (design polyline) &rest options &key &allow-other-keys) (apply #'draw-polygon medium (polygon-points design) :closed (polyline-closed design) :filled nil options)) (defmethod draw-design (medium (design polygon) &rest options &key &allow-other-keys) (apply #'draw-polygon medium (polygon-points design) :closed (polyline-closed design) :filled t options)) (defmethod draw-design (medium (design line) &rest options &key &allow-other-keys) (multiple-value-bind (x1 y1) (line-start-point* design) (multiple-value-bind (x2 y2) (line-end-point* design) (apply #'draw-line* medium x1 y1 x2 y2 options)))) (defmethod draw-design (medium (design rectangle) &rest options &key &allow-other-keys) (multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* design) (apply #'draw-rectangle* medium x1 y1 x2 y2 options))) (defmethod draw-design (medium (design ellipse) &rest options &key &allow-other-keys) (multiple-value-bind (cx cy) (ellipse-center-point* design) (multiple-value-bind (r1x r1y r2x r2y) (ellipse-radii design) (multiple-value-call #'draw-ellipse* medium cx cy r1x r1y r2x r2y :start-angle (ellipse-start-angle design) :end-angle (ellipse-end-angle design) options)))) (defmethod draw-design (medium (design elliptical-arc) &rest options &key &allow-other-keys) (multiple-value-bind (cx cy) (ellipse-center-point* design) (multiple-value-bind (r1x r1y r2x r2y) (ellipse-radii design) (multiple-value-call #'draw-ellipse* medium cx cy r1x r1y r2x r2y :start-angle (ellipse-start-angle design) :end-angle (ellipse-end-angle design) :filled nil options)))) (defmethod draw-design (medium (design standard-region-union) &rest options &key &allow-other-keys) (map-over-region-set-regions (lambda (region) (apply #'draw-design medium region options)) design)) (defmethod draw-design (medium (design standard-rectangle-set) &rest options &key &allow-other-keys) ;; ### we can do better (faster) than this. (map-over-region-set-regions (lambda (region) (apply #'draw-design medium region options)) design)) #+nyi (defmethod draw-design (medium (design standard-region-intersection) &rest options &key &allow-other-keys) ) #+nyi (defmethod draw-design (medium (design standard-region-difference) &rest options &key &allow-other-keys) ) (defmethod draw-design (medium (design (eql +nowhere+)) &rest options &key &allow-other-keys) (declare (ignore medium options) (ignorable design)) nil) (defmethod draw-design ((medium sheet) (design (eql +everywhere+)) &rest options &key &allow-other-keys) (apply #'draw-design medium (bounding-rectangle (sheet-region medium)) options)) (defmethod draw-design ((medium medium) (design (eql +everywhere+)) &rest options &key &allow-other-keys) (apply #'draw-design medium (bounding-rectangle (sheet-region (medium-sheet medium))) options)) ;;; (defmethod draw-design (medium (color color) &rest options &key &allow-other-keys) (apply #'draw-design medium +everywhere+ :ink color options)) (defmethod draw-design (medium (color opacity) &rest options &key &allow-other-keys) (apply #'draw-design medium +everywhere+ :ink color options)) (defmethod draw-design (medium (color standard-flipping-ink) &rest options &key &allow-other-keys) (apply #'draw-design medium +everywhere+ :ink color options)) (defmethod draw-design (medium (color indirect-ink) &rest options &key &allow-other-keys) (apply #'draw-design medium +everywhere+ :ink color options)) ;;;; (defmethod draw-design (medium (design rgb-image-design) &rest options &key (x 0) (y 0) &allow-other-keys) (with-medium-options (medium options) (medium-draw-image-design* medium design x y)) (values)) ;;;; (defmethod draw-design (medium (pattern pattern) &key clipping-region transformation &allow-other-keys) (draw-pattern* medium pattern 0 0 :clipping-region clipping-region :transformation transformation)) (defun draw-pattern* (medium pattern x y &key clipping-region transformation) ;; Note: I believe the sample implementation in the spec is incorrect. ;; --GB (check-type pattern pattern) (cond ((or clipping-region transformation) (with-drawing-options (medium :clipping-region clipping-region :transformation transformation) ;; Now this is totally bogus. (medium-draw-pattern* medium pattern x y) )) (t ;; What happens if there is already a transformation ;; applied to the medium? (medium-draw-pattern* medium pattern x y)))) (defmethod medium-draw-pattern* (medium pattern x y) (let ((width (pattern-width pattern)) (height (pattern-height pattern))) ;; As I read the spec, the pattern itself is not transformed, so ;; we should draw the full (untransformed) pattern at the tranformed ;; x/y coordinates. This requires we revert to the identity transformation ;; before drawing the rectangle. -Hefner (with-transformed-position ((medium-transformation medium) x y) (with-identity-transformation (medium) #+NIL ;; debugging aid. (draw-rectangle* medium x y (+ x width) (+ y height) :filled t :ink +red+) (draw-rectangle* medium x y (+ x width) (+ y height) :filled t :ink (transform-region (make-translation-transformation x y) pattern)))))) (defun draw-rounded-rectangle* (sheet x1 y1 x2 y2 &rest args &key (radius 7) (radius-x radius) (radius-y radius) (radius-left radius-x) (radius-right radius-x) (radius-top radius-y) (radius-bottom radius-y) filled &allow-other-keys) "Draw a rectangle with rounded corners" (apply #'invoke-with-drawing-options sheet (lambda (medium) (declare (ignore medium)) (let ((medium sheet)) (if (not (and (>= (- x2 x1) (* 2 radius-x)) (>= (- y2 y1) (* 2 radius-y)))) (draw-rectangle* medium x1 y1 x2 y2) (with-grown-rectangle* ((ix1 iy1 ix2 iy2) (x1 y1 x2 y2) :radius-left (- radius-left) :radius-right (- radius-right) :radius-top (- radius-top) :radius-bottom (- radius-bottom)) (let ((zl (zerop radius-left)) (zr (zerop radius-right)) (zt (zerop radius-top)) (zb (zerop radius-bottom))) (if filled (progn ; Filled (unless (or zl zt) (draw-ellipse* medium ix1 iy1 radius-left 0 0 radius-top :filled t)) (unless (or zr zt) (draw-ellipse* medium ix2 iy1 radius-right 0 0 radius-top :filled t)) (unless (or zl zb) (draw-ellipse* medium ix1 iy2 radius-left 0 0 radius-bottom :filled t)) (unless (or zr zb) (draw-ellipse* medium ix2 iy2 radius-right 0 0 radius-bottom :filled t)) (draw-rectangle* medium x1 iy1 x2 iy2 :filled t) (draw-rectangle* medium ix1 y1 ix2 iy1 :filled t) (draw-rectangle* medium ix1 iy2 ix2 y2 :filled t)) (progn ; Unfilled (unless (or zl zt) (draw-ellipse* medium ix1 iy1 (- radius-left) 0 0 (- radius-top) :start-angle (/ pi 2) :end-angle pi :filled nil)) (unless (or zr zt) (draw-ellipse* medium ix2 iy1 (- radius-right) 0 0 (- radius-top) :start-angle 0 :end-angle (/ pi 2) :filled nil)) (unless (or zl zb) (draw-ellipse* medium ix1 iy2 (- radius-left) 0 0 (- radius-bottom) :start-angle pi :end-angle (* 3/2 pi) :filled nil)) (unless (or zr zb) (draw-ellipse* medium ix2 iy2 (- radius-right) 0 0 (- radius-bottom) :start-angle (* 3/2 pi) :filled nil)) (labels ((fx (y p x1a x2a x1b x2b) (draw-line* medium (if p x1a x1b) y (if p x2a x2b) y)) (fy (x p y1a y2a y1b y2b) (draw-line* medium x (if p y1a y1b) x (if p y2a y2b)))) (fx y1 zt x1 x2 ix1 ix2) (fy x1 zl y1 y2 iy1 iy2) (fx y2 zb x1 x2 ix1 ix2) (fy x2 zr y1 y2 iy1 iy2))))))))) (with-keywords-removed (args '(:radius :radius-x :radius-y :radius-left :radius-right :radius-top :radius-bottom)) args))) ;;; Bitmap images ;;; ;;; Based on CLIM 2.2, with an extension permitting the definition of ;;; new image formats by the user. (defvar *bitmap-file-readers* (make-hash-table :test 'equalp) "A hash table mapping keyword symbols naming bitmap image formats to a function that can read an image of that format. The functions will be called with one argument, the pathname of the file to be read. The functions should return two values as per `read-bitmap-file'.") (defmacro define-bitmap-file-reader (bitmap-format (&rest args) &body body) "Define a method for reading bitmap images of format BITMAP-FORMAT that will be used by `read-bitmap-file' and MAKE-PATTERN-FROM-BITMAP-FILE. BODY should return two values as per `read-bitmap-file'." `(setf (gethash ,bitmap-format *bitmap-file-readers*) #'(lambda (,@args) ,@body))) (defun bitmap-format-supported-p (format) "Return true if FORMAT is supported by `read-bitmap-file'." (not (null (gethash format *bitmap-file-readers*)))) (define-condition unsupported-bitmap-format (error) ((%format :reader bitmap-format :initarg :bitmap-format :initform (error "The bitmap format must be supplied") :documentation "The bitmap format that cannot be loaded")) (:report (lambda (condition stream) (format stream "Cannot read bitmap of unknown format \"~A\"" (bitmap-format condition)))) (:documentation "This exception is signalled when `read-bitmap-file' is called on an bitmap of a type that no reader has been defined for.")) (defun unsupported-bitmap-format (format) "Signal an error of type `unsupported-bitmap-format' for the bitmap format `format'." (error 'unsupported-bitmap-format :bitmap-format format)) (defun read-bitmap-file (pathname &key (format :bitmap) (port (find-port))) "Read a bitmap file named by `pathname'. `Port' specifies the port that the bitmap is to be used on. `Format' is a keyword symbol naming any defined bitmap file format defined by `clim-extensions:define-bitmap-file-reader'. Two values are returned: a two-dimensional array of pixel values and an array of either colors or color names. If the second value is non-NIL, the pixel values are assumed to be indexes into this array. Otherwise, the pixel values are taken to be RGB values encoded in 32 bit unsigned integers, with the three most significant octets being the values R, G and B, in order." (declare (ignore port)) ; XXX? (funcall (or (gethash format *bitmap-file-readers*) (unsupported-bitmap-format format)) pathname)) (defun make-pattern-from-bitmap-file (pathname &key designs (format :bitmap) (port (find-port))) "Read a bitmap file named by `pathname'. `Port' specifies the port that the bitmap is to be used on. `Format' is a keyword symbol naming any defined bitmap file format defined by `clim-extensions:define-bitmap-file-reader'. Two values are returned: a two-dimensional array of pixel values and an array of either colors or color names. If the second value is non-NIL, the pixel values are assumed to be indexes into this array. Otherwise, the pixel values are taken to be RGB values encoded in 32 bit unsigned integers, with the three most significant octets being the values R, G and B, in order." (multiple-value-bind (res read-designs) (read-bitmap-file pathname :format format :port port) (if read-designs (make-pattern res (or designs read-designs)) (make-instance 'rgb-pattern :image (make-instance 'rgb-image :width (array-dimension res 1) :height (array-dimension res 0) :data res))))) (define-bitmap-file-reader :xpm (pathname) (xpm-parse-file pathname)) (define-bitmap-file-reader :pixmap (pathname) (read-bitmap-file pathname :format :xpm)) (define-bitmap-file-reader :pixmap-3 (pathname) (read-bitmap-file pathname :format :xpm)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/defresource.lisp0000644000175000017500000004256407636702772020231 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-INTERNALS; -*- ;;; --------------------------------------------------------------------------- ;;; Title: CLIM-2 Chapter 32.1 Resources ;;; Created: 2001-05-21 ;;; Author: Gilbert Baumann ;;; License: LGPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2001 by Gilbert Baumann ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;;; Changes ;;; When Who What ;;; -------------------------------------------------------------------------------------- ;;; 2002-02-10 GB named allocator function ;;; 2001-05-21 GB created (in-package :clim-internals) ;;;; 32.1 Resources ;;; TODO ;; - provide a "real" using-resource expansion ;; - under CMU ATOMIC-INCF is a performance blocker, what to do? ;; - use per process free-lists? ;; - use two lists? One for free objects, one for allocated? ;;; NOTES ;; It seems wasteful not to shuffle objects. When there are already a ;; couple of objects in use and these are in front of ;; RESOURCE-OBJECTS, we revisit them each time while finding. On the ;; other hand, when we would like to shuffle the list of objects, we ;; would need to acquire another lock, which seems equally wasteful. ;; Further: This somewhat assumes a feasible implementation of ;; ATOMIC-INCF and ATOMIC-DECF. If plain vanilla locks or ;; WITHOUT-SCHEDULING is faster, we would be better off using that. ;; USING-RESOURCE should not cause unnecessary consing. To test this I ;; appended a test case below. There is an UNWIND-PROTECT in the ;; definition of USING-RESOURCE, which might cause consing. (E.g. CMU ;; does so, when the clean-up form writes to variables defined outside ;; of it). ;; Also I tried to define all this in a way, that the no assumptions ;; about random user code is made. Specifically: no locks are held, ;; scheduling is _not_ disabled, any of the resource API can be ;; called. ;; ) unlike under Genera it seems. (defvar *resource-table* (make-hash-table :test #'eq) "Hash table of all defined resource types.") (defstruct resource ;; One defined resource name ;its name just for the sake of it objects ;a list of RESOURCE-OBJECTs lock ;A regular process lock to protect the OBJECTS slot. allocator ;function to allocate an object ; takes the resource and the parameters. ; Returns two values: the object and its ; descriptor (a RESOURCE-OBJECT) ; [cf. Genera's definition allocate-resource] deallocator) ;function to deallocate an object ; takes three arguments: the resource, the ; object and the descriptor. (defstruct resource-object ;; One resourced object object ;the object itself lock ;homebrew lock ; is >= 1, if resource is allocated or investigated ; is 0, if resource is free parameters) ;list of parameters supplied, while allocating this ; object. Needed for a possible deinitializer ; or default matcher. NIL if not needed at all. (defun find-resource (name &optional barfp) (or (gethash name *resource-table*) (if barfp (progn (cerror "Try again to find resource ~S (after you defined it)" "There is no such resource: ~S." name) (find-resource name)) nil))) (defun (setf find-resource) (value name) (setf (gethash name *resource-table*) value)) (defun allocate-resource (name &rest parameters) "Allocates an object from the resource." (let ((resource (find-resource name))) (values (apply (the function (resource-allocator resource)) resource parameters))) ) (defun deallocate-resource (name object) "Returns the object to the resource." (let ((resource (find-resource name))) (funcall (the function (resource-deallocator resource)) resource object)) ) (defmacro using-resource ((variable name &rest parameters) &body body) "The forms in 'body' are evaluated with 'variable' bound to an object allocated from the resource named 'name', using the parameters given by 'parameters'." (let ((r. (gensym "R.")) (ro. (gensym "RO.")) (evil-cell (gensym "EVIL-CELL."))) `(let* ((,evil-cell (load-time-value (list nil))) (,r. (or (car (the cons ,evil-cell)) (setf (car (the cons ,evil-cell)) (find-resource ',name))))) ;; Q: Why this EVIL-CELL hack? And not ;; (load-time-value (find-resource ..))? ;; A: Since the time of actual evaluation of the LOAD-TIME-VALUE is ;; unspecified with regard to other [top level] forms in a file[, ;; when loaded]. But I want the DEFRESOURCE to evaluate before this ;; LOAD-TIME-VALUE. (multiple-value-bind (,variable ,ro.) (funcall (resource-allocator ,r.) ,r. ,@parameters) (unwind-protect (locally ,@body) (when ,variable (funcall (resource-deallocator ,r.) ,r. ,variable ,ro.))))))) (defun clear-resource (name) "Removes all of the resourced object from the resource." (let ((resource (find-resource name))) (setf (resource-objects resource) nil))) (defun map-resource (function name) "Calls function once on each object in the resource." (let ((resource (find-resource name))) (dolist (resource-object (resource-objects resource)) (funcall function (resource-object-object resource-object) (not (zerop (car (resource-object-lock resource-object)))) name)))) (defmacro defresource (name parameters &key (constructor (error "~S argument is required" :constructor)) initializer deinitializer matcher initial-copies) ;; First do some type checks (check-type name symbol) ;; Safety first: Check a possible definition lock. (let ((pack (symbol-package name))) (when (or (eq pack (find-package :keyword)) (eq pack (find-package :common-lisp)) #+excl (excl:package-definition-lock pack) ) (cerror "Define resource ~S anyway" "Resource ~S cannot be defined, since its home package, ~S, is locked." name (package-name pack)))) ;; Collect parameter variables (let ((pvars nil)) (dolist (parameter parameters) (cond ((member parameter lambda-list-keywords) nil) ((symbolp parameter) (pushnew parameter pvars)) ((consp parameter) (if (consp (first parameter)) (pushnew (second (first parameter)) pvars) (pushnew (first parameter) pvars)) (when (third parameter) (pushnew (third parameter) pvars))))) (setf pvars (reverse pvars)) (let ((parameters-needed-p (or (null matcher) (not (null deinitializer))))) (labels ((allocate-fresh-expr (r.) ;; Allocate a fresh object (let ((ro. (gensym "RO."))) `(let ((,ro. (make-resource-object :object ,constructor :lock (list 1) :parameters ,(if parameters-needed-p `(make-list ,(length pvars)) 'nil)))) (with-lock-held ((resource-lock ,r.)) (push ,ro. (resource-objects ,r.))) ,ro.)) ) (match-expr (ro.) ;; Compilation of the matcher (let ((q. (gensym "Q."))) (if matcher `(let ((,name (resource-object-object ,ro.))) (declare (ignorable ,name)) ,matcher) `(let ((,q. (resource-object-parameters ,ro.))) (declare (ignorable ,q.)) (and ,@(loop for p in pvars collect `(equal (pop ,q.) ,p))))))) (find-expr (r.) ;; Find an object, which matches or allocate a fresh one. ;; ;; To improve granularity of locking, each allocated resource ;; carries its own lock. Furthermore, when a lock is not ;; available, we do not care to wait, but simply choose to ;; carry on. Furthermore we consider resources in use as ;; locked. This saves us another test while finding at the ;; expense that MAP-RESOURCE might once in a while report a ;; resource as used, while somebody else is just peeking. ;; (let ((ro. (gensym "$RO.")) (lock. (gensym "$LOCK."))) `(dolist (,ro. (resource-objects ,r.) ;; fall back: allocate a fresh object ,(allocate-fresh-expr r.)) (declare (type resource-object ,ro.)) (let ((,lock. (resource-object-lock ,ro.))) (declare (type cons ,lock.)) (when (= 0 (the fixnum (car ,lock.))) (atomic-incf (the fixnum (car ,lock.))) (cond ((and (= 1 (the fixnum (locally #+excl (declare (optimize (safety 3))) ;EXCL bug (car ,lock.)))) ,(match-expr ro.)) (return ,ro.)) (t (atomic-decf (the fixnum (car ,lock.)))) )))))) (allocator () ;; Function for ALLOCATE-RESOURCE (let ((r. (gensym "R.")) (ro. (gensym "RO.")) (fn. (make-symbol (with-standard-io-syntax (let ((*package* (find-package :keyword))) (format nil "ALLOCATOR for ~S" name)))))) `(labels ((,fn. (,r. ,@parameters) (let ((,ro. ,(find-expr r.))) (declare (type resource-object ,ro.)) ;; install parameters in resource-object and eval initializer ,(install-parameters-expr ro.) (let ((,name (resource-object-object ,ro.))) (declare (ignorable ,name)) ,initializer) ;; done (values (resource-object-object ,ro.) ,ro.)))) #',fn.))) (install-parameters-expr (ro.) (and parameters-needed-p (let ((q. (gensym "Q."))) `(let ((,q. (resource-object-parameters ,ro.))) (declare (ignorable ,q.)) ,@(loop for p in pvars collect `(setf (car ,q.) ,p ,q. (cdr ,q.))))))) (deallocator () ;; Function for deallocate-resource (let ((r. (gensym "R.")) (ro. (gensym "RO.")) (obj. (gensym "OBJ")) (q. (gensym "Q")) (lock. (gensym "LOCK"))) `(lambda (,r. ,obj. &optional ,ro.) (unless ,ro. (do ((q (resource-objects (the resource ,r.)) (cdr (the cons q)))) ((null q) (error "Something corrupted.")) (let ((ro (car (the cons q)))) (declare (type resource-object ro)) (when (eq ,obj. (resource-object-object ro)) (setf ,ro. ro) (return))))) (locally (declare (type resource-object ,ro.)) (let ((,name ,obj.)) (declare (ignorable ,name)) ,(when deinitializer `(destructuring-bind (,@pvars) (resource-object-parameters ,ro.) (declare (ignorable ,@pvars)) ,deinitializer))) ,(if (and matcher (not (null deinitializer))) `(let ((,q. (resource-object-parameters ,ro.))) ,@(loop repeat (length pvars) collect `(setf (car ,q.) nil ,q. (cdr ,q.)))) nil) (let ((,lock. (resource-object-lock ,ro.))) (atomic-decf (the fixnum (car ,lock.)))))))) ) ;; (let* ((r. (gensym "R.")) (q. (gensym "Q.")) (allocator. (gensym "ALLOCATOR.")) (deallocator. (gensym "DEALLOCATOR.")) ) `(progn #+excl (excl:record-source-file ',name :type :resource-definition) (let* ((,allocator. ,(allocator)) (,deallocator. ,(deallocator)) (,r. (or ;; (find-resource ',name) (make-resource :name ',name :objects nil :lock (make-lock (let ((*package* (find-package :keyword))) (format nil "Resource ~S" ',name))))))) (setf (resource-allocator ,r.) ,allocator. (resource-deallocator ,r.) ,deallocator.) ;; Care for initial copies ,(when initial-copies `(progn (dotimes (,q. ,initial-copies) (funcall ,allocator. ,r.)) (dolist (,q. (resource-objects ,r.)) (funcall ,deallocator. ,r. (resource-object-object ,q.) ,q.)))) ;; Finally install the resource (setf (find-resource ',name) ,r.) ;; Out of habit we return the name, although nobody uses a ;; printing LOAD these days. ',name) )))))) ;;; -------------------- ;;; Proposal ;; PERMANENTLY-DEALLOCATE-RESOURCE name object [Function] ;; Deallocate 'object' and indicate, that it is no longer useful to retain it. ;; EXAMPLE ;; One might consider connections to FTP servers as a resource. But those ;; connection can become dead on "itself", because the FTP server might have ;; chosen to kick us out due to inactivity. With ;; PERMANENTLY-DEALLOCATE-RESOURCE it is now possible to selectively clean ;; up the those objects. Or do it on demand, while matching. ;; (defresource ftp-connection (host &optional (port +ftp-port+)) ;; :constructor (make-ftp-connection host port) ;; :matcher (cond ((connection-dead-p ftp-connection) ;; (permanently-deallocate-resource ;; 'ftp-connection ftp-connection) ;; nil) ;; ((and (equal (ftp-connection-host host) host) ;; (equal (ftp-connection-port port) port)))) ;; :destructor (close-ftp-connection ftp-connection)) ;; IMPLICATIONS ;; We now also need a :DESTRUCTOR option to indicate actions needed, when we ;; throw away an object. These should also be invoked, when one does a ;; CLEAR-RESOURCE. ;;; -------------------- ;;; Test cases #|| ;; First a minimal speed test (defresource seventeen () :constructor 17) (defun test-seventeen () ;; should not cons at all (dotimes (i 1000000) (using-resource (x seventeen)))) ;; Now a more sophisticated test: (defstruct foo x y) (defresource foo (&optional (x 10) (y 20)) :constructor (make-foo) :initializer (setf (foo-x foo) x (foo-y foo) y) :initial-copies 3) (defun test-foo () (dotimes (i 1000000) (using-resource (x foo 8 9)))) ||# cl-mcclim-0.9.6.dfsg.cvs20100315.orig/NEWS0000644000175000017500000002066011345155771015513 0ustar pdmpdm* Changes in mcclim-0.9.7 relative to 0.9.6: * Changes in mcclim-0.9.6 relative to 0.9.5: ** Bug fix: ESA's help commands are better at finding bindings and describing them ** Bug fix: Some missing methods and functions have been implemented for the Null backend, allowing headless operation for many applications. ** Specification compliance: READ-BITMAP-FILE and MAKE-PATTERN-FROM-BITMAP-FILE from CLIM 2.2. Includes new example program, IMAGE-VIEWER. ** Drei improvements *** New redisplay engine that is faster and has more features. *** Support for "views" concept. *** Support for modes a la Emacs "mini-modes". *** Bug fix: Input prompting now works for directly recursive calls to ACCEPT. *** Improvement: Goal-columns for line movement. *** Improvement: More Emacs-like expression movement for Lisp syntax. ** Bug fix: label panes no longer have a restrictive maximum width. ** Bug fix: ellipses with a zero radius no longer cause errors. ** Bug fix: bezier drawing in CLIM-FIG less likely to cause errors. ** Bug fix: restored somewhat working undo in CLIM-FIG. ** Specification compliance: The :inherit-menu keyword argument to DEFINE-COMMAND-TABLE and MAKE-COMMAND-TABLE is now implemented with CLIM 2.2 semantics. The :keystrokes value is not handled yet. ** Specification compliance: :PRINTER functions for MENU-CHOOSE are now called with the menu item, not the display object. ** Improvement: Faster drawing and AA text rendering. AA text requires a fix to the Xrender support of CLX, available in Christophe Rhodes's current CLX distribution from darcs. ** Improvement: Look up arbitrary truetype fonts by name via fontconfig. ** New extension: mcclim-truetype: provides a 100% lisp path for AA fonts with CLX using cl-vectors and zpb-ttf, as an alternative to mcclim-freetype. ** Bug fix: correct computation of bounding rectangle after clear-output-record and recompute-extent-for-new-child. * Changes in mcclim-0.9.5 relative to 0.9.4: ** Installation: the systems clim-listener, clim-examples, and clouseau can now be loaded without loading the system mcclim first. Users with existing McCLIM installations should use the provided script: ./symlink-asd-files.sh /path/to/asdf-central-registry/ ** New extension: tab-layout. This extension allows keeping a stack of panes whose foreground pane is controlled by a tab bar. This layout can be customized in backends and frame managers. For examples, see the gtkairo backend and the pixie frame manager. ** New extension function: SHEET-RGB-IMAGE: makes a screenshot of a sheet in the CLX backend. (Supported on truecolor visuals only for now.) ** New experimental extension: tree-with-cross-edges are an extension to the graph formatter. ** New experimental backend: clim-graphic-forms: native widgets on Windows. This backend is still very experimental (it doesn't run demos yet). ** New inspector feature: The inspector now displays more useful information about hash tables and generic functions. ** Specification compliance: Various layout panes no longer quite as aggressive at eating the space requirements of their children. ** Specification compliance: There is now a rudimentary implementation of NOTIFY-USER ** Usability: Text editors and text input panes now use click-to-focus. ** Improvement: the ACCEPTING-VALUES command table was renamed to ACCEPT-VALUES (as this is the name that the other clim-2 implementation uses) ** Improvement: the CLX backend should no longer cause focus stealing when an application has text-editor panes. This change comes with a rudimentary click-to-focus-keyboard widget policy. ** Improvement: define-application-frame now allows a :default-initargs option. (This is not exactly a "specification compliance" fix, as d-a-frame is not defined to accept this option.). ** Improvement: menu-choose menus now look a little prettier. ** Improvement: added more styles for bordered-output: :rounded, :ellipse ** Improvement: Toggle button values now default to NIL. ** Improvement: Frame layouts are now inherited from the frame's superclass. ** Improvement: The Lisp Syntax is much improved: now recognizes delimiter characters, and more types of Lambda lists. ** Bug fix: Bezier designs should now draw in the right place in all backends. ** Bug fix: Text in Drei no longer "walks" to the left. ** Bug fix: Drei now has better support for delimiter gestures. ** Bug fix: Partial commands now work better when invoked from the menu. * Changes in mcclim-0.9.4 relative to 0.9.3: ** cleanup: removed the obsolete system.lisp file. ** backend improvements: Gtkairo *** Double buffering is now supported (fixes disappearing widgets on Windows). *** X errors no longer terminate the lisp process. *** Some bugfixes, including CMUCL support and better key event handling. *** Native implementation of context menus, list panes, label panes, and option panes. *** Draw text using Pango. (Bug fix: Fixed-width font supported on Windows now. Multiple lines of output in TEXT-SIZE supported now. TEXT-STYLE-FIXED-WIDTH-P works correctly now.) ** Improvement: Added new editor substrate ("Drei"). ** Improvement: Improved the pathname presentation methods considerably. ** specification compliance: DELETE-GESTURE-NAME function now implemented. ** specification compliance: PRESENTATION-TYPE-SPECIFIER-P presentaion function now implemented. ** specification compliance: DISPLAY-COMMAND-TABLE-MENU function now implemented. ** specification compliance: DISPLAY-COMMAND-MENU function now implemented. ** specification compliance: POINTER-PLACE-RUBBER-BAND-LINE* function now implemented. ** specification compliance: POINTER-INPUT-RECTANGLE* function now implemented. ** specification compliance: POINTER-INPUT-RECTANGLE function now implemented. ** Improvement: Added font listing support, see section "Fonts and Extended Text Styles" in the manual. ** Improvement: Added support for bezier splines (Robert Strandh). To be documented. ** better PRESENTATION-SUBTYPEP (more likely to give the right answer on some-of and all-of presentation types) ** Improvement: M-n/M-p gestures for navigating presentation histories. * Changes in mcclim-0.9.3 "All Souls' Day" relative to 0.9.2: ** backend improvement: The Null backend now registers itself in the server search path ** improvement: with-output-as-gadget now sets the correct cursor position when incremental redisplay is active. ** specification compliance: INVOKE-WITH-NEW-OUTPUT-RECORD's argument list now is the same as the one in the Franz CLIM user guide. ** improvement: The text field cursor is now a solid block again. ** backend improvement: the PostScript backend now outputs correct EPS ** improvement: Graph nodes can now be dragged ** improvement: Possibilities when reading from COMPLETE-FROM-GENERATOR are now sorted alphabetically. ** new experimental backend: gtkairo (loads on SBCL, CMUCL and SCL): Uses GTK+ for gadgets and cairo for rendering graphics. ** Bug fix: incremental-redisplay does no longer leak memory ** improvement: incremental-redisplay is now a little faster ** Bug fix: Invisible text cursors no longer leave a dangling space behind the text output record ** improvement: commands whose names are shadowed in child command tables are now suggested in preference to their parents. ** Bug fix: (setf stream-cursor-position) and output record replay on encapsulating streams work now. ** Bug fix: Invoking command menu items in frames with no interactor works now. ** Bug fix: DESTROY-PORT removes the port even if an error occurs while closing the port ** Bug fix: make-process now sets the process name on SBCL ** specification compliance: MENU-CHOOSE now supports almost all features demanded in the CLIM 2.0 specification. ** improvement: new and improved ACCEPT presentation method for expressions on interactive streams. ** specification compliance: LOOKUP-KEYSTROKE-ITEM no longer accepts the :errorp argument. ** Bug fix: incremental redisplay no longer breaks on output records that had no children. ** Bug fix: arrow head sizes are now transformed along with the line thickness. ** improvement: resizing a viewport's child will now move the viewport's focus. ** improvement: loading mcclim.asd no longer shows a code deletion note on SBCL. ** new demo: logic-cube ** compatibility: Add support for post-1.0 openmcl, and for Allegro Common Lisp 8.0 (ansi mode). ** new example application showing use of CLIM views. cl-mcclim-0.9.6.dfsg.cvs20100315.orig/input-editing-goatee.lisp0000644000175000017500000001422711345155771021731 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2001 by ;;; Tim Moore (moore@bricoworks.com) ;;; (c) copyright 2006 by ;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Finalization of the implementation of the Goatee-based ;;; input-editing-stream. This probably doesn't work perfectly. (in-package :clim-internals) (defclass goatee-input-editing-stream (empty-input-mixin goatee:goatee-input-editing-mixin standard-input-editing-mixin input-editing-stream standard-encapsulating-stream) ((buffer :reader stream-input-buffer :initform (make-array 16 :adjustable t :fill-pointer 0)) (insertion-pointer :accessor stream-insertion-pointer :initform 0) (scan-pointer :accessor stream-scan-pointer :initform 0) (rescan-queued :accessor rescan-queued :initform nil) (rescanning-p :reader stream-rescanning-p :initform nil) (activation-gesture :accessor activation-gesture :initform nil))) (defmethod interactive-stream-p ((stream goatee-input-editing-stream)) t) (defmethod stream-accept ((stream goatee-input-editing-stream) type &rest args &key (view (stream-default-view stream)) &allow-other-keys) (apply #'prompt-for-accept stream type view args) (apply #'accept-1 stream type args)) ;;; Have to reexamine how many of the keyword arguments to ;;; stream-read-gesture should really be passed to the encapsulated ;;; stream. ;;; ;;; OK, now I know :) They should all be passed, except for peek-p. ;;; However, the loop that calls stream-read-gesture on the ;;; encapsulated stream needs to return null if we see a :timeout or ;;; :eof. ;;; ;;; Activation gesture handling has been moved out of ;;; stream-process-gesture to stream-read-gesture and ;;; stream-unread-gesture. This allows a gesture to be read in while ;;; it is not an activation gesture, unread, and then read again as an ;;; activation gesture. This kind of game seems to be needed for ;;; reading forms properly. -- moore (defmethod stream-read-gesture ((stream goatee-input-editing-stream) &rest rest-args &key peek-p &allow-other-keys) (with-keywords-removed (rest-args (:peek-p)) (rescan-if-necessary stream) (with-slots (buffer insertion-pointer scan-pointer activation-gesture) stream (loop (loop while (< scan-pointer insertion-pointer) do (let ((gesture (aref buffer scan-pointer))) ;; Skip noise strings. ;; XXX We should skip accept results too; I think that they ;; should be consumed by ACCEPT-1. That's not happening yet. (cond ((characterp gesture) (unless peek-p (incf scan-pointer)) (return-from stream-read-gesture gesture)) ((and (not peek-p) (typep gesture 'goatee::accept-result-extent)) (incf scan-pointer) (throw-object-ptype (goatee::object gesture) (goatee::result-type gesture))) (t (incf scan-pointer))))) ;; The scan pointer should not be greater than the insertion pointer ;; because the code that set the insertion pointer should have queued ;; a rescan. (when (> scan-pointer insertion-pointer) (warn "scan-pointer ~S > insertion-pointer ~S; shouldn't happen" scan-pointer insertion-pointer) (immediate-rescan stream)) (when activation-gesture (return-from stream-read-gesture (prog1 activation-gesture (unless peek-p (setf activation-gesture nil))))) (setf (slot-value stream 'rescanning-p) nil) ;; In McCLIM stream-process-gesture is responsible for inserting ;; characters into the buffer, changing the insertion pointer and ;; possibly setting up the activation-gesture slot. (loop with gesture and type do (setf (values gesture type) (apply #'stream-read-gesture (encapsulating-stream-stream stream) rest-args)) when (null gesture) do (return-from stream-read-gesture (values gesture type)) when (stream-process-gesture stream gesture type) do (loop-finish)))))) (defmethod stream-unread-gesture ((stream goatee-input-editing-stream) gesture) (with-slots (buffer scan-pointer activation-gesture) stream (when (> scan-pointer 0) (if (and (eql scan-pointer (fill-pointer buffer)) (activation-gesture-p gesture)) (setf activation-gesture gesture) (decf scan-pointer))))) (defmethod activate-stream ((stream goatee-input-editing-stream) gesture) (setf (activation-gesture stream) gesture) (setf (stream-insertion-pointer stream) (fill-pointer (stream-input-buffer stream))) (goatee::set-editing-stream-insertion-pointer stream (stream-insertion-pointer stream))) (defmethod reset-scan-pointer ((stream goatee-input-editing-stream) &optional (scan-pointer 0)) (setf (stream-scan-pointer stream) scan-pointer) (setf (slot-value stream 'rescanning-p) t)) (defmethod immediate-rescan ((stream goatee-input-editing-stream)) (signal 'rescan-condition)) (defmethod queue-rescan ((stream goatee-input-editing-stream)) (setf (rescan-queued stream) t)) (defmethod rescan-if-necessary ((stream goatee-input-editing-stream) &optional inhibit-activation) (declare (ignore inhibit-activation)) (when (rescan-queued stream) (setf (rescan-queued stream) nil) (immediate-rescan stream))) (defmethod input-editing-stream-output-record ((stream goatee-input-editing-stream)) (area stream)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/X11-colors.lisp0000644000175000017500000016355711345155771017572 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) ; $XConsortium: rgb.txt,v 10.41 94/02/20 18:39:36 rws Exp $ (defconstant +snow+ (make-named-color "snow" 1.0000 0.9804 0.9804)) (defconstant +ghost-white+ (make-named-color "ghost-white" 0.9725 0.9725 1.0000)) (defconstant +GhostWhite+ (make-named-color "GhostWhite" 0.9725 0.9725 1.0000)) (defconstant +white-smoke+ (make-named-color "white-smoke" 0.9608 0.9608 0.9608)) (defconstant +WhiteSmoke+ (make-named-color "WhiteSmoke" 0.9608 0.9608 0.9608)) (defconstant +gainsboro+ (make-named-color "gainsboro" 0.8627 0.8627 0.8627)) (defconstant +floral-white+ (make-named-color "floral-white" 1.0000 0.9804 0.9412)) (defconstant +FloralWhite+ (make-named-color "FloralWhite" 1.0000 0.9804 0.9412)) (defconstant +old-lace+ (make-named-color "old-lace" 0.9922 0.9608 0.9020)) (defconstant +OldLace+ (make-named-color "OldLace" 0.9922 0.9608 0.9020)) (defconstant +linen+ (make-named-color "linen" 0.9804 0.9412 0.9020)) (defconstant +antique-white+ (make-named-color "antique-white" 0.9804 0.9216 0.8431)) (defconstant +AntiqueWhite+ (make-named-color "AntiqueWhite" 0.9804 0.9216 0.8431)) (defconstant +papaya-whip+ (make-named-color "papaya-whip" 1.0000 0.9373 0.8353)) (defconstant +PapayaWhip+ (make-named-color "PapayaWhip" 1.0000 0.9373 0.8353)) (defconstant +blanched-almond+ (make-named-color "blanched-almond" 1.0000 0.9216 0.8039)) (defconstant +BlanchedAlmond+ (make-named-color "BlanchedAlmond" 1.0000 0.9216 0.8039)) (defconstant +bisque+ (make-named-color "bisque" 1.0000 0.8941 0.7686)) (defconstant +peach-puff+ (make-named-color "peach-puff" 1.0000 0.8549 0.7255)) (defconstant +PeachPuff+ (make-named-color "PeachPuff" 1.0000 0.8549 0.7255)) (defconstant +navajo-white+ (make-named-color "navajo-white" 1.0000 0.8706 0.6784)) (defconstant +NavajoWhite+ (make-named-color "NavajoWhite" 1.0000 0.8706 0.6784)) (defconstant +moccasin+ (make-named-color "moccasin" 1.0000 0.8941 0.7098)) (defconstant +cornsilk+ (make-named-color "cornsilk" 1.0000 0.9725 0.8627)) (defconstant +ivory+ (make-named-color "ivory" 1.0000 1.0000 0.9412)) (defconstant +lemon-chiffon+ (make-named-color "lemon-chiffon" 1.0000 0.9804 0.8039)) (defconstant +LemonChiffon+ (make-named-color "LemonChiffon" 1.0000 0.9804 0.8039)) (defconstant +seashell+ (make-named-color "seashell" 1.0000 0.9608 0.9333)) (defconstant +honeydew+ (make-named-color "honeydew" 0.9412 1.0000 0.9412)) (defconstant +mint-cream+ (make-named-color "mint-cream" 0.9608 1.0000 0.9804)) (defconstant +MintCream+ (make-named-color "MintCream" 0.9608 1.0000 0.9804)) (defconstant +azure+ (make-named-color "azure" 0.9412 1.0000 1.0000)) (defconstant +alice-blue+ (make-named-color "alice-blue" 0.9412 0.9725 1.0000)) (defconstant +AliceBlue+ (make-named-color "AliceBlue" 0.9412 0.9725 1.0000)) (defconstant +lavender+ (make-named-color "lavender" 0.9020 0.9020 0.9804)) (defconstant +lavender-blush+ (make-named-color "lavender-blush" 1.0000 0.9412 0.9608)) (defconstant +LavenderBlush+ (make-named-color "LavenderBlush" 1.0000 0.9412 0.9608)) (defconstant +misty-rose+ (make-named-color "misty-rose" 1.0000 0.8941 0.8824)) (defconstant +MistyRose+ (make-named-color "MistyRose" 1.0000 0.8941 0.8824)) (defconstant +dark-slate-gray+ (make-named-color "dark-slate-gray" 0.1843 0.3098 0.3098)) (defconstant +DarkSlateGray+ (make-named-color "DarkSlateGray" 0.1843 0.3098 0.3098)) (defconstant +dark-slate-grey+ (make-named-color "dark-slate-grey" 0.1843 0.3098 0.3098)) (defconstant +DarkSlateGrey+ (make-named-color "DarkSlateGrey" 0.1843 0.3098 0.3098)) (defconstant +dim-gray+ (make-named-color "dim-gray" 0.4118 0.4118 0.4118)) (defconstant +DimGray+ (make-named-color "DimGray" 0.4118 0.4118 0.4118)) (defconstant +dim-grey+ (make-named-color "dim-grey" 0.4118 0.4118 0.4118)) (defconstant +DimGrey+ (make-named-color "DimGrey" 0.4118 0.4118 0.4118)) (defconstant +slate-gray+ (make-named-color "slate-gray" 0.4392 0.5020 0.5647)) (defconstant +SlateGray+ (make-named-color "SlateGray" 0.4392 0.5020 0.5647)) (defconstant +slate-grey+ (make-named-color "slate-grey" 0.4392 0.5020 0.5647)) (defconstant +SlateGrey+ (make-named-color "SlateGrey" 0.4392 0.5020 0.5647)) (defconstant +light-slate-gray+ (make-named-color "light-slate-gray" 0.4667 0.5333 0.6000)) (defconstant +LightSlateGray+ (make-named-color "LightSlateGray" 0.4667 0.5333 0.6000)) (defconstant +light-slate-grey+ (make-named-color "light-slate-grey" 0.4667 0.5333 0.6000)) (defconstant +LightSlateGrey+ (make-named-color "LightSlateGrey" 0.4667 0.5333 0.6000)) (defconstant +gray+ (make-named-color "gray" 0.7451 0.7451 0.7451)) (defconstant +grey+ (make-named-color "grey" 0.7451 0.7451 0.7451)) (defconstant +light-grey+ (make-named-color "light-grey" 0.8275 0.8275 0.8275)) (defconstant +LightGrey+ (make-named-color "LightGrey" 0.8275 0.8275 0.8275)) (defconstant +light-gray+ (make-named-color "light-gray" 0.8275 0.8275 0.8275)) (defconstant +LightGray+ (make-named-color "LightGray" 0.8275 0.8275 0.8275)) (defconstant +midnight-blue+ (make-named-color "midnight-blue" 0.0980 0.0980 0.4392)) (defconstant +MidnightBlue+ (make-named-color "MidnightBlue" 0.0980 0.0980 0.4392)) (defconstant +navy+ (make-named-color "navy" 0.0000 0.0000 0.5020)) (defconstant +navy-blue+ (make-named-color "navy-blue" 0.0000 0.0000 0.5020)) (defconstant +NavyBlue+ (make-named-color "NavyBlue" 0.0000 0.0000 0.5020)) (defconstant +cornflower-blue+ (make-named-color "cornflower-blue" 0.3922 0.5843 0.9294)) (defconstant +CornflowerBlue+ (make-named-color "CornflowerBlue" 0.3922 0.5843 0.9294)) (defconstant +dark-slate-blue+ (make-named-color "dark-slate-blue" 0.2824 0.2392 0.5451)) (defconstant +DarkSlateBlue+ (make-named-color "DarkSlateBlue" 0.2824 0.2392 0.5451)) (defconstant +slate-blue+ (make-named-color "slate-blue" 0.4157 0.3529 0.8039)) (defconstant +SlateBlue+ (make-named-color "SlateBlue" 0.4157 0.3529 0.8039)) (defconstant +medium-slate-blue+ (make-named-color "medium-slate-blue" 0.4824 0.4078 0.9333)) (defconstant +MediumSlateBlue+ (make-named-color "MediumSlateBlue" 0.4824 0.4078 0.9333)) (defconstant +light-slate-blue+ (make-named-color "light-slate-blue" 0.5176 0.4392 1.0000)) (defconstant +LightSlateBlue+ (make-named-color "LightSlateBlue" 0.5176 0.4392 1.0000)) (defconstant +medium-blue+ (make-named-color "medium-blue" 0.0000 0.0000 0.8039)) (defconstant +MediumBlue+ (make-named-color "MediumBlue" 0.0000 0.0000 0.8039)) (defconstant +royal-blue+ (make-named-color "royal-blue" 0.2549 0.4118 0.8824)) (defconstant +RoyalBlue+ (make-named-color "RoyalBlue" 0.2549 0.4118 0.8824)) (defconstant +blue+ (make-named-color "blue" 0.0000 0.0000 1.0000)) (defconstant +dodger-blue+ (make-named-color "dodger-blue" 0.1176 0.5647 1.0000)) (defconstant +DodgerBlue+ (make-named-color "DodgerBlue" 0.1176 0.5647 1.0000)) (defconstant +deep-sky-blue+ (make-named-color "deep-sky-blue" 0.0000 0.7490 1.0000)) (defconstant +DeepSkyBlue+ (make-named-color "DeepSkyBlue" 0.0000 0.7490 1.0000)) (defconstant +sky-blue+ (make-named-color "sky-blue" 0.5294 0.8078 0.9216)) (defconstant +SkyBlue+ (make-named-color "SkyBlue" 0.5294 0.8078 0.9216)) (defconstant +light-sky-blue+ (make-named-color "light-sky-blue" 0.5294 0.8078 0.9804)) (defconstant +LightSkyBlue+ (make-named-color "LightSkyBlue" 0.5294 0.8078 0.9804)) (defconstant +steel-blue+ (make-named-color "steel-blue" 0.2745 0.5098 0.7059)) (defconstant +SteelBlue+ (make-named-color "SteelBlue" 0.2745 0.5098 0.7059)) (defconstant +light-steel-blue+ (make-named-color "light-steel-blue" 0.6902 0.7686 0.8706)) (defconstant +LightSteelBlue+ (make-named-color "LightSteelBlue" 0.6902 0.7686 0.8706)) (defconstant +light-blue+ (make-named-color "light-blue" 0.6784 0.8471 0.9020)) (defconstant +LightBlue+ (make-named-color "LightBlue" 0.6784 0.8471 0.9020)) (defconstant +powder-blue+ (make-named-color "powder-blue" 0.6902 0.8784 0.9020)) (defconstant +PowderBlue+ (make-named-color "PowderBlue" 0.6902 0.8784 0.9020)) (defconstant +pale-turquoise+ (make-named-color "pale-turquoise" 0.6863 0.9333 0.9333)) (defconstant +PaleTurquoise+ (make-named-color "PaleTurquoise" 0.6863 0.9333 0.9333)) (defconstant +dark-turquoise+ (make-named-color "dark-turquoise" 0.0000 0.8078 0.8196)) (defconstant +DarkTurquoise+ (make-named-color "DarkTurquoise" 0.0000 0.8078 0.8196)) (defconstant +medium-turquoise+ (make-named-color "medium-turquoise" 0.2824 0.8196 0.8000)) (defconstant +MediumTurquoise+ (make-named-color "MediumTurquoise" 0.2824 0.8196 0.8000)) (defconstant +turquoise+ (make-named-color "turquoise" 0.2510 0.8784 0.8157)) (defconstant +cyan+ (make-named-color "cyan" 0.0000 1.0000 1.0000)) (defconstant +light-cyan+ (make-named-color "light-cyan" 0.8784 1.0000 1.0000)) (defconstant +LightCyan+ (make-named-color "LightCyan" 0.8784 1.0000 1.0000)) (defconstant +cadet-blue+ (make-named-color "cadet-blue" 0.3725 0.6196 0.6275)) (defconstant +CadetBlue+ (make-named-color "CadetBlue" 0.3725 0.6196 0.6275)) (defconstant +medium-aquamarine+ (make-named-color "medium-aquamarine" 0.4000 0.8039 0.6667)) (defconstant +MediumAquamarine+ (make-named-color "MediumAquamarine" 0.4000 0.8039 0.6667)) (defconstant +aquamarine+ (make-named-color "aquamarine" 0.4980 1.0000 0.8314)) (defconstant +dark-green+ (make-named-color "dark-green" 0.0000 0.3922 0.0000)) (defconstant +DarkGreen+ (make-named-color "DarkGreen" 0.0000 0.3922 0.0000)) (defconstant +dark-olive-green+ (make-named-color "dark-olive-green" 0.3333 0.4196 0.1843)) (defconstant +DarkOliveGreen+ (make-named-color "DarkOliveGreen" 0.3333 0.4196 0.1843)) (defconstant +dark-sea-green+ (make-named-color "dark-sea-green" 0.5608 0.7373 0.5608)) (defconstant +DarkSeaGreen+ (make-named-color "DarkSeaGreen" 0.5608 0.7373 0.5608)) (defconstant +sea-green+ (make-named-color "sea-green" 0.1804 0.5451 0.3412)) (defconstant +SeaGreen+ (make-named-color "SeaGreen" 0.1804 0.5451 0.3412)) (defconstant +medium-sea-green+ (make-named-color "medium-sea-green" 0.2353 0.7020 0.4431)) (defconstant +MediumSeaGreen+ (make-named-color "MediumSeaGreen" 0.2353 0.7020 0.4431)) (defconstant +light-sea-green+ (make-named-color "light-sea-green" 0.1255 0.6980 0.6667)) (defconstant +LightSeaGreen+ (make-named-color "LightSeaGreen" 0.1255 0.6980 0.6667)) (defconstant +pale-green+ (make-named-color "pale-green" 0.5961 0.9843 0.5961)) (defconstant +PaleGreen+ (make-named-color "PaleGreen" 0.5961 0.9843 0.5961)) (defconstant +spring-green+ (make-named-color "spring-green" 0.0000 1.0000 0.4980)) (defconstant +SpringGreen+ (make-named-color "SpringGreen" 0.0000 1.0000 0.4980)) (defconstant +lawn-green+ (make-named-color "lawn-green" 0.4863 0.9882 0.0000)) (defconstant +LawnGreen+ (make-named-color "LawnGreen" 0.4863 0.9882 0.0000)) (defconstant +green+ (make-named-color "green" 0.0000 1.0000 0.0000)) (defconstant +chartreuse+ (make-named-color "chartreuse" 0.4980 1.0000 0.0000)) (defconstant +medium-spring-green+ (make-named-color "medium-spring-green" 0.0000 0.9804 0.6039)) (defconstant +MediumSpringGreen+ (make-named-color "MediumSpringGreen" 0.0000 0.9804 0.6039)) (defconstant +green-yellow+ (make-named-color "green-yellow" 0.6784 1.0000 0.1843)) (defconstant +GreenYellow+ (make-named-color "GreenYellow" 0.6784 1.0000 0.1843)) (defconstant +lime-green+ (make-named-color "lime-green" 0.1961 0.8039 0.1961)) (defconstant +LimeGreen+ (make-named-color "LimeGreen" 0.1961 0.8039 0.1961)) (defconstant +yellow-green+ (make-named-color "yellow-green" 0.6039 0.8039 0.1961)) (defconstant +YellowGreen+ (make-named-color "YellowGreen" 0.6039 0.8039 0.1961)) (defconstant +forest-green+ (make-named-color "forest-green" 0.1333 0.5451 0.1333)) (defconstant +ForestGreen+ (make-named-color "ForestGreen" 0.1333 0.5451 0.1333)) (defconstant +olive-drab+ (make-named-color "olive-drab" 0.4196 0.5569 0.1373)) (defconstant +OliveDrab+ (make-named-color "OliveDrab" 0.4196 0.5569 0.1373)) (defconstant +dark-khaki+ (make-named-color "dark-khaki" 0.7412 0.7176 0.4196)) (defconstant +DarkKhaki+ (make-named-color "DarkKhaki" 0.7412 0.7176 0.4196)) (defconstant +khaki+ (make-named-color "khaki" 0.9412 0.9020 0.5490)) (defconstant +pale-goldenrod+ (make-named-color "pale-goldenrod" 0.9333 0.9098 0.6667)) (defconstant +PaleGoldenrod+ (make-named-color "PaleGoldenrod" 0.9333 0.9098 0.6667)) (defconstant +light-goldenrod-yellow+ (make-named-color "light-goldenrod-yellow" 0.9804 0.9804 0.8235)) (defconstant +LightGoldenrodYellow+ (make-named-color "LightGoldenrodYellow" 0.9804 0.9804 0.8235)) (defconstant +light-yellow+ (make-named-color "light-yellow" 1.0000 1.0000 0.8784)) (defconstant +LightYellow+ (make-named-color "LightYellow" 1.0000 1.0000 0.8784)) (defconstant +yellow+ (make-named-color "yellow" 1.0000 1.0000 0.0000)) (defconstant +gold+ (make-named-color "gold" 1.0000 0.8431 0.0000)) (defconstant +light-goldenrod+ (make-named-color "light-goldenrod" 0.9333 0.8667 0.5098)) (defconstant +LightGoldenrod+ (make-named-color "LightGoldenrod" 0.9333 0.8667 0.5098)) (defconstant +goldenrod+ (make-named-color "goldenrod" 0.8549 0.6471 0.1255)) (defconstant +dark-goldenrod+ (make-named-color "dark-goldenrod" 0.7216 0.5255 0.0431)) (defconstant +DarkGoldenrod+ (make-named-color "DarkGoldenrod" 0.7216 0.5255 0.0431)) (defconstant +rosy-brown+ (make-named-color "rosy-brown" 0.7373 0.5608 0.5608)) (defconstant +RosyBrown+ (make-named-color "RosyBrown" 0.7373 0.5608 0.5608)) (defconstant +indian-red+ (make-named-color "indian-red" 0.8039 0.3608 0.3608)) (defconstant +IndianRed+ (make-named-color "IndianRed" 0.8039 0.3608 0.3608)) (defconstant +saddle-brown+ (make-named-color "saddle-brown" 0.5451 0.2706 0.0745)) (defconstant +SaddleBrown+ (make-named-color "SaddleBrown" 0.5451 0.2706 0.0745)) (defconstant +sienna+ (make-named-color "sienna" 0.6275 0.3216 0.1765)) (defconstant +peru+ (make-named-color "peru" 0.8039 0.5216 0.2471)) (defconstant +burlywood+ (make-named-color "burlywood" 0.8706 0.7216 0.5294)) (defconstant +beige+ (make-named-color "beige" 0.9608 0.9608 0.8627)) (defconstant +wheat+ (make-named-color "wheat" 0.9608 0.8706 0.7020)) (defconstant +sandy-brown+ (make-named-color "sandy-brown" 0.9569 0.6431 0.3765)) (defconstant +SandyBrown+ (make-named-color "SandyBrown" 0.9569 0.6431 0.3765)) (defconstant +tan+ (make-named-color "tan" 0.8235 0.7059 0.5490)) (defconstant +chocolate+ (make-named-color "chocolate" 0.8235 0.4118 0.1176)) (defconstant +firebrick+ (make-named-color "firebrick" 0.6980 0.1333 0.1333)) (defconstant +brown+ (make-named-color "brown" 0.6471 0.1647 0.1647)) (defconstant +dark-salmon+ (make-named-color "dark-salmon" 0.9137 0.5882 0.4784)) (defconstant +DarkSalmon+ (make-named-color "DarkSalmon" 0.9137 0.5882 0.4784)) (defconstant +salmon+ (make-named-color "salmon" 0.9804 0.5020 0.4471)) (defconstant +light-salmon+ (make-named-color "light-salmon" 1.0000 0.6275 0.4784)) (defconstant +LightSalmon+ (make-named-color "LightSalmon" 1.0000 0.6275 0.4784)) (defconstant +orange+ (make-named-color "orange" 1.0000 0.6471 0.0000)) (defconstant +dark-orange+ (make-named-color "dark-orange" 1.0000 0.5490 0.0000)) (defconstant +DarkOrange+ (make-named-color "DarkOrange" 1.0000 0.5490 0.0000)) (defconstant +coral+ (make-named-color "coral" 1.0000 0.4980 0.3137)) (defconstant +light-coral+ (make-named-color "light-coral" 0.9412 0.5020 0.5020)) (defconstant +LightCoral+ (make-named-color "LightCoral" 0.9412 0.5020 0.5020)) (defconstant +tomato+ (make-named-color "tomato" 1.0000 0.3882 0.2784)) (defconstant +orange-red+ (make-named-color "orange-red" 1.0000 0.2706 0.0000)) (defconstant +OrangeRed+ (make-named-color "OrangeRed" 1.0000 0.2706 0.0000)) (defconstant +red+ (make-named-color "red" 1.0000 0.0000 0.0000)) (defconstant +hot-pink+ (make-named-color "hot-pink" 1.0000 0.4118 0.7059)) (defconstant +HotPink+ (make-named-color "HotPink" 1.0000 0.4118 0.7059)) (defconstant +deep-pink+ (make-named-color "deep-pink" 1.0000 0.0784 0.5765)) (defconstant +DeepPink+ (make-named-color "DeepPink" 1.0000 0.0784 0.5765)) (defconstant +pink+ (make-named-color "pink" 1.0000 0.7529 0.7961)) (defconstant +light-pink+ (make-named-color "light-pink" 1.0000 0.7137 0.7569)) (defconstant +LightPink+ (make-named-color "LightPink" 1.0000 0.7137 0.7569)) (defconstant +pale-violet-red+ (make-named-color "pale-violet-red" 0.8588 0.4392 0.5765)) (defconstant +PaleVioletRed+ (make-named-color "PaleVioletRed" 0.8588 0.4392 0.5765)) (defconstant +maroon+ (make-named-color "maroon" 0.6902 0.1882 0.3765)) (defconstant +medium-violet-red+ (make-named-color "medium-violet-red" 0.7804 0.0824 0.5216)) (defconstant +MediumVioletRed+ (make-named-color "MediumVioletRed" 0.7804 0.0824 0.5216)) (defconstant +violet-red+ (make-named-color "violet-red" 0.8157 0.1255 0.5647)) (defconstant +VioletRed+ (make-named-color "VioletRed" 0.8157 0.1255 0.5647)) (defconstant +magenta+ (make-named-color "magenta" 1.0000 0.0000 1.0000)) (defconstant +violet+ (make-named-color "violet" 0.9333 0.5098 0.9333)) (defconstant +plum+ (make-named-color "plum" 0.8667 0.6275 0.8667)) (defconstant +orchid+ (make-named-color "orchid" 0.8549 0.4392 0.8392)) (defconstant +medium-orchid+ (make-named-color "medium-orchid" 0.7294 0.3333 0.8275)) (defconstant +MediumOrchid+ (make-named-color "MediumOrchid" 0.7294 0.3333 0.8275)) (defconstant +dark-orchid+ (make-named-color "dark-orchid" 0.6000 0.1961 0.8000)) (defconstant +DarkOrchid+ (make-named-color "DarkOrchid" 0.6000 0.1961 0.8000)) (defconstant +dark-violet+ (make-named-color "dark-violet" 0.5804 0.0000 0.8275)) (defconstant +DarkViolet+ (make-named-color "DarkViolet" 0.5804 0.0000 0.8275)) (defconstant +blue-violet+ (make-named-color "blue-violet" 0.5412 0.1686 0.8863)) (defconstant +BlueViolet+ (make-named-color "BlueViolet" 0.5412 0.1686 0.8863)) (defconstant +purple+ (make-named-color "purple" 0.6275 0.1255 0.9412)) (defconstant +medium-purple+ (make-named-color "medium-purple" 0.5765 0.4392 0.8588)) (defconstant +MediumPurple+ (make-named-color "MediumPurple" 0.5765 0.4392 0.8588)) (defconstant +thistle+ (make-named-color "thistle" 0.8471 0.7490 0.8471)) (defconstant +snow1+ (make-named-color "snow1" 1.0000 0.9804 0.9804)) (defconstant +snow2+ (make-named-color "snow2" 0.9333 0.9137 0.9137)) (defconstant +snow3+ (make-named-color "snow3" 0.8039 0.7882 0.7882)) (defconstant +snow4+ (make-named-color "snow4" 0.5451 0.5373 0.5373)) (defconstant +seashell1+ (make-named-color "seashell1" 1.0000 0.9608 0.9333)) (defconstant +seashell2+ (make-named-color "seashell2" 0.9333 0.8980 0.8706)) (defconstant +seashell3+ (make-named-color "seashell3" 0.8039 0.7725 0.7490)) (defconstant +seashell4+ (make-named-color "seashell4" 0.5451 0.5255 0.5098)) (defconstant +AntiqueWhite1+ (make-named-color "AntiqueWhite1" 1.0000 0.9373 0.8588)) (defconstant +AntiqueWhite2+ (make-named-color "AntiqueWhite2" 0.9333 0.8745 0.8000)) (defconstant +AntiqueWhite3+ (make-named-color "AntiqueWhite3" 0.8039 0.7529 0.6902)) (defconstant +AntiqueWhite4+ (make-named-color "AntiqueWhite4" 0.5451 0.5137 0.4706)) (defconstant +bisque1+ (make-named-color "bisque1" 1.0000 0.8941 0.7686)) (defconstant +bisque2+ (make-named-color "bisque2" 0.9333 0.8353 0.7176)) (defconstant +bisque3+ (make-named-color "bisque3" 0.8039 0.7176 0.6196)) (defconstant +bisque4+ (make-named-color "bisque4" 0.5451 0.4902 0.4196)) (defconstant +PeachPuff1+ (make-named-color "PeachPuff1" 1.0000 0.8549 0.7255)) (defconstant +PeachPuff2+ (make-named-color "PeachPuff2" 0.9333 0.7961 0.6784)) (defconstant +PeachPuff3+ (make-named-color "PeachPuff3" 0.8039 0.6863 0.5843)) (defconstant +PeachPuff4+ (make-named-color "PeachPuff4" 0.5451 0.4667 0.3961)) (defconstant +NavajoWhite1+ (make-named-color "NavajoWhite1" 1.0000 0.8706 0.6784)) (defconstant +NavajoWhite2+ (make-named-color "NavajoWhite2" 0.9333 0.8118 0.6314)) (defconstant +NavajoWhite3+ (make-named-color "NavajoWhite3" 0.8039 0.7020 0.5451)) (defconstant +NavajoWhite4+ (make-named-color "NavajoWhite4" 0.5451 0.4745 0.3686)) (defconstant +LemonChiffon1+ (make-named-color "LemonChiffon1" 1.0000 0.9804 0.8039)) (defconstant +LemonChiffon2+ (make-named-color "LemonChiffon2" 0.9333 0.9137 0.7490)) (defconstant +LemonChiffon3+ (make-named-color "LemonChiffon3" 0.8039 0.7882 0.6471)) (defconstant +LemonChiffon4+ (make-named-color "LemonChiffon4" 0.5451 0.5373 0.4392)) (defconstant +cornsilk1+ (make-named-color "cornsilk1" 1.0000 0.9725 0.8627)) (defconstant +cornsilk2+ (make-named-color "cornsilk2" 0.9333 0.9098 0.8039)) (defconstant +cornsilk3+ (make-named-color "cornsilk3" 0.8039 0.7843 0.6941)) (defconstant +cornsilk4+ (make-named-color "cornsilk4" 0.5451 0.5333 0.4706)) (defconstant +ivory1+ (make-named-color "ivory1" 1.0000 1.0000 0.9412)) (defconstant +ivory2+ (make-named-color "ivory2" 0.9333 0.9333 0.8784)) (defconstant +ivory3+ (make-named-color "ivory3" 0.8039 0.8039 0.7569)) (defconstant +ivory4+ (make-named-color "ivory4" 0.5451 0.5451 0.5137)) (defconstant +honeydew1+ (make-named-color "honeydew1" 0.9412 1.0000 0.9412)) (defconstant +honeydew2+ (make-named-color "honeydew2" 0.8784 0.9333 0.8784)) (defconstant +honeydew3+ (make-named-color "honeydew3" 0.7569 0.8039 0.7569)) (defconstant +honeydew4+ (make-named-color "honeydew4" 0.5137 0.5451 0.5137)) (defconstant +LavenderBlush1+ (make-named-color "LavenderBlush1" 1.0000 0.9412 0.9608)) (defconstant +LavenderBlush2+ (make-named-color "LavenderBlush2" 0.9333 0.8784 0.8980)) (defconstant +LavenderBlush3+ (make-named-color "LavenderBlush3" 0.8039 0.7569 0.7725)) (defconstant +LavenderBlush4+ (make-named-color "LavenderBlush4" 0.5451 0.5137 0.5255)) (defconstant +MistyRose1+ (make-named-color "MistyRose1" 1.0000 0.8941 0.8824)) (defconstant +MistyRose2+ (make-named-color "MistyRose2" 0.9333 0.8353 0.8235)) (defconstant +MistyRose3+ (make-named-color "MistyRose3" 0.8039 0.7176 0.7098)) (defconstant +MistyRose4+ (make-named-color "MistyRose4" 0.5451 0.4902 0.4824)) (defconstant +azure1+ (make-named-color "azure1" 0.9412 1.0000 1.0000)) (defconstant +azure2+ (make-named-color "azure2" 0.8784 0.9333 0.9333)) (defconstant +azure3+ (make-named-color "azure3" 0.7569 0.8039 0.8039)) (defconstant +azure4+ (make-named-color "azure4" 0.5137 0.5451 0.5451)) (defconstant +SlateBlue1+ (make-named-color "SlateBlue1" 0.5137 0.4353 1.0000)) (defconstant +SlateBlue2+ (make-named-color "SlateBlue2" 0.4784 0.4039 0.9333)) (defconstant +SlateBlue3+ (make-named-color "SlateBlue3" 0.4118 0.3490 0.8039)) (defconstant +SlateBlue4+ (make-named-color "SlateBlue4" 0.2784 0.2353 0.5451)) (defconstant +RoyalBlue1+ (make-named-color "RoyalBlue1" 0.2824 0.4627 1.0000)) (defconstant +RoyalBlue2+ (make-named-color "RoyalBlue2" 0.2627 0.4314 0.9333)) (defconstant +RoyalBlue3+ (make-named-color "RoyalBlue3" 0.2275 0.3725 0.8039)) (defconstant +RoyalBlue4+ (make-named-color "RoyalBlue4" 0.1529 0.2510 0.5451)) (defconstant +blue1+ (make-named-color "blue1" 0.0000 0.0000 1.0000)) (defconstant +blue2+ (make-named-color "blue2" 0.0000 0.0000 0.9333)) (defconstant +blue3+ (make-named-color "blue3" 0.0000 0.0000 0.8039)) (defconstant +blue4+ (make-named-color "blue4" 0.0000 0.0000 0.5451)) (defconstant +DodgerBlue1+ (make-named-color "DodgerBlue1" 0.1176 0.5647 1.0000)) (defconstant +DodgerBlue2+ (make-named-color "DodgerBlue2" 0.1098 0.5255 0.9333)) (defconstant +DodgerBlue3+ (make-named-color "DodgerBlue3" 0.0941 0.4549 0.8039)) (defconstant +DodgerBlue4+ (make-named-color "DodgerBlue4" 0.0627 0.3059 0.5451)) (defconstant +SteelBlue1+ (make-named-color "SteelBlue1" 0.3882 0.7216 1.0000)) (defconstant +SteelBlue2+ (make-named-color "SteelBlue2" 0.3608 0.6745 0.9333)) (defconstant +SteelBlue3+ (make-named-color "SteelBlue3" 0.3098 0.5804 0.8039)) (defconstant +SteelBlue4+ (make-named-color "SteelBlue4" 0.2118 0.3922 0.5451)) (defconstant +DeepSkyBlue1+ (make-named-color "DeepSkyBlue1" 0.0000 0.7490 1.0000)) (defconstant +DeepSkyBlue2+ (make-named-color "DeepSkyBlue2" 0.0000 0.6980 0.9333)) (defconstant +DeepSkyBlue3+ (make-named-color "DeepSkyBlue3" 0.0000 0.6039 0.8039)) (defconstant +DeepSkyBlue4+ (make-named-color "DeepSkyBlue4" 0.0000 0.4078 0.5451)) (defconstant +SkyBlue1+ (make-named-color "SkyBlue1" 0.5294 0.8078 1.0000)) (defconstant +SkyBlue2+ (make-named-color "SkyBlue2" 0.4941 0.7529 0.9333)) (defconstant +SkyBlue3+ (make-named-color "SkyBlue3" 0.4235 0.6510 0.8039)) (defconstant +SkyBlue4+ (make-named-color "SkyBlue4" 0.2902 0.4392 0.5451)) (defconstant +LightSkyBlue1+ (make-named-color "LightSkyBlue1" 0.6902 0.8863 1.0000)) (defconstant +LightSkyBlue2+ (make-named-color "LightSkyBlue2" 0.6431 0.8275 0.9333)) (defconstant +LightSkyBlue3+ (make-named-color "LightSkyBlue3" 0.5529 0.7137 0.8039)) (defconstant +LightSkyBlue4+ (make-named-color "LightSkyBlue4" 0.3765 0.4824 0.5451)) (defconstant +SlateGray1+ (make-named-color "SlateGray1" 0.7765 0.8863 1.0000)) (defconstant +SlateGray2+ (make-named-color "SlateGray2" 0.7255 0.8275 0.9333)) (defconstant +SlateGray3+ (make-named-color "SlateGray3" 0.6235 0.7137 0.8039)) (defconstant +SlateGray4+ (make-named-color "SlateGray4" 0.4235 0.4824 0.5451)) (defconstant +LightSteelBlue1+ (make-named-color "LightSteelBlue1" 0.7922 0.8824 1.0000)) (defconstant +LightSteelBlue2+ (make-named-color "LightSteelBlue2" 0.7373 0.8235 0.9333)) (defconstant +LightSteelBlue3+ (make-named-color "LightSteelBlue3" 0.6353 0.7098 0.8039)) (defconstant +LightSteelBlue4+ (make-named-color "LightSteelBlue4" 0.4314 0.4824 0.5451)) (defconstant +LightBlue1+ (make-named-color "LightBlue1" 0.7490 0.9373 1.0000)) (defconstant +LightBlue2+ (make-named-color "LightBlue2" 0.6980 0.8745 0.9333)) (defconstant +LightBlue3+ (make-named-color "LightBlue3" 0.6039 0.7529 0.8039)) (defconstant +LightBlue4+ (make-named-color "LightBlue4" 0.4078 0.5137 0.5451)) (defconstant +LightCyan1+ (make-named-color "LightCyan1" 0.8784 1.0000 1.0000)) (defconstant +LightCyan2+ (make-named-color "LightCyan2" 0.8196 0.9333 0.9333)) (defconstant +LightCyan3+ (make-named-color "LightCyan3" 0.7059 0.8039 0.8039)) (defconstant +LightCyan4+ (make-named-color "LightCyan4" 0.4784 0.5451 0.5451)) (defconstant +PaleTurquoise1+ (make-named-color "PaleTurquoise1" 0.7333 1.0000 1.0000)) (defconstant +PaleTurquoise2+ (make-named-color "PaleTurquoise2" 0.6824 0.9333 0.9333)) (defconstant +PaleTurquoise3+ (make-named-color "PaleTurquoise3" 0.5882 0.8039 0.8039)) (defconstant +PaleTurquoise4+ (make-named-color "PaleTurquoise4" 0.4000 0.5451 0.5451)) (defconstant +CadetBlue1+ (make-named-color "CadetBlue1" 0.5961 0.9608 1.0000)) (defconstant +CadetBlue2+ (make-named-color "CadetBlue2" 0.5569 0.8980 0.9333)) (defconstant +CadetBlue3+ (make-named-color "CadetBlue3" 0.4784 0.7725 0.8039)) (defconstant +CadetBlue4+ (make-named-color "CadetBlue4" 0.3255 0.5255 0.5451)) (defconstant +turquoise1+ (make-named-color "turquoise1" 0.0000 0.9608 1.0000)) (defconstant +turquoise2+ (make-named-color "turquoise2" 0.0000 0.8980 0.9333)) (defconstant +turquoise3+ (make-named-color "turquoise3" 0.0000 0.7725 0.8039)) (defconstant +turquoise4+ (make-named-color "turquoise4" 0.0000 0.5255 0.5451)) (defconstant +cyan1+ (make-named-color "cyan1" 0.0000 1.0000 1.0000)) (defconstant +cyan2+ (make-named-color "cyan2" 0.0000 0.9333 0.9333)) (defconstant +cyan3+ (make-named-color "cyan3" 0.0000 0.8039 0.8039)) (defconstant +cyan4+ (make-named-color "cyan4" 0.0000 0.5451 0.5451)) (defconstant +DarkSlateGray1+ (make-named-color "DarkSlateGray1" 0.5922 1.0000 1.0000)) (defconstant +DarkSlateGray2+ (make-named-color "DarkSlateGray2" 0.5529 0.9333 0.9333)) (defconstant +DarkSlateGray3+ (make-named-color "DarkSlateGray3" 0.4745 0.8039 0.8039)) (defconstant +DarkSlateGray4+ (make-named-color "DarkSlateGray4" 0.3216 0.5451 0.5451)) (defconstant +aquamarine1+ (make-named-color "aquamarine1" 0.4980 1.0000 0.8314)) (defconstant +aquamarine2+ (make-named-color "aquamarine2" 0.4627 0.9333 0.7765)) (defconstant +aquamarine3+ (make-named-color "aquamarine3" 0.4000 0.8039 0.6667)) (defconstant +aquamarine4+ (make-named-color "aquamarine4" 0.2706 0.5451 0.4549)) (defconstant +DarkSeaGreen1+ (make-named-color "DarkSeaGreen1" 0.7569 1.0000 0.7569)) (defconstant +DarkSeaGreen2+ (make-named-color "DarkSeaGreen2" 0.7059 0.9333 0.7059)) (defconstant +DarkSeaGreen3+ (make-named-color "DarkSeaGreen3" 0.6078 0.8039 0.6078)) (defconstant +DarkSeaGreen4+ (make-named-color "DarkSeaGreen4" 0.4118 0.5451 0.4118)) (defconstant +SeaGreen1+ (make-named-color "SeaGreen1" 0.3294 1.0000 0.6235)) (defconstant +SeaGreen2+ (make-named-color "SeaGreen2" 0.3059 0.9333 0.5804)) (defconstant +SeaGreen3+ (make-named-color "SeaGreen3" 0.2627 0.8039 0.5020)) (defconstant +SeaGreen4+ (make-named-color "SeaGreen4" 0.1804 0.5451 0.3412)) (defconstant +PaleGreen1+ (make-named-color "PaleGreen1" 0.6039 1.0000 0.6039)) (defconstant +PaleGreen2+ (make-named-color "PaleGreen2" 0.5647 0.9333 0.5647)) (defconstant +PaleGreen3+ (make-named-color "PaleGreen3" 0.4863 0.8039 0.4863)) (defconstant +PaleGreen4+ (make-named-color "PaleGreen4" 0.3294 0.5451 0.3294)) (defconstant +SpringGreen1+ (make-named-color "SpringGreen1" 0.0000 1.0000 0.4980)) (defconstant +SpringGreen2+ (make-named-color "SpringGreen2" 0.0000 0.9333 0.4627)) (defconstant +SpringGreen3+ (make-named-color "SpringGreen3" 0.0000 0.8039 0.4000)) (defconstant +SpringGreen4+ (make-named-color "SpringGreen4" 0.0000 0.5451 0.2706)) (defconstant +green1+ (make-named-color "green1" 0.0000 1.0000 0.0000)) (defconstant +green2+ (make-named-color "green2" 0.0000 0.9333 0.0000)) (defconstant +green3+ (make-named-color "green3" 0.0000 0.8039 0.0000)) (defconstant +green4+ (make-named-color "green4" 0.0000 0.5451 0.0000)) (defconstant +chartreuse1+ (make-named-color "chartreuse1" 0.4980 1.0000 0.0000)) (defconstant +chartreuse2+ (make-named-color "chartreuse2" 0.4627 0.9333 0.0000)) (defconstant +chartreuse3+ (make-named-color "chartreuse3" 0.4000 0.8039 0.0000)) (defconstant +chartreuse4+ (make-named-color "chartreuse4" 0.2706 0.5451 0.0000)) (defconstant +OliveDrab1+ (make-named-color "OliveDrab1" 0.7529 1.0000 0.2431)) (defconstant +OliveDrab2+ (make-named-color "OliveDrab2" 0.7020 0.9333 0.2275)) (defconstant +OliveDrab3+ (make-named-color "OliveDrab3" 0.6039 0.8039 0.1961)) (defconstant +OliveDrab4+ (make-named-color "OliveDrab4" 0.4118 0.5451 0.1333)) (defconstant +DarkOliveGreen1+ (make-named-color "DarkOliveGreen1" 0.7922 1.0000 0.4392)) (defconstant +DarkOliveGreen2+ (make-named-color "DarkOliveGreen2" 0.7373 0.9333 0.4078)) (defconstant +DarkOliveGreen3+ (make-named-color "DarkOliveGreen3" 0.6353 0.8039 0.3529)) (defconstant +DarkOliveGreen4+ (make-named-color "DarkOliveGreen4" 0.4314 0.5451 0.2392)) (defconstant +khaki1+ (make-named-color "khaki1" 1.0000 0.9647 0.5608)) (defconstant +khaki2+ (make-named-color "khaki2" 0.9333 0.9020 0.5216)) (defconstant +khaki3+ (make-named-color "khaki3" 0.8039 0.7765 0.4510)) (defconstant +khaki4+ (make-named-color "khaki4" 0.5451 0.5255 0.3059)) (defconstant +LightGoldenrod1+ (make-named-color "LightGoldenrod1" 1.0000 0.9255 0.5451)) (defconstant +LightGoldenrod2+ (make-named-color "LightGoldenrod2" 0.9333 0.8627 0.5098)) (defconstant +LightGoldenrod3+ (make-named-color "LightGoldenrod3" 0.8039 0.7451 0.4392)) (defconstant +LightGoldenrod4+ (make-named-color "LightGoldenrod4" 0.5451 0.5059 0.2980)) (defconstant +LightYellow1+ (make-named-color "LightYellow1" 1.0000 1.0000 0.8784)) (defconstant +LightYellow2+ (make-named-color "LightYellow2" 0.9333 0.9333 0.8196)) (defconstant +LightYellow3+ (make-named-color "LightYellow3" 0.8039 0.8039 0.7059)) (defconstant +LightYellow4+ (make-named-color "LightYellow4" 0.5451 0.5451 0.4784)) (defconstant +yellow1+ (make-named-color "yellow1" 1.0000 1.0000 0.0000)) (defconstant +yellow2+ (make-named-color "yellow2" 0.9333 0.9333 0.0000)) (defconstant +yellow3+ (make-named-color "yellow3" 0.8039 0.8039 0.0000)) (defconstant +yellow4+ (make-named-color "yellow4" 0.5451 0.5451 0.0000)) (defconstant +gold1+ (make-named-color "gold1" 1.0000 0.8431 0.0000)) (defconstant +gold2+ (make-named-color "gold2" 0.9333 0.7882 0.0000)) (defconstant +gold3+ (make-named-color "gold3" 0.8039 0.6784 0.0000)) (defconstant +gold4+ (make-named-color "gold4" 0.5451 0.4588 0.0000)) (defconstant +goldenrod1+ (make-named-color "goldenrod1" 1.0000 0.7569 0.1451)) (defconstant +goldenrod2+ (make-named-color "goldenrod2" 0.9333 0.7059 0.1333)) (defconstant +goldenrod3+ (make-named-color "goldenrod3" 0.8039 0.6078 0.1137)) (defconstant +goldenrod4+ (make-named-color "goldenrod4" 0.5451 0.4118 0.0784)) (defconstant +DarkGoldenrod1+ (make-named-color "DarkGoldenrod1" 1.0000 0.7255 0.0588)) (defconstant +DarkGoldenrod2+ (make-named-color "DarkGoldenrod2" 0.9333 0.6784 0.0549)) (defconstant +DarkGoldenrod3+ (make-named-color "DarkGoldenrod3" 0.8039 0.5843 0.0471)) (defconstant +DarkGoldenrod4+ (make-named-color "DarkGoldenrod4" 0.5451 0.3961 0.0314)) (defconstant +RosyBrown1+ (make-named-color "RosyBrown1" 1.0000 0.7569 0.7569)) (defconstant +RosyBrown2+ (make-named-color "RosyBrown2" 0.9333 0.7059 0.7059)) (defconstant +RosyBrown3+ (make-named-color "RosyBrown3" 0.8039 0.6078 0.6078)) (defconstant +RosyBrown4+ (make-named-color "RosyBrown4" 0.5451 0.4118 0.4118)) (defconstant +IndianRed1+ (make-named-color "IndianRed1" 1.0000 0.4157 0.4157)) (defconstant +IndianRed2+ (make-named-color "IndianRed2" 0.9333 0.3882 0.3882)) (defconstant +IndianRed3+ (make-named-color "IndianRed3" 0.8039 0.3333 0.3333)) (defconstant +IndianRed4+ (make-named-color "IndianRed4" 0.5451 0.2275 0.2275)) (defconstant +sienna1+ (make-named-color "sienna1" 1.0000 0.5098 0.2784)) (defconstant +sienna2+ (make-named-color "sienna2" 0.9333 0.4745 0.2588)) (defconstant +sienna3+ (make-named-color "sienna3" 0.8039 0.4078 0.2235)) (defconstant +sienna4+ (make-named-color "sienna4" 0.5451 0.2784 0.1490)) (defconstant +burlywood1+ (make-named-color "burlywood1" 1.0000 0.8275 0.6078)) (defconstant +burlywood2+ (make-named-color "burlywood2" 0.9333 0.7725 0.5686)) (defconstant +burlywood3+ (make-named-color "burlywood3" 0.8039 0.6667 0.4902)) (defconstant +burlywood4+ (make-named-color "burlywood4" 0.5451 0.4510 0.3333)) (defconstant +wheat1+ (make-named-color "wheat1" 1.0000 0.9059 0.7294)) (defconstant +wheat2+ (make-named-color "wheat2" 0.9333 0.8471 0.6824)) (defconstant +wheat3+ (make-named-color "wheat3" 0.8039 0.7294 0.5882)) (defconstant +wheat4+ (make-named-color "wheat4" 0.5451 0.4941 0.4000)) (defconstant +tan1+ (make-named-color "tan1" 1.0000 0.6471 0.3098)) (defconstant +tan2+ (make-named-color "tan2" 0.9333 0.6039 0.2863)) (defconstant +tan3+ (make-named-color "tan3" 0.8039 0.5216 0.2471)) (defconstant +tan4+ (make-named-color "tan4" 0.5451 0.3529 0.1686)) (defconstant +chocolate1+ (make-named-color "chocolate1" 1.0000 0.4980 0.1412)) (defconstant +chocolate2+ (make-named-color "chocolate2" 0.9333 0.4627 0.1294)) (defconstant +chocolate3+ (make-named-color "chocolate3" 0.8039 0.4000 0.1137)) (defconstant +chocolate4+ (make-named-color "chocolate4" 0.5451 0.2706 0.0745)) (defconstant +firebrick1+ (make-named-color "firebrick1" 1.0000 0.1882 0.1882)) (defconstant +firebrick2+ (make-named-color "firebrick2" 0.9333 0.1725 0.1725)) (defconstant +firebrick3+ (make-named-color "firebrick3" 0.8039 0.1490 0.1490)) (defconstant +firebrick4+ (make-named-color "firebrick4" 0.5451 0.1020 0.1020)) (defconstant +brown1+ (make-named-color "brown1" 1.0000 0.2510 0.2510)) (defconstant +brown2+ (make-named-color "brown2" 0.9333 0.2314 0.2314)) (defconstant +brown3+ (make-named-color "brown3" 0.8039 0.2000 0.2000)) (defconstant +brown4+ (make-named-color "brown4" 0.5451 0.1373 0.1373)) (defconstant +salmon1+ (make-named-color "salmon1" 1.0000 0.5490 0.4118)) (defconstant +salmon2+ (make-named-color "salmon2" 0.9333 0.5098 0.3843)) (defconstant +salmon3+ (make-named-color "salmon3" 0.8039 0.4392 0.3294)) (defconstant +salmon4+ (make-named-color "salmon4" 0.5451 0.2980 0.2235)) (defconstant +LightSalmon1+ (make-named-color "LightSalmon1" 1.0000 0.6275 0.4784)) (defconstant +LightSalmon2+ (make-named-color "LightSalmon2" 0.9333 0.5843 0.4471)) (defconstant +LightSalmon3+ (make-named-color "LightSalmon3" 0.8039 0.5059 0.3843)) (defconstant +LightSalmon4+ (make-named-color "LightSalmon4" 0.5451 0.3412 0.2588)) (defconstant +orange1+ (make-named-color "orange1" 1.0000 0.6471 0.0000)) (defconstant +orange2+ (make-named-color "orange2" 0.9333 0.6039 0.0000)) (defconstant +orange3+ (make-named-color "orange3" 0.8039 0.5216 0.0000)) (defconstant +orange4+ (make-named-color "orange4" 0.5451 0.3529 0.0000)) (defconstant +DarkOrange1+ (make-named-color "DarkOrange1" 1.0000 0.4980 0.0000)) (defconstant +DarkOrange2+ (make-named-color "DarkOrange2" 0.9333 0.4627 0.0000)) (defconstant +DarkOrange3+ (make-named-color "DarkOrange3" 0.8039 0.4000 0.0000)) (defconstant +DarkOrange4+ (make-named-color "DarkOrange4" 0.5451 0.2706 0.0000)) (defconstant +coral1+ (make-named-color "coral1" 1.0000 0.4471 0.3373)) (defconstant +coral2+ (make-named-color "coral2" 0.9333 0.4157 0.3137)) (defconstant +coral3+ (make-named-color "coral3" 0.8039 0.3569 0.2706)) (defconstant +coral4+ (make-named-color "coral4" 0.5451 0.2431 0.1843)) (defconstant +tomato1+ (make-named-color "tomato1" 1.0000 0.3882 0.2784)) (defconstant +tomato2+ (make-named-color "tomato2" 0.9333 0.3608 0.2588)) (defconstant +tomato3+ (make-named-color "tomato3" 0.8039 0.3098 0.2235)) (defconstant +tomato4+ (make-named-color "tomato4" 0.5451 0.2118 0.1490)) (defconstant +OrangeRed1+ (make-named-color "OrangeRed1" 1.0000 0.2706 0.0000)) (defconstant +OrangeRed2+ (make-named-color "OrangeRed2" 0.9333 0.2510 0.0000)) (defconstant +OrangeRed3+ (make-named-color "OrangeRed3" 0.8039 0.2157 0.0000)) (defconstant +OrangeRed4+ (make-named-color "OrangeRed4" 0.5451 0.1451 0.0000)) (defconstant +red1+ (make-named-color "red1" 1.0000 0.0000 0.0000)) (defconstant +red2+ (make-named-color "red2" 0.9333 0.0000 0.0000)) (defconstant +red3+ (make-named-color "red3" 0.8039 0.0000 0.0000)) (defconstant +red4+ (make-named-color "red4" 0.5451 0.0000 0.0000)) (defconstant +DeepPink1+ (make-named-color "DeepPink1" 1.0000 0.0784 0.5765)) (defconstant +DeepPink2+ (make-named-color "DeepPink2" 0.9333 0.0706 0.5373)) (defconstant +DeepPink3+ (make-named-color "DeepPink3" 0.8039 0.0627 0.4627)) (defconstant +DeepPink4+ (make-named-color "DeepPink4" 0.5451 0.0392 0.3137)) (defconstant +HotPink1+ (make-named-color "HotPink1" 1.0000 0.4314 0.7059)) (defconstant +HotPink2+ (make-named-color "HotPink2" 0.9333 0.4157 0.6549)) (defconstant +HotPink3+ (make-named-color "HotPink3" 0.8039 0.3765 0.5647)) (defconstant +HotPink4+ (make-named-color "HotPink4" 0.5451 0.2275 0.3843)) (defconstant +pink1+ (make-named-color "pink1" 1.0000 0.7098 0.7725)) (defconstant +pink2+ (make-named-color "pink2" 0.9333 0.6627 0.7216)) (defconstant +pink3+ (make-named-color "pink3" 0.8039 0.5686 0.6196)) (defconstant +pink4+ (make-named-color "pink4" 0.5451 0.3882 0.4235)) (defconstant +LightPink1+ (make-named-color "LightPink1" 1.0000 0.6824 0.7255)) (defconstant +LightPink2+ (make-named-color "LightPink2" 0.9333 0.6353 0.6784)) (defconstant +LightPink3+ (make-named-color "LightPink3" 0.8039 0.5490 0.5843)) (defconstant +LightPink4+ (make-named-color "LightPink4" 0.5451 0.3725 0.3961)) (defconstant +PaleVioletRed1+ (make-named-color "PaleVioletRed1" 1.0000 0.5098 0.6706)) (defconstant +PaleVioletRed2+ (make-named-color "PaleVioletRed2" 0.9333 0.4745 0.6235)) (defconstant +PaleVioletRed3+ (make-named-color "PaleVioletRed3" 0.8039 0.4078 0.5373)) (defconstant +PaleVioletRed4+ (make-named-color "PaleVioletRed4" 0.5451 0.2784 0.3647)) (defconstant +maroon1+ (make-named-color "maroon1" 1.0000 0.2039 0.7020)) (defconstant +maroon2+ (make-named-color "maroon2" 0.9333 0.1882 0.6549)) (defconstant +maroon3+ (make-named-color "maroon3" 0.8039 0.1608 0.5647)) (defconstant +maroon4+ (make-named-color "maroon4" 0.5451 0.1098 0.3843)) (defconstant +VioletRed1+ (make-named-color "VioletRed1" 1.0000 0.2431 0.5882)) (defconstant +VioletRed2+ (make-named-color "VioletRed2" 0.9333 0.2275 0.5490)) (defconstant +VioletRed3+ (make-named-color "VioletRed3" 0.8039 0.1961 0.4706)) (defconstant +VioletRed4+ (make-named-color "VioletRed4" 0.5451 0.1333 0.3216)) (defconstant +magenta1+ (make-named-color "magenta1" 1.0000 0.0000 1.0000)) (defconstant +magenta2+ (make-named-color "magenta2" 0.9333 0.0000 0.9333)) (defconstant +magenta3+ (make-named-color "magenta3" 0.8039 0.0000 0.8039)) (defconstant +magenta4+ (make-named-color "magenta4" 0.5451 0.0000 0.5451)) (defconstant +orchid1+ (make-named-color "orchid1" 1.0000 0.5137 0.9804)) (defconstant +orchid2+ (make-named-color "orchid2" 0.9333 0.4784 0.9137)) (defconstant +orchid3+ (make-named-color "orchid3" 0.8039 0.4118 0.7882)) (defconstant +orchid4+ (make-named-color "orchid4" 0.5451 0.2784 0.5373)) (defconstant +plum1+ (make-named-color "plum1" 1.0000 0.7333 1.0000)) (defconstant +plum2+ (make-named-color "plum2" 0.9333 0.6824 0.9333)) (defconstant +plum3+ (make-named-color "plum3" 0.8039 0.5882 0.8039)) (defconstant +plum4+ (make-named-color "plum4" 0.5451 0.4000 0.5451)) (defconstant +MediumOrchid1+ (make-named-color "MediumOrchid1" 0.8784 0.4000 1.0000)) (defconstant +MediumOrchid2+ (make-named-color "MediumOrchid2" 0.8196 0.3725 0.9333)) (defconstant +MediumOrchid3+ (make-named-color "MediumOrchid3" 0.7059 0.3216 0.8039)) (defconstant +MediumOrchid4+ (make-named-color "MediumOrchid4" 0.4784 0.2157 0.5451)) (defconstant +DarkOrchid1+ (make-named-color "DarkOrchid1" 0.7490 0.2431 1.0000)) (defconstant +DarkOrchid2+ (make-named-color "DarkOrchid2" 0.6980 0.2275 0.9333)) (defconstant +DarkOrchid3+ (make-named-color "DarkOrchid3" 0.6039 0.1961 0.8039)) (defconstant +DarkOrchid4+ (make-named-color "DarkOrchid4" 0.4078 0.1333 0.5451)) (defconstant +purple1+ (make-named-color "purple1" 0.6078 0.1882 1.0000)) (defconstant +purple2+ (make-named-color "purple2" 0.5686 0.1725 0.9333)) (defconstant +purple3+ (make-named-color "purple3" 0.4902 0.1490 0.8039)) (defconstant +purple4+ (make-named-color "purple4" 0.3333 0.1020 0.5451)) (defconstant +MediumPurple1+ (make-named-color "MediumPurple1" 0.6706 0.5098 1.0000)) (defconstant +MediumPurple2+ (make-named-color "MediumPurple2" 0.6235 0.4745 0.9333)) (defconstant +MediumPurple3+ (make-named-color "MediumPurple3" 0.5373 0.4078 0.8039)) (defconstant +MediumPurple4+ (make-named-color "MediumPurple4" 0.3647 0.2784 0.5451)) (defconstant +thistle1+ (make-named-color "thistle1" 1.0000 0.8824 1.0000)) (defconstant +thistle2+ (make-named-color "thistle2" 0.9333 0.8235 0.9333)) (defconstant +thistle3+ (make-named-color "thistle3" 0.8039 0.7098 0.8039)) (defconstant +thistle4+ (make-named-color "thistle4" 0.5451 0.4824 0.5451)) (defconstant +gray0+ (make-named-color "gray0" 0.0000 0.0000 0.0000)) (defconstant +grey0+ (make-named-color "grey0" 0.0000 0.0000 0.0000)) (defconstant +gray1+ (make-named-color "gray1" 0.0118 0.0118 0.0118)) (defconstant +grey1+ (make-named-color "grey1" 0.0118 0.0118 0.0118)) (defconstant +gray2+ (make-named-color "gray2" 0.0196 0.0196 0.0196)) (defconstant +grey2+ (make-named-color "grey2" 0.0196 0.0196 0.0196)) (defconstant +gray3+ (make-named-color "gray3" 0.0314 0.0314 0.0314)) (defconstant +grey3+ (make-named-color "grey3" 0.0314 0.0314 0.0314)) (defconstant +gray4+ (make-named-color "gray4" 0.0392 0.0392 0.0392)) (defconstant +grey4+ (make-named-color "grey4" 0.0392 0.0392 0.0392)) (defconstant +gray5+ (make-named-color "gray5" 0.0510 0.0510 0.0510)) (defconstant +grey5+ (make-named-color "grey5" 0.0510 0.0510 0.0510)) (defconstant +gray6+ (make-named-color "gray6" 0.0588 0.0588 0.0588)) (defconstant +grey6+ (make-named-color "grey6" 0.0588 0.0588 0.0588)) (defconstant +gray7+ (make-named-color "gray7" 0.0706 0.0706 0.0706)) (defconstant +grey7+ (make-named-color "grey7" 0.0706 0.0706 0.0706)) (defconstant +gray8+ (make-named-color "gray8" 0.0784 0.0784 0.0784)) (defconstant +grey8+ (make-named-color "grey8" 0.0784 0.0784 0.0784)) (defconstant +gray9+ (make-named-color "gray9" 0.0902 0.0902 0.0902)) (defconstant +grey9+ (make-named-color "grey9" 0.0902 0.0902 0.0902)) (defconstant +gray10+ (make-named-color "gray10" 0.1020 0.1020 0.1020)) (defconstant +grey10+ (make-named-color "grey10" 0.1020 0.1020 0.1020)) (defconstant +gray11+ (make-named-color "gray11" 0.1098 0.1098 0.1098)) (defconstant +grey11+ (make-named-color "grey11" 0.1098 0.1098 0.1098)) (defconstant +gray12+ (make-named-color "gray12" 0.1216 0.1216 0.1216)) (defconstant +grey12+ (make-named-color "grey12" 0.1216 0.1216 0.1216)) (defconstant +gray13+ (make-named-color "gray13" 0.1294 0.1294 0.1294)) (defconstant +grey13+ (make-named-color "grey13" 0.1294 0.1294 0.1294)) (defconstant +gray14+ (make-named-color "gray14" 0.1412 0.1412 0.1412)) (defconstant +grey14+ (make-named-color "grey14" 0.1412 0.1412 0.1412)) (defconstant +gray15+ (make-named-color "gray15" 0.1490 0.1490 0.1490)) (defconstant +grey15+ (make-named-color "grey15" 0.1490 0.1490 0.1490)) (defconstant +gray16+ (make-named-color "gray16" 0.1608 0.1608 0.1608)) (defconstant +grey16+ (make-named-color "grey16" 0.1608 0.1608 0.1608)) (defconstant +gray17+ (make-named-color "gray17" 0.1686 0.1686 0.1686)) (defconstant +grey17+ (make-named-color "grey17" 0.1686 0.1686 0.1686)) (defconstant +gray18+ (make-named-color "gray18" 0.1804 0.1804 0.1804)) (defconstant +grey18+ (make-named-color "grey18" 0.1804 0.1804 0.1804)) (defconstant +gray19+ (make-named-color "gray19" 0.1882 0.1882 0.1882)) (defconstant +grey19+ (make-named-color "grey19" 0.1882 0.1882 0.1882)) (defconstant +gray20+ (make-named-color "gray20" 0.2000 0.2000 0.2000)) (defconstant +grey20+ (make-named-color "grey20" 0.2000 0.2000 0.2000)) (defconstant +gray21+ (make-named-color "gray21" 0.2118 0.2118 0.2118)) (defconstant +grey21+ (make-named-color "grey21" 0.2118 0.2118 0.2118)) (defconstant +gray22+ (make-named-color "gray22" 0.2196 0.2196 0.2196)) (defconstant +grey22+ (make-named-color "grey22" 0.2196 0.2196 0.2196)) (defconstant +gray23+ (make-named-color "gray23" 0.2314 0.2314 0.2314)) (defconstant +grey23+ (make-named-color "grey23" 0.2314 0.2314 0.2314)) (defconstant +gray24+ (make-named-color "gray24" 0.2392 0.2392 0.2392)) (defconstant +grey24+ (make-named-color "grey24" 0.2392 0.2392 0.2392)) (defconstant +gray25+ (make-named-color "gray25" 0.2510 0.2510 0.2510)) (defconstant +grey25+ (make-named-color "grey25" 0.2510 0.2510 0.2510)) (defconstant +gray26+ (make-named-color "gray26" 0.2588 0.2588 0.2588)) (defconstant +grey26+ (make-named-color "grey26" 0.2588 0.2588 0.2588)) (defconstant +gray27+ (make-named-color "gray27" 0.2706 0.2706 0.2706)) (defconstant +grey27+ (make-named-color "grey27" 0.2706 0.2706 0.2706)) (defconstant +gray28+ (make-named-color "gray28" 0.2784 0.2784 0.2784)) (defconstant +grey28+ (make-named-color "grey28" 0.2784 0.2784 0.2784)) (defconstant +gray29+ (make-named-color "gray29" 0.2902 0.2902 0.2902)) (defconstant +grey29+ (make-named-color "grey29" 0.2902 0.2902 0.2902)) (defconstant +gray30+ (make-named-color "gray30" 0.3020 0.3020 0.3020)) (defconstant +grey30+ (make-named-color "grey30" 0.3020 0.3020 0.3020)) (defconstant +gray31+ (make-named-color "gray31" 0.3098 0.3098 0.3098)) (defconstant +grey31+ (make-named-color "grey31" 0.3098 0.3098 0.3098)) (defconstant +gray32+ (make-named-color "gray32" 0.3216 0.3216 0.3216)) (defconstant +grey32+ (make-named-color "grey32" 0.3216 0.3216 0.3216)) (defconstant +gray33+ (make-named-color "gray33" 0.3294 0.3294 0.3294)) (defconstant +grey33+ (make-named-color "grey33" 0.3294 0.3294 0.3294)) (defconstant +gray34+ (make-named-color "gray34" 0.3412 0.3412 0.3412)) (defconstant +grey34+ (make-named-color "grey34" 0.3412 0.3412 0.3412)) (defconstant +gray35+ (make-named-color "gray35" 0.3490 0.3490 0.3490)) (defconstant +grey35+ (make-named-color "grey35" 0.3490 0.3490 0.3490)) (defconstant +gray36+ (make-named-color "gray36" 0.3608 0.3608 0.3608)) (defconstant +grey36+ (make-named-color "grey36" 0.3608 0.3608 0.3608)) (defconstant +gray37+ (make-named-color "gray37" 0.3686 0.3686 0.3686)) (defconstant +grey37+ (make-named-color "grey37" 0.3686 0.3686 0.3686)) (defconstant +gray38+ (make-named-color "gray38" 0.3804 0.3804 0.3804)) (defconstant +grey38+ (make-named-color "grey38" 0.3804 0.3804 0.3804)) (defconstant +gray39+ (make-named-color "gray39" 0.3882 0.3882 0.3882)) (defconstant +grey39+ (make-named-color "grey39" 0.3882 0.3882 0.3882)) (defconstant +gray40+ (make-named-color "gray40" 0.4000 0.4000 0.4000)) (defconstant +grey40+ (make-named-color "grey40" 0.4000 0.4000 0.4000)) (defconstant +gray41+ (make-named-color "gray41" 0.4118 0.4118 0.4118)) (defconstant +grey41+ (make-named-color "grey41" 0.4118 0.4118 0.4118)) (defconstant +gray42+ (make-named-color "gray42" 0.4196 0.4196 0.4196)) (defconstant +grey42+ (make-named-color "grey42" 0.4196 0.4196 0.4196)) (defconstant +gray43+ (make-named-color "gray43" 0.4314 0.4314 0.4314)) (defconstant +grey43+ (make-named-color "grey43" 0.4314 0.4314 0.4314)) (defconstant +gray44+ (make-named-color "gray44" 0.4392 0.4392 0.4392)) (defconstant +grey44+ (make-named-color "grey44" 0.4392 0.4392 0.4392)) (defconstant +gray45+ (make-named-color "gray45" 0.4510 0.4510 0.4510)) (defconstant +grey45+ (make-named-color "grey45" 0.4510 0.4510 0.4510)) (defconstant +gray46+ (make-named-color "gray46" 0.4588 0.4588 0.4588)) (defconstant +grey46+ (make-named-color "grey46" 0.4588 0.4588 0.4588)) (defconstant +gray47+ (make-named-color "gray47" 0.4706 0.4706 0.4706)) (defconstant +grey47+ (make-named-color "grey47" 0.4706 0.4706 0.4706)) (defconstant +gray48+ (make-named-color "gray48" 0.4784 0.4784 0.4784)) (defconstant +grey48+ (make-named-color "grey48" 0.4784 0.4784 0.4784)) (defconstant +gray49+ (make-named-color "gray49" 0.4902 0.4902 0.4902)) (defconstant +grey49+ (make-named-color "grey49" 0.4902 0.4902 0.4902)) (defconstant +gray50+ (make-named-color "gray50" 0.4980 0.4980 0.4980)) (defconstant +grey50+ (make-named-color "grey50" 0.4980 0.4980 0.4980)) (defconstant +gray51+ (make-named-color "gray51" 0.5098 0.5098 0.5098)) (defconstant +grey51+ (make-named-color "grey51" 0.5098 0.5098 0.5098)) (defconstant +gray52+ (make-named-color "gray52" 0.5216 0.5216 0.5216)) (defconstant +grey52+ (make-named-color "grey52" 0.5216 0.5216 0.5216)) (defconstant +gray53+ (make-named-color "gray53" 0.5294 0.5294 0.5294)) (defconstant +grey53+ (make-named-color "grey53" 0.5294 0.5294 0.5294)) (defconstant +gray54+ (make-named-color "gray54" 0.5412 0.5412 0.5412)) (defconstant +grey54+ (make-named-color "grey54" 0.5412 0.5412 0.5412)) (defconstant +gray55+ (make-named-color "gray55" 0.5490 0.5490 0.5490)) (defconstant +grey55+ (make-named-color "grey55" 0.5490 0.5490 0.5490)) (defconstant +gray56+ (make-named-color "gray56" 0.5608 0.5608 0.5608)) (defconstant +grey56+ (make-named-color "grey56" 0.5608 0.5608 0.5608)) (defconstant +gray57+ (make-named-color "gray57" 0.5686 0.5686 0.5686)) (defconstant +grey57+ (make-named-color "grey57" 0.5686 0.5686 0.5686)) (defconstant +gray58+ (make-named-color "gray58" 0.5804 0.5804 0.5804)) (defconstant +grey58+ (make-named-color "grey58" 0.5804 0.5804 0.5804)) (defconstant +gray59+ (make-named-color "gray59" 0.5882 0.5882 0.5882)) (defconstant +grey59+ (make-named-color "grey59" 0.5882 0.5882 0.5882)) (defconstant +gray60+ (make-named-color "gray60" 0.6000 0.6000 0.6000)) (defconstant +grey60+ (make-named-color "grey60" 0.6000 0.6000 0.6000)) (defconstant +gray61+ (make-named-color "gray61" 0.6118 0.6118 0.6118)) (defconstant +grey61+ (make-named-color "grey61" 0.6118 0.6118 0.6118)) (defconstant +gray62+ (make-named-color "gray62" 0.6196 0.6196 0.6196)) (defconstant +grey62+ (make-named-color "grey62" 0.6196 0.6196 0.6196)) (defconstant +gray63+ (make-named-color "gray63" 0.6314 0.6314 0.6314)) (defconstant +grey63+ (make-named-color "grey63" 0.6314 0.6314 0.6314)) (defconstant +gray64+ (make-named-color "gray64" 0.6392 0.6392 0.6392)) (defconstant +grey64+ (make-named-color "grey64" 0.6392 0.6392 0.6392)) (defconstant +gray65+ (make-named-color "gray65" 0.6510 0.6510 0.6510)) (defconstant +grey65+ (make-named-color "grey65" 0.6510 0.6510 0.6510)) (defconstant +gray66+ (make-named-color "gray66" 0.6588 0.6588 0.6588)) (defconstant +grey66+ (make-named-color "grey66" 0.6588 0.6588 0.6588)) (defconstant +gray67+ (make-named-color "gray67" 0.6706 0.6706 0.6706)) (defconstant +grey67+ (make-named-color "grey67" 0.6706 0.6706 0.6706)) (defconstant +gray68+ (make-named-color "gray68" 0.6784 0.6784 0.6784)) (defconstant +grey68+ (make-named-color "grey68" 0.6784 0.6784 0.6784)) (defconstant +gray69+ (make-named-color "gray69" 0.6902 0.6902 0.6902)) (defconstant +grey69+ (make-named-color "grey69" 0.6902 0.6902 0.6902)) (defconstant +gray70+ (make-named-color "gray70" 0.7020 0.7020 0.7020)) (defconstant +grey70+ (make-named-color "grey70" 0.7020 0.7020 0.7020)) (defconstant +gray71+ (make-named-color "gray71" 0.7098 0.7098 0.7098)) (defconstant +grey71+ (make-named-color "grey71" 0.7098 0.7098 0.7098)) (defconstant +gray72+ (make-named-color "gray72" 0.7216 0.7216 0.7216)) (defconstant +grey72+ (make-named-color "grey72" 0.7216 0.7216 0.7216)) (defconstant +gray73+ (make-named-color "gray73" 0.7294 0.7294 0.7294)) (defconstant +grey73+ (make-named-color "grey73" 0.7294 0.7294 0.7294)) (defconstant +gray74+ (make-named-color "gray74" 0.7412 0.7412 0.7412)) (defconstant +grey74+ (make-named-color "grey74" 0.7412 0.7412 0.7412)) (defconstant +gray75+ (make-named-color "gray75" 0.7490 0.7490 0.7490)) (defconstant +grey75+ (make-named-color "grey75" 0.7490 0.7490 0.7490)) (defconstant +gray76+ (make-named-color "gray76" 0.7608 0.7608 0.7608)) (defconstant +grey76+ (make-named-color "grey76" 0.7608 0.7608 0.7608)) (defconstant +gray77+ (make-named-color "gray77" 0.7686 0.7686 0.7686)) (defconstant +grey77+ (make-named-color "grey77" 0.7686 0.7686 0.7686)) (defconstant +gray78+ (make-named-color "gray78" 0.7804 0.7804 0.7804)) (defconstant +grey78+ (make-named-color "grey78" 0.7804 0.7804 0.7804)) (defconstant +gray79+ (make-named-color "gray79" 0.7882 0.7882 0.7882)) (defconstant +grey79+ (make-named-color "grey79" 0.7882 0.7882 0.7882)) (defconstant +gray80+ (make-named-color "gray80" 0.8000 0.8000 0.8000)) (defconstant +grey80+ (make-named-color "grey80" 0.8000 0.8000 0.8000)) (defconstant +gray81+ (make-named-color "gray81" 0.8118 0.8118 0.8118)) (defconstant +grey81+ (make-named-color "grey81" 0.8118 0.8118 0.8118)) (defconstant +gray82+ (make-named-color "gray82" 0.8196 0.8196 0.8196)) (defconstant +grey82+ (make-named-color "grey82" 0.8196 0.8196 0.8196)) (defconstant +gray83+ (make-named-color "gray83" 0.8314 0.8314 0.8314)) (defconstant +grey83+ (make-named-color "grey83" 0.8314 0.8314 0.8314)) (defconstant +gray84+ (make-named-color "gray84" 0.8392 0.8392 0.8392)) (defconstant +grey84+ (make-named-color "grey84" 0.8392 0.8392 0.8392)) (defconstant +gray85+ (make-named-color "gray85" 0.8510 0.8510 0.8510)) (defconstant +grey85+ (make-named-color "grey85" 0.8510 0.8510 0.8510)) (defconstant +gray86+ (make-named-color "gray86" 0.8588 0.8588 0.8588)) (defconstant +grey86+ (make-named-color "grey86" 0.8588 0.8588 0.8588)) (defconstant +gray87+ (make-named-color "gray87" 0.8706 0.8706 0.8706)) (defconstant +grey87+ (make-named-color "grey87" 0.8706 0.8706 0.8706)) (defconstant +gray88+ (make-named-color "gray88" 0.8784 0.8784 0.8784)) (defconstant +grey88+ (make-named-color "grey88" 0.8784 0.8784 0.8784)) (defconstant +gray89+ (make-named-color "gray89" 0.8902 0.8902 0.8902)) (defconstant +grey89+ (make-named-color "grey89" 0.8902 0.8902 0.8902)) (defconstant +gray90+ (make-named-color "gray90" 0.8980 0.8980 0.8980)) (defconstant +grey90+ (make-named-color "grey90" 0.8980 0.8980 0.8980)) (defconstant +gray91+ (make-named-color "gray91" 0.9098 0.9098 0.9098)) (defconstant +grey91+ (make-named-color "grey91" 0.9098 0.9098 0.9098)) (defconstant +gray92+ (make-named-color "gray92" 0.9216 0.9216 0.9216)) (defconstant +grey92+ (make-named-color "grey92" 0.9216 0.9216 0.9216)) (defconstant +gray93+ (make-named-color "gray93" 0.9294 0.9294 0.9294)) (defconstant +grey93+ (make-named-color "grey93" 0.9294 0.9294 0.9294)) (defconstant +gray94+ (make-named-color "gray94" 0.9412 0.9412 0.9412)) (defconstant +grey94+ (make-named-color "grey94" 0.9412 0.9412 0.9412)) (defconstant +gray95+ (make-named-color "gray95" 0.9490 0.9490 0.9490)) (defconstant +grey95+ (make-named-color "grey95" 0.9490 0.9490 0.9490)) (defconstant +gray96+ (make-named-color "gray96" 0.9608 0.9608 0.9608)) (defconstant +grey96+ (make-named-color "grey96" 0.9608 0.9608 0.9608)) (defconstant +gray97+ (make-named-color "gray97" 0.9686 0.9686 0.9686)) (defconstant +grey97+ (make-named-color "grey97" 0.9686 0.9686 0.9686)) (defconstant +gray98+ (make-named-color "gray98" 0.9804 0.9804 0.9804)) (defconstant +grey98+ (make-named-color "grey98" 0.9804 0.9804 0.9804)) (defconstant +gray99+ (make-named-color "gray99" 0.9882 0.9882 0.9882)) (defconstant +grey99+ (make-named-color "grey99" 0.9882 0.9882 0.9882)) (defconstant +gray100+ (make-named-color "gray100" 1.0000 1.0000 1.0000)) (defconstant +grey100+ (make-named-color "grey100" 1.0000 1.0000 1.0000)) (defconstant +dark-grey+ (make-named-color "dark-grey" 0.6627 0.6627 0.6627)) (defconstant +DarkGrey+ (make-named-color "DarkGrey" 0.6627 0.6627 0.6627)) (defconstant +dark-gray+ (make-named-color "dark-gray" 0.6627 0.6627 0.6627)) (defconstant +DarkGray+ (make-named-color "DarkGray" 0.6627 0.6627 0.6627)) (defconstant +dark-blue+ (make-named-color "dark-blue" 0.0000 0.0000 0.5451)) (defconstant +DarkBlue+ (make-named-color "DarkBlue" 0.0000 0.0000 0.5451)) (defconstant +dark-cyan+ (make-named-color "dark-cyan" 0.0000 0.5451 0.5451)) (defconstant +DarkCyan+ (make-named-color "DarkCyan" 0.0000 0.5451 0.5451)) (defconstant +dark-magenta+ (make-named-color "dark-magenta" 0.5451 0.0000 0.5451)) (defconstant +DarkMagenta+ (make-named-color "DarkMagenta" 0.5451 0.0000 0.5451)) (defconstant +dark-red+ (make-named-color "dark-red" 0.5451 0.0000 0.0000)) (defconstant +DarkRed+ (make-named-color "DarkRed" 0.5451 0.0000 0.0000)) (defconstant +light-green+ (make-named-color "light-green" 0.5647 0.9333 0.5647)) (defconstant +LightGreen+ (make-named-color "LightGreen" 0.5647 0.9333 0.5647)) (defconstant +contrasting-colors+ (vector +black+ +red+ +green+ +blue+ +cyan+ +magenta+ +yellow+ +white+)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/stream-input.lisp0000644000175000017500000006723611345155772020350 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com) ;;; (c) copyright 2000 by ;;; Robert Strandh (strandh@labri.u-bordeaux.fr) ;;; (c) copyright 2001,2002 by Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) ;;; X returns #\Return and #\Backspace where we want to see #\Newline ;;; and #\Delete at the stream-read-char level. Dunno if this is the ;;; right place to do the transformation... ;; Why exactly do we want to see #\Delete instead of #\Backspace? ;; There is a separate Delete key, unless your keyboard is strange. --Hefner (defconstant +read-char-map+ '((#\Return . #\Newline) #+nil (#\Backspace . #\Delete))) (defvar *abort-gestures* '(:abort)) (defvar *accelerator-gestures* nil) (define-condition abort-gesture (condition) ((event :reader %abort-gesture-event :initarg :event))) (defmethod abort-gesture-event ((condition abort-gesture)) (%abort-gesture-event condition)) (define-condition accelerator-gesture (condition) ((event :reader %accelerator-gesture-event :initarg :event) (numeric-argument :reader %accelerator-gesture-numeric-argument :initarg :numeric-argument :initform 1))) (defmethod accelerator-gesture-event ((condition accelerator-gesture)) (%accelerator-gesture-event condition)) (defmethod accelerator-gesture-numeric-argument ((condition accelerator-gesture)) (%accelerator-gesture-numeric-argument condition)) (defun char-for-read (char) (let ((new-char (cdr (assoc char +read-char-map+)))) (or new-char char))) (defun unmap-char-for-read (char) (let ((new-char (car (rassoc char +read-char-map+)))) (or new-char char))) ;;; Streams are subclasses of standard-sheet-input-mixin regardless of ;;; whether or not we are multiprocessing. In single-process mode the ;;; blocking calls to stream-read-char, stream-read-gesture are what ;;; cause process-next-event to be called. It's most convenient to ;;; let process-next-event queue up events for the stream and then see ;;; what we've got after it returns. (defclass standard-input-stream (fundamental-character-input-stream standard-sheet-input-mixin) ((unread-chars :initform nil :accessor stream-unread-chars))) (defmethod stream-read-char ((pane standard-input-stream)) (if (stream-unread-chars pane) (pop (stream-unread-chars pane)) ;XXX (flet ((do-one-event (event) (if (and (typep event 'key-press-event) (keyboard-event-character event)) (let ((char (char-for-read (keyboard-event-character event)))) (stream-write-char pane char) (return-from stream-read-char char)) (handle-event (event-sheet event) event)))) (let* ((port (port pane)) (queue (stream-input-buffer pane))) (declare (ignorable port)) (loop (let ((event (event-queue-read-no-hang queue))) (cond (event (do-one-event event)) (*multiprocessing-p* (event-queue-listen-or-wait queue)) (t (process-next-event port))))))))) (defmethod stream-unread-char ((pane standard-input-stream) char) (push char (stream-unread-chars pane))) (defmethod stream-read-char-no-hang ((pane standard-input-stream)) (if (stream-unread-chars pane) (pop (stream-unread-chars pane)) (loop for event = (event-read-no-hang pane) if (null event) return nil if (and (typep event 'key-press-event) (keyboard-event-character event)) return (char-for-read (keyboard-event-character event)) else do (handle-event (event-sheet event) event)))) (defmethod stream-clear-input ((pane standard-input-stream)) (setf (stream-unread-chars pane) nil) (loop for event = (event-read-no-hang pane) if (null event) return nil else do (handle-event (event-sheet event) event)) nil) (defclass dead-key-merging-mixin () ((state :initform *dead-key-table*) (last-deadie-gesture) ; For avoiding name clash with standard-extended-input-stream (last-state)) (:documentation "A mixin class for extended input streams that takes care of handling dead keys. This is done by still passing every gesture on, but accenting the final one as per the dead keys read.")) (defmethod stream-read-gesture :around ((stream dead-key-merging-mixin) &key timeout peek-p (input-wait-test *input-wait-test*) (input-wait-handler *input-wait-handler*) (pointer-button-press-handler *pointer-button-press-handler*)) (with-slots (state last-deadie-gesture last-state) stream (handler-case (loop with start-time = (get-internal-real-time) with end-time = start-time do (multiple-value-bind (gesture reason) (call-next-method stream :timeout (when timeout (- timeout (/ (- end-time start-time) internal-time-units-per-second))) :peek-p peek-p :input-wait-test input-wait-test :input-wait-handler input-wait-handler :pointer-button-press-handler pointer-button-press-handler) (when (null gesture) (return (values nil reason))) (setf end-time (get-internal-real-time) last-deadie-gesture gesture last-state state) (merging-dead-keys (gesture state) (return gesture)))) ;; Policy decision: an abort cancels the current composition. (abort-gesture (c) (setf state *dead-key-table*) (signal c))))) (defmethod stream-unread-gesture :around ((stream dead-key-merging-mixin) gesture) (if (typep gesture '(or keyboard-event character)) (with-slots (state last-deadie-gesture last-state) stream (setf state last-state) (call-next-method stream last-deadie-gesture)) (call-next-method))) (defclass standard-extended-input-stream (extended-input-stream ;; FIXME: is this still needed? standard-sheet-input-mixin dead-key-merging-mixin) ((pointer) (cursor :initarg :text-cursor) (last-gesture :accessor last-gesture :initform nil :documentation "Holds the last gesture returned by stream-read-gesture (not peek-p), untransformed, so it can easily be unread."))) (defvar *input-wait-test* nil) (defvar *input-wait-handler* nil) (defvar *pointer-button-press-handler* nil) (defmacro with-input-focus ((stream) &body body) (when (eq stream t) (setq stream '*standard-input*)) (let ((old-stream (gensym "OLD-STREAM"))) `(let ((,old-stream (stream-set-input-focus ,stream))) (unwind-protect (locally ,@body) (when ,old-stream (stream-set-input-focus ,old-stream)))))) (defun read-gesture (&key (stream *standard-input*) timeout peek-p (input-wait-test *input-wait-test*) (input-wait-handler *input-wait-handler*) (pointer-button-press-handler *pointer-button-press-handler*)) (stream-read-gesture stream :timeout timeout :peek-p peek-p :input-wait-test input-wait-test :input-wait-handler input-wait-handler :pointer-button-press-handler pointer-button-press-handler)) ;;; Do streams care about any other events? (defun handle-non-stream-event (buffer) (let* ((event (event-queue-peek buffer)) (sheet (and event (event-sheet event)))) (if (and event (or (and (gadgetp sheet) (gadget-active-p sheet)) (not (and (typep sheet 'clim-stream-pane) (or (typep event 'key-press-event) (typep event 'pointer-button-press-event)))))) (progn (event-queue-read buffer) ;eat it (handle-event (event-sheet event) event) t) nil))) (defun pop-gesture (buffer peek-p) (if peek-p (event-queue-peek buffer) (event-queue-read-no-hang buffer))) (defun repush-gesture (gesture buffer) (event-queue-prepend buffer gesture)) (defmethod convert-to-gesture ((ev event)) nil) (defmethod convert-to-gesture ((ev character)) ev) (defmethod convert-to-gesture ((ev symbol)) ev) (defmethod convert-to-gesture ((ev key-press-event)) (let ((modifiers (event-modifier-state ev)) (event ev) (char nil)) (when (or (zerop modifiers) (eql modifiers +shift-key+)) (setq char (keyboard-event-character ev))) (if char (char-for-read char) event))) (defmethod convert-to-gesture ((ev pointer-button-press-event)) ev) (defmethod stream-read-gesture ((stream standard-extended-input-stream) &key timeout peek-p (input-wait-test *input-wait-test*) (input-wait-handler *input-wait-handler*) (pointer-button-press-handler *pointer-button-press-handler*)) (with-encapsulating-stream (estream stream) (let ((*input-wait-test* input-wait-test) (*input-wait-handler* input-wait-handler) (*pointer-button-press-handler* pointer-button-press-handler) (buffer (stream-input-buffer stream))) (tagbody ;; Wait for input... or not ;; XXX decay timeout. wait-for-char (multiple-value-bind (available reason) (stream-input-wait estream :timeout timeout :input-wait-test input-wait-test) (unless available (case reason (:timeout (return-from stream-read-gesture (values nil :timeout))) (:input-wait-test ;; input-wait-handler might leave the event for us. This is ;; actually quite messy; I'd like to confine handle-event to ;; stream-input-wait, but we can't loop back to it because the ;; input handler will continue to decline to read the event :( (let ((event (event-queue-peek buffer))) (when input-wait-handler (funcall input-wait-handler stream)) (let ((current-event (event-queue-peek buffer))) (when (or (not current-event) (not (eq event current-event))) ;; If there's a new event input-wait-test needs to take a ;; look at it. (go wait-for-char))))) (t (go wait-for-char))))) ;; An event should be in the stream buffer now. (when (handle-non-stream-event buffer) (go wait-for-char)) (let* ((raw-gesture (pop-gesture buffer peek-p)) (gesture (convert-to-gesture raw-gesture))) ;; Sometimes key press events get generated with a key code for ;; which there is no keysym. This seems to happen on my machine ;; when keys are hit rapidly in succession. I'm not sure if this is ;; a hardware problem with my keyboard, and this case is probably ;; better handled in the backend, but for now the case below handles ;; the problem. -- moore (cond ((null gesture) (go wait-for-char)) ((and pointer-button-press-handler (typep gesture 'pointer-button-press-event)) (funcall pointer-button-press-handler stream gesture)) ((loop for gesture-name in *abort-gestures* thereis (event-matches-gesture-name-p gesture gesture-name)) (signal 'abort-gesture :event gesture)) ((loop for gesture-name in *accelerator-gestures* thereis (event-matches-gesture-name-p gesture gesture-name)) (signal 'accelerator-gesture :event gesture)) (t (setf (last-gesture stream) raw-gesture) (return-from stream-read-gesture gesture)))) (go wait-for-char))))) (defmethod stream-input-wait ((stream standard-extended-input-stream) &key timeout input-wait-test) (block exit (let* ((buffer (stream-input-buffer stream)) (port (port stream))) (declare (ignorable port)) ;; Loop if not multiprocessing or if input-wait-test returns nil ;; XXX need to decay timeout on multiple trips through the loop (tagbody check-buffer (let ((event (event-queue-peek buffer))) (when event (when (and input-wait-test (funcall input-wait-test stream)) (return-from exit (values nil :input-wait-test))) (if (handle-non-stream-event buffer) (go check-buffer) (return-from exit t)))) ;; Event queue has been drained, time to block waiting for new events. (if *multiprocessing-p* (unless (event-queue-listen-or-wait buffer :timeout timeout) (return-from exit (values nil :timeout))) (multiple-value-bind (result reason) (process-next-event port :timeout timeout) (unless result (return-from exit (values nil reason))))) (go check-buffer))))) (defun unread-gesture (gesture &key (stream *standard-input*)) (stream-unread-gesture stream gesture)) (defmethod stream-unread-gesture ((stream standard-extended-input-stream) gesture) (declare (ignore gesture)) (with-encapsulating-stream (estream stream) (let ((gesture (last-gesture stream))) (when gesture (setf (last-gesture stream) nil) (repush-gesture gesture (stream-input-buffer estream)))))) ;;; Standard stream methods on standard-extended-input-stream. Ignore any ;;; pointer gestures in the input buffer. ;;; ;;; Is stream-read-gesture allowed to return :eof? (defmethod stream-read-char ((stream standard-extended-input-stream)) (with-encapsulating-stream (estream stream) (loop with char and reason do (setf (values char reason) (stream-read-gesture estream)) until (or (characterp char) (eq reason :eof)) finally (return (if (eq reason :eof) reason (char-for-read char)))))) (defmethod stream-read-char-no-hang ((stream standard-extended-input-stream)) (with-encapsulating-stream (estream stream) (loop with char and reason do (setf (values char reason) (stream-read-gesture estream :timeout 0)) until (or (characterp char) (eq reason :timeout) (eq reason :eof) ) finally (return (cond ((eq reason :timeout) nil) ((eq reason :eof) :eof) (t (char-for-read char))))))) (defmethod stream-unread-char ((stream standard-extended-input-stream) char) (with-encapsulating-stream (estream stream) (stream-unread-gesture estream (unmap-char-for-read char)))) (defmethod stream-peek-char ((stream standard-extended-input-stream)) (with-encapsulating-stream (estream stream) (loop with char and reason do (setf (values char reason) (stream-read-gesture estream :peek-p t)) until (or (characterp char) (eq reason :eof)) do (stream-read-gesture estream) ; consume pointer gesture finally (return (if (eq reason :eof) reason (char-for-read char)))))) (defmethod stream-listen ((stream standard-extended-input-stream)) (with-encapsulating-stream (estream stream) (loop with char and reason do (setf (values char reason) (stream-read-gesture estream :timeout 0 :peek-p t)) until (or (characterp char) (eq reason :eof) (eq reason :timeout)) do (stream-read-gesture estream) ; consume pointer gesture finally (return (characterp char))))) (defmethod stream-clear-input ((stream standard-extended-input-stream)) (with-encapsulating-stream (estream stream) (loop with char and reason do (setf (values char reason) (stream-read-gesture estream :timeout 0 :peek-p t)) until (or (eq reason :eof) (eq reason :timeout)) do (stream-read-gesture estream) ; consume pointer gesture )) nil) ;;; stream-read-line returns a second value of t if terminated by eof. (defmethod stream-read-line ((stream standard-extended-input-stream)) (with-encapsulating-stream (estream stream) (let ((result (make-array 1 :element-type 'character :adjustable t :fill-pointer 0))) (loop for char = (stream-read-char estream) while (and (characterp char) (not (char= char #\Newline))) do (vector-push-extend char result) finally (return (values (subseq result 0) (not (characterp char)))))))) ;;; stream-read-gesture on string strings. Needed so ;;; accept-from-string "just works" ;;; XXX Evil hack because "string-stream" isn't the superclass of ;;; string streams in CMUCL/SBCL... (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *string-input-stream-class* (with-input-from-string (s "foo") (class-name (class-of s))))) (defmethod stream-read-gesture ((stream #.*string-input-stream-class*) &key peek-p &allow-other-keys) (let ((char (if peek-p (peek-char nil stream nil nil) (read-char stream nil nil)))) (if char char (values nil :eof)))) (defmethod stream-unread-gesture ((stream #.*string-input-stream-class*) gesture) (unread-char gesture stream)) ;;; Gestures (defparameter *gesture-names* (make-hash-table)) (defmacro define-gesture-name (name type gesture-spec &key (unique t)) `(add-gesture-name ',name ',type ',gesture-spec ,@(and unique `(:unique ',unique)))) (defun delete-gesture-name (name) "Delete the gesture named by the symbol `name' from the list of known gestures." (remhash name *gesture-names*)) ;;; XXX perhaps this should be in the backend somewhere? (defconstant +name-to-char+ '((:newline . #\newline) (:linefeed . #\linefeed) (:return . #\return) (:tab . #\tab) (:backspace . #\backspace) (:page . #\page) (:rubout . #\rubout))) (defun realize-gesture-spec (type gesture-spec) ;; Some CLIM code (scigraph) assumes that gesture-spec can be a symbol. (unless (listp gesture-spec) (setq gesture-spec (list gesture-spec))) (destructuring-bind (device-name . modifiers) gesture-spec (let* ((modifier-state (apply #'make-modifier-state modifiers))) (cond ((and (eq type :keyboard) (symbolp device-name)) (setq device-name (or (cdr (assoc device-name +name-to-char+)) device-name))) ((and (member type '(:pointer-button :pointer-button-press :pointer-button-release) :test #'eq)) (let ((real-device-name (case device-name (:left +pointer-left-button+) (:middle +pointer-middle-button+) (:right +pointer-right-button+) (:wheel-up +pointer-wheel-up+) (:wheel-down +pointer-wheel-down+) (t (error "~S is not a known button" device-name))))) (setq device-name real-device-name)))) (values type device-name modifier-state)))) (defun add-gesture-name (name type gesture-spec &key unique) (let ((gesture-entry (multiple-value-list (realize-gesture-spec type gesture-spec)))) (if unique (setf (gethash name *gesture-names*) (list gesture-entry)) (push gesture-entry (gethash name *gesture-names*))))) (defgeneric character-gesture-name (name)) (defmethod character-gesture-name ((name character)) name) (defmethod character-gesture-name ((name symbol)) (let ((entry (car (gethash name *gesture-names*)))) (if entry (destructuring-bind (type device-name modifier-state) entry (if (and (eq type :keyboard) (eql modifier-state 0)) device-name nil)) nil))) (defgeneric %event-matches-gesture (event type device-name modifier-state)) (defmethod %event-matches-gesture (event type device-name modifier-state) (declare (ignore event type device-name modifier-state)) nil) (defmethod %event-matches-gesture ((event key-press-event) (type (eql :keyboard)) device-name modifier-state) (let ((character (keyboard-event-character event)) (name (keyboard-event-key-name event))) (and (if character (eql character device-name) (eql name device-name)) (eql (event-modifier-state event) modifier-state)))) (defmethod %event-matches-gesture ((event pointer-button-press-event) type device-name modifier-state) (and (or (eql type :pointer-button-press) (eql type :pointer-button)) (eql (pointer-event-button event) device-name) (eql (event-modifier-state event) modifier-state))) (defmethod %event-matches-gesture ((event pointer-button-release-event) type device-name modifier-state) (and (or (eql type :pointer-button-release) (eql type :pointer-button)) (eql (pointer-event-button event) device-name) (eql (event-modifier-state event) modifier-state))) (defmethod %event-matches-gesture ((event pointer-button-event) type device-name modifier-state) (and (or (eql type :pointer-button-press) (eql type :pointer-button-release) (eql type :pointer-button)) (eql (pointer-event-button event) device-name) (eql (event-modifier-state event) modifier-state))) ;;; Because gesture objects are either characters or event objects, support ;;; characters here too. (defmethod %event-matches-gesture ((event character) (type (eql :keyboard)) device-name modifier-state) (and (eql event device-name) (eql modifier-state 0))) (defun event-matches-gesture-name-p (event gesture-name) ;; Just to be nice, we special-case literal characters here. ;; We also special-case literal 'physical' gesture specs of ;; the form (type device-name modifier-state). ;; The CLIM spec requires neither of these things. (let ((gesture-entry (typecase gesture-name (character (list (multiple-value-list (realize-gesture-spec :keyboard gesture-name)))) (cons (list gesture-name)) ;; Literal physical gesture (t (gethash gesture-name *gesture-names*))))) (loop for (type device-name modifier-state) in gesture-entry do (when (%event-matches-gesture event type device-name modifier-state) (return-from event-matches-gesture-name-p t)) finally (return nil)))) (defun modifier-state-matches-gesture-name-p (modifier-state gesture-name) (loop for (nil nil gesture-state) in (gethash gesture-name *gesture-names*) do (when (eql gesture-state modifier-state) (return-from modifier-state-matches-gesture-name-p t)) finally (return nil))) (defun make-modifier-state (&rest modifiers) (loop for result = 0 then (logior (case modifier (:shift +shift-key+) (:control +control-key+) (:meta +meta-key+) (:super +super-key+) (:hyper +hyper-key+) (t (error "~S is not a known modifier" modifier))) result) for modifier in modifiers finally (return result))) ;;; Standard gesture names (define-gesture-name :abort :keyboard (#\c :control)) (define-gesture-name :clear-input :keyboard (#\u :control)) (define-gesture-name :complete :keyboard (:tab)) (define-gesture-name :help :keyboard (#\/ :control)) (define-gesture-name :possibilities :keyboard (#\? :control)) (define-gesture-name :select :pointer-button-press (:left)) (define-gesture-name :describe :pointer-button-press (:middle)) (define-gesture-name :menu :pointer-button-press (:right)) (define-gesture-name :edit :pointer-button-press (:left :meta)) (define-gesture-name :delete :pointer-button-press (:middle :shift)) ;;; Define so we have a gesture for #\newline that we can use in ;;; *standard-activation-gestures* (define-gesture-name :newline :keyboard (#\newline)) (define-gesture-name :return :keyboard (#\return)) ;;; The standard delimiter (define-gesture-name command-delimiter :keyboard (#\space)) ;;; Extension: support for handling abort gestures that appears to be ;;; in real CLIM ;;; From the hyperspec, more or less (defun invoke-condition-restart (c) (let ((restarts (compute-restarts c))) (loop for i from 0 for restart in restarts do (format t "~&~D: ~A~%" i restart)) (loop with n = nil and k = (length restarts) until (and (integerp n) (>= n 0) (< n k)) do (progn (format t "~&Option: ") (setq n (read)) (fresh-line)) finally #-cmu (invoke-restart (nth n restarts)) #+cmu (funcall (conditions::restart-function (nth n restarts)))))) (defmacro catch-abort-gestures (format-args &body body) `(restart-case (handler-bind ((abort-gesture #'invoke-condition-restart)) ,@body) (nil () :report (lambda (s) (format s ,@format-args)) :test (lambda (c) (typep c 'abort-gesture)) nil))) ;;; 22.4 The Pointer Protocol ;;; ;;; Implemented by the back end. Sort of. ;;; FIXME: I think the standard-pointer should absorb some of the ;;; common methods that are currently entirely provided by the ;;; backends. (defclass standard-pointer (pointer) ((port :reader port :initarg :port) (state-lock :reader state-lock :initform (make-lock "pointer lock")) (button-state :initform 0 ) (modifier-state :initform 0))) (defgeneric pointer-sheet (pointer)) (defmethod pointer-sheet ((pointer pointer)) (port-pointer-sheet (port pointer))) (defgeneric (setf pointer-sheet) (sheet pointer)) (defgeneric pointer-button-state (pointer)) (defgeneric pointer-modifier-state (pointer)) (defgeneric pointer-position (pointer)) (defgeneric* (setf pointer-position) (x y pointer)) (defgeneric synthesize-pointer-motion-event (pointer) (:documentation "Create a CLIM pointer motion event based on the current pointer state.")) (defgeneric pointer-cursor (pointer)) (defgeneric (setf pointer-cursor) (cursor pointer)) ;;; Should this go in sheets.lisp? That comes before events and ports... (defmethod handle-event :before ((sheet mirrored-sheet-mixin) (event pointer-enter-event)) (setf (port-pointer-sheet (port sheet)) sheet)) (defmethod handle-event :before ((sheet mirrored-sheet-mixin) (event pointer-exit-event)) (with-accessors ((port-pointer-sheet port-pointer-sheet)) (port sheet) (when (eq port-pointer-sheet sheet) (setq port-pointer-sheet nil)))) (defmethod pointer-button-state ((pointer standard-pointer)) (with-lock-held ((state-lock pointer)) (slot-value pointer 'button-state))) (defmethod pointer-modifier-state ((pointer standard-pointer)) (with-lock-held ((state-lock pointer)) (slot-value pointer 'modifier-state))) (defmethod pointer-update-state ((pointer standard-pointer) (event keyboard-event)) (with-lock-held ((state-lock pointer)) (setf (slot-value pointer 'modifier-state) (event-modifier-state event)))) (defmethod pointer-update-state ((pointer standard-pointer) (event pointer-button-press-event)) (with-lock-held ((state-lock pointer)) (setf (slot-value pointer 'button-state) (logior (slot-value pointer 'button-state) (pointer-event-button event))))) (defmethod pointer-update-state ((pointer standard-pointer) (event pointer-button-release-event)) (with-lock-held ((state-lock pointer)) (setf (slot-value pointer 'button-state) (logandc2 (slot-value pointer 'button-state) (pointer-event-button event))))) (defmethod stream-pointer-position ((stream standard-extended-input-stream) &key (pointer (port-pointer (port stream)))) (multiple-value-bind (x y) (pointer-position pointer) (let ((pointer-sheet (port-pointer-sheet (port stream)))) (if (eq stream pointer-sheet) (values x y) ;; Is this right? (multiple-value-bind (native-x native-y) (transform-position (sheet-native-transformation stream) x y) (untransform-position (sheet-native-transformation pointer-sheet) native-x native-y)))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/blank.lisp0000644000175000017500000000162307636702772017001 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/ESA/0000750000175000017500000000000011347763706015420 5ustar pdmpdmcl-mcclim-0.9.6.dfsg.cvs20100315.orig/ESA/esa-io.lisp0000644000175000017500000003350711345155772017477 0ustar pdmpdm;;; -*- Mode: Lisp; Package: ESA-IO -*- ;;; (c) copyright 2006 by ;;; Robert Strandh (strandh@labri.fr) ;;; (c) copyright 2007-2008 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :esa-io) (defgeneric frame-find-file (application-frame file-path) (:documentation "If a buffer with the file-path already exists, return it, else if a file with the right name exists, return a fresh buffer created from the file, else return a new empty buffer having the associated file name.")) (defgeneric frame-find-file-read-only (application-frame file-path)) (defgeneric frame-set-visited-file-name (application-frame filepath buffer)) (defgeneric check-buffer-writability (application-frame filepath buffer) (:documentation "Check that `buffer' can be written to `filepath', which can be an arbitrary pathname. If there is a problem, an error that is a subclass of `buffer-writing-error'should be signalled.")) (defgeneric frame-save-buffer (application-frame buffer)) (defgeneric frame-write-buffer (application-frame filepath buffer)) (define-condition buffer-writing-error (error) ((%buffer :reader buffer :initarg :buffer :initform (error "A buffer must be provided") :documentation "The buffer that was attempted written when this error occured.") (%filepath :reader filepath :initarg :filepath :initform (error "A filepath must be provided") :documentation "The filepath that the buffer was attempted to be saved to when this error occured")) (:report (lambda (condition stream) (format stream "~A could not be saved to ~A" (name (buffer condition)) (filepath condition)))) (:documentation "An error that is a subclass of `buffer-writing-error' will be signalled when a buffer is attempted saved to a file, but something goes wrong. Not all error cases will result in the signalling of a `buffer-writing-error', but some defined cases will.")) (define-condition filepath-is-directory (buffer-writing-error) () (:report (lambda (condition stream) (format stream "Cannot save buffer ~A to just a directory" (name (buffer condition))))) (:documentation "This error is signalled when a buffer is attempted saved to a directory.")) (defun filepath-is-directory (buffer filepath) "Signal an error of type `filepath-is-directory' with the buffer `buffer' and the filepath `filepath'." (error 'filepath-is-directory :buffer buffer :filepath filepath)) (defun find-file (file-path) (frame-find-file *application-frame* file-path)) (defun find-file-read-only (file-path) (frame-find-file-read-only *application-frame* file-path)) (defun set-visited-file-name (filepath buffer) (frame-set-visited-file-name *application-frame* filepath buffer)) (defun save-buffer (buffer) (frame-save-buffer *application-frame* buffer)) (defun write-buffer (filepath buffer) (frame-write-buffer *application-frame* filepath buffer)) (make-command-table 'esa-io-table :errorp nil) ;;; Adapted from cl-fad/PCL (defun directory-pathname-p (pathspec) "Returns NIL if PATHSPEC does not designate a directory." (let ((name (pathname-name pathspec)) (type (pathname-type pathspec))) (and (or (null name) (eql name :unspecific)) (or (null type) (eql type :unspecific))))) (defun filepath-filename (pathname) (if (null (pathname-type pathname)) (pathname-name pathname) (concatenate 'string (pathname-name pathname) "." (pathname-type pathname)))) (defmethod frame-find-file (application-frame filepath) (cond ((null filepath) (display-message "No file name given.") (beep)) ((directory-pathname-p filepath) (display-message "~A is a directory name." filepath) (beep)) (t (or (find filepath (buffers *application-frame*) :key #'filepath :test #'equal) (let ((buffer (if (probe-file filepath) (with-open-file (stream filepath :direction :input) (make-buffer-from-stream stream)) (make-new-buffer)))) (setf (filepath buffer) filepath (name buffer) (filepath-filename filepath) (needs-saving buffer) nil) buffer))))) (defun directory-of-current-buffer () "Extract the directory part of the filepath to the file in the current buffer. If the current buffer does not have a filepath, the path to the user's home directory will be returned." (make-pathname :directory (pathname-directory (or (and (current-buffer) (filepath (current-buffer))) (user-homedir-pathname))))) (define-command (com-find-file :name t :command-table esa-io-table) ((filepath 'pathname :prompt "Find File: " :prompt-mode :raw :default (directory-of-current-buffer) :default-type 'pathname :insert-default t)) "Prompt for a filename then edit that file. If a buffer is already visiting that file, switch to that buffer. Does not create a file if the filename given does not name an existing file." (handler-case (find-file filepath) (file-error (e) (display-message "~A" e)))) (set-key `(com-find-file ,*unsupplied-argument-marker*) 'esa-io-table '((#\x :control) (#\f :control))) (defmethod frame-find-file-read-only (application-frame filepath) (cond ((null filepath) (display-message "No file name given.") (beep)) ((directory-pathname-p filepath) (display-message "~A is a directory name." filepath) (beep)) (t (or (find filepath (buffers *application-frame*) :key #'filepath :test #'equal) (if (probe-file filepath) (with-open-file (stream filepath :direction :input) (let ((buffer (make-buffer-from-stream stream))) (setf (filepath buffer) filepath (name buffer) (filepath-filename filepath) (read-only-p buffer) t (needs-saving buffer) nil))) (progn (display-message "No such file: ~A" filepath) (beep) nil)))))) (define-command (com-find-file-read-only :name t :command-table esa-io-table) ((filepath 'pathname :prompt "Find File read-only: " :prompt-mode :raw :default (directory-of-current-buffer) :default-type 'pathname :insert-default t)) "Prompt for a filename then open that file readonly. If a buffer is already visiting that file, switch to that buffer. If the filename given does not name an existing file, signal an error." (find-file-read-only filepath)) (set-key `(com-find-file-read-only ,*unsupplied-argument-marker*) 'esa-io-table '((#\x :control) (#\r :control))) (define-command (com-read-only :name t :command-table esa-io-table) () "Toggle the readonly status of the current buffer. When a buffer is readonly, attempts to change the contents of the buffer signal an error." (let ((buffer (current-buffer))) (setf (read-only-p buffer) (not (read-only-p buffer))))) (set-key 'com-read-only 'esa-io-table '((#\x :control) (#\q :control))) (defmethod frame-set-visited-file-name (application-frame filepath buffer) (setf (filepath buffer) filepath (name buffer) (filepath-filename filepath) (needs-saving buffer) t)) (define-command (com-set-visited-file-name :name t :command-table esa-io-table) ((filename 'pathname :prompt "New filename: " :prompt-mode :raw :default (directory-of-current-buffer) :insert-default t :default-type 'pathname :insert-default t)) "Prompt for a new filename for the current buffer. The next time the buffer is saved it will be saved to a file with that filename." (set-visited-file-name filename (current-buffer))) (defmethod check-buffer-writability (application-frame (filepath pathname) (buffer esa-buffer-mixin)) ;; Cannot write to a directory. (when (directory-pathname-p filepath) (filepath-is-directory buffer filepath))) (defun extract-version-number (pathname) "Extracts the emacs-style version-number from a pathname." (let* ((type (pathname-type pathname)) (length (length type))) (when (and (> length 2) (char= (char type (1- length)) #\~)) (let ((tilde (position #\~ type :from-end t :end (- length 2)))) (when tilde (parse-integer type :start (1+ tilde) :junk-allowed t)))))) (defun version-number (pathname) "Return the number of the highest versioned backup of PATHNAME or 0 if there is no versioned backup. Looks for name.type~X~, returns highest X." (let* ((wildpath (merge-pathnames (make-pathname :type :wild) pathname)) (possibilities (directory wildpath))) (loop for possibility in possibilities for version = (extract-version-number possibility) if (numberp version) maximize version into max finally (return max)))) (defun check-file-times (buffer filepath question answer) "Return NIL if filepath newer than buffer and user doesn't want to overwrite." (let ((f-w-d (and (probe-file filepath) (file-write-date filepath))) (f-w-t (file-write-time buffer))) (if (and f-w-d f-w-t (> f-w-d f-w-t)) (if (accept 'boolean :prompt (format nil "File has changed on disk. ~a anyway?" question)) t (progn (display-message "~a not ~a" filepath answer) nil)) t))) (defmethod frame-save-buffer (application-frame buffer) (let ((filepath (or (filepath buffer) (accept 'pathname :prompt "Save Buffer to File")))) (check-buffer-writability application-frame filepath buffer) (unless (check-file-times buffer filepath "Overwrite" "written") (return-from frame-save-buffer)) (when (and (probe-file filepath) (not (file-saved-p buffer))) (let ((backup-name (pathname-name filepath)) (backup-type (format nil "~A~~~D~~" (pathname-type filepath) (1+ (version-number filepath))))) (rename-file filepath (make-pathname :name backup-name :type backup-type)))) (with-open-file (stream filepath :direction :output :if-exists :supersede) (save-buffer-to-stream buffer stream)) (setf (filepath buffer) filepath (file-write-time buffer) (file-write-date filepath) (name buffer) (filepath-filename filepath)) (display-message "Wrote: ~a" (filepath buffer)) (setf (needs-saving buffer) nil))) (define-command (com-save-buffer :name t :command-table esa-io-table) () "Write the contents of the buffer to a file. If there is filename associated with the buffer, write to that file, replacing its contents. If not, prompt for a filename." (let ((buffer (current-buffer))) (if (null (filepath buffer)) (com-write-buffer (accept 'pathname :prompt "Write Buffer to File: " :prompt-mode :raw :default (directory-of-current-buffer) :insert-default t :default-type 'pathname)) (if (needs-saving buffer) (handler-case (save-buffer buffer) ((or buffer-writing-error file-error) (e) (display-message "~A" e))) (display-message "No changes need to be saved from ~a" (name buffer)))))) (set-key 'com-save-buffer 'esa-io-table '((#\x :control) (#\s :control))) (defmethod frame-write-buffer (application-frame filepath buffer) (check-buffer-writability application-frame filepath buffer) (with-open-file (stream filepath :direction :output :if-exists :supersede) (save-buffer-to-stream buffer stream)) (setf (filepath buffer) filepath (name buffer) (filepath-filename filepath) (needs-saving buffer) nil) (display-message "Wrote: ~a" (filepath buffer))) (define-command (com-write-buffer :name t :command-table esa-io-table) ((filepath 'pathname :prompt "Write Buffer to File: " :prompt-mode :raw :default (directory-of-current-buffer) :insert-default t :default-type 'pathname)) "Prompt for a filename and write the current buffer to it. Changes the file visted by the buffer to the given file." (let ((buffer (current-buffer))) (handler-case (write-buffer filepath buffer) (buffer-writing-error (e) (with-minibuffer-stream (minibuffer) (let ((*print-escape* nil)) (print-object e minibuffer))))))) (set-key `(com-write-buffer ,*unsupplied-argument-marker*) 'esa-io-table '((#\x :control) (#\w :control))) (define-menu-table esa-io-menu-table (esa-io-table global-esa-table) `(com-find-file ,*unsupplied-argument-marker*) `(com-find-file-read-only ,*unsupplied-argument-marker*) 'com-save-buffer `(com-write-buffer ,*unsupplied-argument-marker*) `(com-set-visited-file-name ,*unsupplied-argument-marker*) :divider 'com-quit) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/ESA/packages.lisp0000644000175000017500000001304711345155772020075 0ustar pdmpdm;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2004-2006 by ;;; Robert Strandh (strandh@labri.fr) ;;; (c) copyright 2006-2008 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Package definitions for ESA. (defpackage :esa-utils (:use :clim-lisp :clim-mop :clim) (:shadowing-import-from :clim-lisp #:describe-object) (:export #:with-gensyms #:once-only #:unlisted #:fully-unlisted #:listed #:list-aref #:letf #:letf* #:display-string #:object-equal #:object= #:no-upper-p #:case-relevant-test #:with-keywords-removed #:invoke-with-dynamic-bindings-1 #:invoke-with-dynamic-bindings #:maptree #:subtype-compatible-p #:capitalize #:ensure-array-size #:values-max-min #:retaining-value #:format-sym #:build-menu #:define-menu-table #:observable-mixin #:add-observer #:remove-observer #:observer-notified #:notify-observers #:name-mixin #:name #:subscriptable-name-mixin #:subscripted-name #:subscript #:subscript-generator #:mode #:modual-class #:available-modes #:mode-directly-applicable-p #:mode-applicable-p #:mode-enabled-p #:enabled-modes #:nonapplicable-mode #:change-class-for-enabled-mode #:change-class-for-disabled-mode #:enable-mode #:disable-mode #:add-default-modes #:remove-default-modes)) (defpackage :esa (:use :clim-lisp :clim :esa-utils :clim-extensions) (:export #:*esa-instance* #:buffers #:esa-current-buffer #:current-buffer #:windows #:esa-current-window #:current-window #:*previous-command* #:*minibuffer* #:minibuffer #:minibuffer-pane #:display-message #:with-minibuffer-stream #:esa-pane-mixin #:previous-command #:info-pane #:master-pane #:esa-frame-mixin #:recordingp #:executingp #:*esa-abort-gestures* #:*current-gesture* #:*command-processor* #:unbound-gesture-sequence #:gestures #:command-processor #:instant-macro-execution-mixin #:asynchronous-command-processor #:command-loop-command-processor #:dead-key-merging-command-processor #:overriding-handler #:directly-processing-p #:process-gesture #:process-gestures-or-command #:command-for-unbound-gestures #:*extended-command-prompt* #:define-esa-top-level #:esa-top-level #:simple-command-loop #:convert-to-gesture #:gesture-name #:invoke-with-help-stream #:with-help-stream #:set-key #:find-applicable-command-table #:esa-command-parser #:esa-partial-command-parser #:gesture-matches-gesture-name-p #:meta-digit #:proper-gesture-p #:universal-argument #:meta-minus ;; General commands #:global-esa-table #:com-quit #:com-extended-command ;; Help commands #:help-table #:help-menu-table #:com-describe-key-briefly #:com-where-is #:com-describe-bindings #:com-describe-key #:com-describe-command #:com-apropos-command ;; Keyboard macro commands #:keyboard-macro-table #:keyboard-macro-menu-table #:com-start-macro #:com-end-macro #:com-call-last-macro)) (defpackage :esa-buffer (:use :clim-lisp :clim :esa :esa-utils) (:export #:frame-make-buffer-from-stream #:make-buffer-from-stream #:frame-save-buffer-to-stream #:save-buffer-to-stream #:filepath #:name #:needs-saving #:file-write-time #:file-saved-p #:esa-buffer-mixin #:frame-make-new-buffer #:make-new-buffer #:read-only-p)) (defpackage :esa-io (:use :clim-lisp :clim :esa :esa-buffer :esa-utils) (:export #:frame-find-file #:find-file #:frame-find-file-read-only #:find-file-read-only #:frame-set-visited-file-name #:set-visited-filename #:check-buffer-writability #:frame-save-buffer #:save-buffer #:frame-write-buffer #:write-buffer #:buffer-writing-error #:buffer #:filepath #:filepath-is-directory #:esa-io-table #:esa-io-menu-table #:com-find-file #:com-find-file-read-only #:com-read-only #:com-set-visited-file-name #:com-save-buffer #:com-write-buffer)) #-(or mcclim building-mcclim) (defpackage :clim-extensions (:use :clim-lisp :clim) (:export #:+blue-violet+ #:+dark-blue+ #:+dark-green+ #:+dark-violet+ #:+gray50+ #:+gray85+ #:+maroon+ #:+purple+))cl-mcclim-0.9.6.dfsg.cvs20100315.orig/ESA/esa-buffer.lisp0000640000175000017500000000447410741375213020327 0ustar pdmpdm;;; -*- Mode: Lisp; Package: ESA-IO -*- ;;; (c) copyright 2006 by ;;; Robert Strandh (strandh@labri.fr) ;;; (c) copyright 2007 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :esa-buffer) (defgeneric frame-make-buffer-from-stream (application-frame stream) (:documentation "Create a fresh buffer by reading the external representation from STREAM")) (defun make-buffer-from-stream (stream) "Create a fresh buffer by reading the external representation from STREAM" (frame-make-buffer-from-stream *application-frame* stream)) (defgeneric frame-make-new-buffer (application-frame &key &allow-other-keys) (:documentation "Create a empty buffer for the application frame.")) (defun make-new-buffer (&rest args &key &allow-other-keys) "Create a empty buffer for the current frame." (apply #'frame-make-new-buffer *application-frame* args)) (defgeneric frame-save-buffer-to-stream (application-frame buffer stream) (:documentation "Save the entire BUFFER to STREAM in the appropriate external representation")) (defun save-buffer-to-stream (buffer stream) "Save the entire BUFFER to STREAM in the appropriate external representation" (frame-save-buffer-to-stream *application-frame* buffer stream)) (defclass esa-buffer-mixin (name-mixin) ((%filepath :initform nil :accessor filepath) (%needs-saving :initform nil :accessor needs-saving) (%file-write-time :initform nil :accessor file-write-time) (%file-saved-p :initform nil :accessor file-saved-p) (%read-only-p :initform nil :accessor read-only-p)) (:default-initargs :name "*scratch*")) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/ESA/esa-command-parser.lisp0000644000175000017500000001554711345155772022004 0ustar pdmpdm;;; -*- Mode: Lisp; Package: ESA -*- ;;; (c) copyright 2006 by ;;; Christophe Rhodes (c.rhodes@gold.ac.uk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :esa) ;;; There is an ambiguity over what to do for parsing partial commands ;;; with certain values filled in, as might occur for keyboard ;;; shortcuts. Either the supplied arguments should be treated as ;;; gospel and not even mentioned to the user, as we do now; or they ;;; should be treated as the default, but the user should be prompted ;;; to confirm, as we used to do. (defun esa-parse-one-arg (stream name ptype accept-args) (declare (ignore name)) ;; this conditional doesn't feel entirely happy. The issue is that ;; we could be called either recursively from an outer call to ;; (accept 'command), in which case we want our inner accept to ;; occur on the minibuffer stream not the input-editing-stream, or ;; from the toplevel when handed a partial command. Maybe the ;; toplevel should establish an input editing context for partial ;; commands anyway? Then ESA-PARSE-ONE-ARG would always be called ;; with an input-editing-stream. (let ((stream (if (encapsulating-stream-p stream) (encapsulating-stream-stream stream) stream))) (apply #'accept (eval ptype) :stream stream ;; This is fucking nuts. FIXME: the clim spec says ;; ":GESTURE is not evaluated at all". Um, but how are you ;; meant to tell if a keyword argument is :GESTURE, then? ;; The following does not actually allow variable keys: ;; anyone who writes (DEFINE-COMMAND FOO ((BAR 'PATHNAME ;; *RANDOM-ARG* ""))) and expects it to work deserves to ;; lose. ;; ;; FIXME: this will do the wrong thing on malformed accept ;; arguments, such improper lists or those with an odd ;; number of keyword arguments. I doubt that ;; DEFINE-COMMAND is checking the syntax, so we probably ;; should. (loop for (key val) on accept-args by #'cddr unless (eq key :gesture) collect key and collect (eval val))))) (defun esa-command-parser (command-table stream) (let ((command-name nil)) (flet ((maybe-clear-input () (let ((gesture (read-gesture :stream stream :peek-p t :timeout 0))) (when (and gesture (or (delimiter-gesture-p gesture) (activation-gesture-p gesture))) (read-gesture :stream stream))))) (with-delimiter-gestures (*command-name-delimiters* :override t) ;; While reading the command name we want use the history of ;; the (accept 'command ...) that's calling this function. ;; ;; FIXME: does this :history nil actually achieve the above? (setq command-name (accept `(command-name :command-table ,command-table) :stream (encapsulating-stream-stream stream) :prompt *extended-command-prompt* :prompt-mode :raw :history nil)) (maybe-clear-input)) (with-delimiter-gestures (*command-argument-delimiters* :override t) ;; FIXME, except we can't: use of CLIM-INTERNALS. (let* ((info (gethash command-name climi::*command-parser-table*)) (required-args (climi::required-args info)) (keyword-args (climi::keyword-args info))) (declare (ignore keyword-args)) (let (result) ;; only required args for now. (dolist (arg required-args (cons command-name (nreverse result))) (destructuring-bind (name ptype &rest args) arg (push (esa-parse-one-arg stream name ptype args) result) (maybe-clear-input))))))))) (defun esa-partial-command-parser (command-table stream command position &optional numeric-argument) (declare (ignore command-table position)) (let ((command-name (car command)) (command-args (cdr command))) (flet ((maybe-clear-input () (let ((gesture (read-gesture :stream stream :peek-p t :timeout 0))) (when (and gesture (or (delimiter-gesture-p gesture) (activation-gesture-p gesture))) (read-gesture :stream stream))))) (with-delimiter-gestures (*command-argument-delimiters* :override t) ;; FIXME, except we can't: use of CLIM-INTERNALS. (let ((info (gethash command-name climi::*command-parser-table*))) (if (null info) ;; `command' is not a real command! Well, we can still ;; replace numeric argument markers. (substitute-numeric-argument-marker command numeric-argument) (let ((required-args (climi::required-args info)) (keyword-args (climi::keyword-args info))) ;; keyword arguments not yet supported (declare (ignore keyword-args)) (let (result arg-parsed) ;; only required args for now. (do* ((required-args required-args (cdr required-args)) (arg (car required-args) (car required-args)) (command-args command-args (cdr command-args)) (command-arg (car command-args) (car command-args))) ((null required-args) (cons command-name (nreverse result))) (destructuring-bind (name ptype &rest args) arg (push (cond ((eq command-arg *unsupplied-argument-marker*) (setf arg-parsed t) (esa-parse-one-arg stream name ptype args)) ((eq command-arg *numeric-argument-marker*) (or numeric-argument (getf args :default))) (t (eval command-arg))) result) (when arg-parsed (maybe-clear-input)))))))))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/ESA/colors.lisp0000640000175000017500000000275510524227170017606 0ustar pdmpdm;;; -*- Mode: Lisp; Package: clim-extensions -*- ;;; (c) copyright 2006 by ;;; Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Color definitions from McCLIM that don't exist in Classic CLIM (in-package :clim-extensions) #-(or mcclim building-mcclim) (progn (defparameter +blue-violet+ (make-rgb-color 0.5412 0.1686 0.8863)) (defparameter +gray50+ (make-gray-color 0.4980)) (defparameter +gray85+ (make-gray-color 0.8510)) (defparameter +dark-blue+ (make-rgb-color 0.0 0.0 0.5451)) (defparameter +dark-green+ (make-rgb-color 0.0000 0.3922 0.0000)) (defparameter +dark-violet+ (make-rgb-color 0.5804 0.0000 0.8275)) (defparameter +maroon+ (make-rgb-color 0.6902 0.1882 0.3765)) (defparameter +purple+ (make-rgb-color 0.6275 0.1255 0.9412))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/ESA/utils.lisp0000644000175000017500000006723111345155772017463 0ustar pdmpdm;;; -*- Mode: Lisp; Package: ESA-UTILS -*- ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Miscellaneous utilities used in ESA. (in-package :esa-utils) ;;; Cribbed from Paul Graham (defmacro with-gensyms (syms &body body) `(let ,(mapcar #'(lambda (s) `(,s (gensym))) syms) ,@body)) ;;; Cribbed from PCL by Seibel (defmacro once-only ((&rest names) &body body) (let ((gensyms (loop for n in names collect (gensym)))) `(let (,@(loop for g in gensyms collect `(,g (gensym)))) `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n))) ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g))) ,@body))))) (defun unlisted (obj &optional (fn #'first)) (if (listp obj) (funcall fn obj) obj)) (defun fully-unlisted (obj &optional (fn #'first)) (if (listp obj) (fully-unlisted (funcall fn obj)) obj)) (defun listed (obj) (if (listp obj) obj (list obj))) (defun list-aref (list &rest subscripts) (if subscripts (apply #'list-aref (nth (first subscripts) list) (rest subscripts)) list)) ;;; Cribbed from McCLIM. (defun check-letf-form (form) (assert (and (listp form) (= 2 (length form))))) (defun valueify (list) (if (and (consp list) (endp (rest list))) (first list) `(values ,@list))) (defmacro letf ((&rest forms) &body body &environment env) "LETF ({(Place Value)}*) Declaration* Form* During evaluation of the Forms, SETF the Places to the result of evaluating the Value forms. The places are SETF-ed in parallel after all of the Values are evaluated." (mapc #'check-letf-form forms) (let* (init-let-form save-old-values-setf-form new-values-set-form old-values-set-form update-form) (loop for (place new-value) in forms for (vars vals store-vars writer-form reader-form) = (multiple-value-list (get-setf-expansion place env)) for old-value-names = (mapcar (lambda (var) (declare (ignore var)) (gensym)) store-vars) nconc (mapcar #'list vars vals) into temp-init-let-form nconc (copy-list store-vars) into temp-init-let-form nconc (copy-list old-value-names) into temp-init-let-form nconc `(,(valueify old-value-names) ,reader-form) into temp-save-old-values-setf-form nconc `(,(valueify store-vars) ,new-value) into temp-new-values-set-form nconc `(,(valueify store-vars) ,(valueify old-value-names)) into temp-old-values-set-form collect writer-form into temp-update-form finally (setq init-let-form temp-init-let-form save-old-values-setf-form temp-save-old-values-setf-form new-values-set-form temp-new-values-set-form old-values-set-form temp-old-values-set-form update-form (cons 'progn temp-update-form))) `(let* ,init-let-form (setf ,@save-old-values-setf-form) (unwind-protect (progn (setf ,@new-values-set-form) ,update-form (progn ,@body)) (setf ,@old-values-set-form) ,update-form)))) (defun invoke-with-dynamic-bindings-1 (bindings continuation) (let ((old-values (mapcar #'(lambda (elt) (symbol-value (first elt))) bindings))) (unwind-protect (progn (mapcar #'(lambda (elt) (setf (symbol-value (first elt)) (funcall (second elt)))) bindings) (funcall continuation)) (mapcar #'(lambda (elt value) (setf (symbol-value (first elt)) value)) bindings old-values)))) (defmacro invoke-with-dynamic-bindings ((&rest bindings) &body body) `(invoke-with-dynamic-bindings-1 ,(loop for (symbol expression) in bindings collect (list `',symbol `#'(lambda () ,expression))) #'(lambda () ,@body))) ;;; XXX This is currently broken with respect to declarations (defmacro letf* ((&rest forms) &body body) (if (null forms) `(locally ,@body) `(letf (,(car forms)) (letf* (,(cdr forms)) ,@body)))) (defun display-string (string) (with-output-to-string (result) (loop for char across string do (cond ((graphic-char-p char) (princ char result)) ((char= char #\Space) (princ char result)) (t (prin1 char result)))))) (defun object-equal (x y) "Case insensitive equality that doesn't require characters" (if (characterp x) (and (characterp y) (char-equal x y)) (eql x y))) (defun object= (x y) "Case sensitive equality that doesn't require characters" (if (characterp x) (and (characterp y) (char= x y)) (eql x y))) (defun no-upper-p (string) "Does STRING contain no uppercase characters" (notany #'upper-case-p string)) (defun case-relevant-test (string) "Returns a test function based on the search-string STRING. If STRING contains no uppercase characters the test is case-insensitive, otherwise it is case-sensitive." (if (no-upper-p string) #'object-equal #'object=)) (defun remove-keywords (arg-list keywords) (let ((clean-tail arg-list)) ;; First, determine a tail in which there are no keywords to be removed. (loop for arg-tail on arg-list by #'cddr for (key) = arg-tail do (when (member key keywords :test #'eq) (setq clean-tail (cddr arg-tail)))) ;; Cons up the new arg list until we hit the clean-tail, then nconc that on ;; the end. (loop for arg-tail on arg-list by #'cddr for (key value) = arg-tail if (eq arg-tail clean-tail) nconc clean-tail and do (loop-finish) else if (not (member key keywords :test #'eq)) nconc (list key value) end))) (defmacro with-keywords-removed ((var keywords &optional (new-var var)) &body body) "binds NEW-VAR (defaults to VAR) to VAR with the keyword arguments specified in KEYWORDS removed." `(let ((,new-var (remove-keywords ,var ',keywords))) ,@body)) (defun maptree (fn x) "This auxiliary function is like MAPCAR but has two extra purposes: (1) it handles dotted lists; (2) it tries to make the result share with the argument x as much as possible." (if (atom x) (funcall fn x) (let ((a (funcall fn (car x))) (d (maptree fn (cdr x)))) (if (and (eql a (car x)) (eql d (cdr x))) x (cons a d))))) (defun subtype-compatible-p (types) "Return true if an element of `types' is a subtype of every other type specifier in `types'. `Types' must be a list of type specifiers." (some (lambda (x) (subtypep x `(and ,@types))) types)) (defun capitalize (string) "Return `string' with the first character capitalized (destructively modified)." (setf (elt string 0) (char-upcase (elt string 0))) string) (defun ensure-array-size (array min-size new-elem-fn) "Ensure that `array' is at least of size `min-size'. If `array' needs to be resized, call `new-elem-fn' with no arguments to generate the elements of the new cells in the array. Returns `array'. Currently, this function only works when `array' is a vector." (when (< (length array) min-size) (let ((old-length (length array))) (setf array (adjust-array array (max (* old-length 2) min-size))) (loop for i from old-length below (length array) do (setf (elt array i) (funcall new-elem-fn))))) array) (define-method-combination values-max-min (&optional (order ':most-specific-first)) ((around (:around)) (before (:before)) (after (:after)) (primary (values-max-min) :order order :required t)) (flet ((call-methods (methods) (mapcar (lambda (m) `(call-method ,m)) methods)) (call-vmm-methods (methods) `(multiple-value-bind (max min) (call-method ,(first methods)) (progn ,@(loop for m in (rest methods) collect `(multiple-value-bind (mmax mmin) (call-method ,m) (setq max (max max mmax) min (min min mmin))))) (values max min)))) (let ((form (if (or around before after (rest primary)) `(multiple-value-prog1 (progn ,@(call-methods before) ,(call-vmm-methods primary)) (progn ,@(call-methods (reverse after)))) `(call-method ,(first primary))))) (if around `(call-method ,(first around) (,@(rest around) (make-method ,form))) form)))) (defmacro retaining-value ((bound-symbol &optional initial-value) &body body) "Evaluate `body' with `bound-symbol' bound to `initial-value' (default NIL). Th next time `body' is evaluated, `bound-symbol' will be bound to whatever its value was the last time evaluation of `body' ended." (let ((symbol (gensym))) `(progn (unless (boundp ',symbol) (setf (symbol-value ',symbol) ,initial-value)) (let ((,bound-symbol (symbol-value ',symbol))) (unwind-protect (progn ,@body) (setf (symbol-value ',symbol) ,bound-symbol)))))) (defun format-sym (format-string &rest args) "Return `format-string' with args spliced in, where all arguments that are symbols with have their `symbol-name' spliced instead, this makes sure the result is correct even on systems where read/print case is other than default." (apply #'format nil format-string (mapcar #'(lambda (arg) (if (symbolp arg) (symbol-name arg) arg)) args))) (defun build-menu (command-tables &rest commands) "Create a command table inheriting commands from `command-tables', which must be a list of command table designators. The created command table will have a menu consisting of `commands', elements of which must be one of: * A named command accessible in one of `command-tables'. This may either be a command name, or a cons of a command name and arguments. The command will appear directly in the menu. * A list of the symbol `:menu' and something that will evaluate to a command table designator. This will create a submenu showing the name and menu of the designated command table. * A list of the symbol `:submenu', a string, and a &rest list of the same form as `commands'. This is equivalent to `:menu' with a call to `build-menu' with `command-tables' and the specified list as arguments. * A symbol `:divider', which will present a horizontal divider line. An error of type`command-table-error' will be signalled if a command cannot be found in any of the provided command tables." (labels ((get-command-name (command) (or (loop for table in command-tables for name = (command-line-name-for-command command table :errorp nil) when name return name) (error 'command-table-error :format-string "Command ~A not found in any provided command table" :format-arguments (list command)))) (make-menu-entry (entry) (cond ((and (listp entry) (eq (first entry) :menu)) (list (command-table-name (find-command-table (second entry))) :menu (second entry))) ((and (listp entry) (eq (first entry) :submenu)) (list (second entry) :menu (apply #'build-menu command-tables (cddr entry)))) ((eq entry :divider) '(nil :divider :line)) (t (list (get-command-name (command-name (listed entry))) :command entry))))) (make-command-table nil :inherit-from command-tables :menu (mapcar #'make-menu-entry commands)))) (defmacro define-menu-table (name (&rest command-tables) &body commands) "Define a command table with a menu named `name' and containing `commands'. `Command-tables' must be a list of command table designators containing the named commands that will be included in the menu. `Commands' must have the same format as the `commands' argument to `build-menu'. If `name' already names a command table, the old definition will be destroyed." `(make-command-table ',name :inherit-from (list (build-menu ',command-tables ,@commands)) :inherit-menu t :errorp nil)) (defclass observable-mixin () ((%observers :accessor observers :initform '())) (:documentation "A mixin class that adds the capability for a subclass to have a list of \"event subscribers\" (observers) that can be informed via callback (the function `observer-notified') whenever the state of the object changes. The order in which observers will be notified is undefined.")) (defgeneric add-observer (observable observer) (:documentation "Add an observer to an observable object. If the observer is already observing `observable', it will not be added again.")) (defmethod add-observer ((observable observable-mixin) observer) ;; Linear in complexity, perhaps a transparent switch to a hash ;; table would be a good idea for large amounts of observers. (pushnew observer (observers observable))) (defgeneric remove-observer (observable observer) (:documentation "Remove an observer from an observable object. If observer is not in the list of observers of `observable', nothing will happen.")) (defmethod remove-observer ((observable observable-mixin) observer) (setf (observers observable) (delete observer (observers observable)))) (defgeneric observer-notified (observer observable data) (:documentation "This function is called by `observable' when its state changes on each observer that is observing it. `Observer' is the observing object, `observable' is the observed object. `Data' is arbitrary data that might be of interest to `observer', it is recommended that subclasses of `observable-mixin' specify exactly which form this data will take, the observer protocol does not guarantee anything. It is non-&optional so that methods may be specialised on it, if applicable. The default method on this function is a no-op, so it is never an error to not define a method on this generic function for an observer.") (:method (observer (observable observable-mixin) data) ;; Never a no-applicable-method error. nil)) (defgeneric notify-observers (observable &optional data-fn) (:documentation "Notify each observer of `observable' by calling `observer-notified' on them. `Data-fn' will be called, with the observer as the single argument, to obtain the `data' argument to `observer-notified'. The default value of `data-fn' should cause the `data' argument to be NIL.")) (defmethod notify-observers ((observable observable-mixin) &optional (data-fn (constantly nil))) (dolist (observer (observers observable)) (observer-notified observer observable (funcall data-fn observer)))) (defclass name-mixin () ((%name :accessor name :initarg :name :type string :documentation "The name of the named object.")) (:documentation "A class used for defining named objects.")) (defclass subscriptable-name-mixin (name-mixin) ((%subscript :accessor subscript :documentation "The subscript of the named object.") (%subscript-generator :accessor subscript-generator :initarg :subscript-generator :initform (constantly 1) :documentation "A function used for finding the subscript of a `name-mixin' whenever the name is set (including during object initialization). This function will be called with the name as the single argument.")) (:documentation "A class used for defining named objects. A facility is provided for assigning a named object a \"subscript\" uniquely identifying the object if there are other objects of the same name in its collection (in particular, if an editor has two buffers with the same name).")) (defmethod initialize-instance :after ((name-mixin subscriptable-name-mixin) &rest initargs) (declare (ignore initargs)) (setf (subscript name-mixin) (funcall (subscript-generator name-mixin) (name name-mixin)))) (defmethod subscripted-name ((name-mixin subscriptable-name-mixin)) ;; Perhaps this could be written as a single format statement? (if (/= (subscript name-mixin) 1) (format nil "~A <~D>" (name name-mixin) (subscript name-mixin)) (name name-mixin))) (defmethod (setf name) :after (new-name (name-mixin subscriptable-name-mixin)) (setf (subscript name-mixin) (funcall (subscript-generator name-mixin) new-name))) ;;; "Modes" are a generally useful concept, so let's define some ;;; primitives for them here. (defclass mode () () (:documentation "A superclass for all modes.")) (defconstant +default-modes-plist-symbol+ 'modual-class-default-modes "The symbol that is pushed onto the property list of the name of a class to contain the list of default modes for the class.") (defun default-modes (modual-class) "Return the list of default modes for `modual-class', which must be a symbol and the name of a modual class. The modes are returned as a list of conses, with the car of each cons being the name of the mode as a symbol, and the cdr of each cons being a list of initargs" (getf (symbol-plist modual-class) +default-modes-plist-symbol+)) (defun (setf default-modes) (new-default-modes modual-class) "Set the list of default modes for `modual-class', which must be a symbol and the name of a modual class. The modes should be given as a list of conses, with the car of each cons being the name of the mode as a symbol, and the cdr of each cons being a list of initargs" (setf (getf (symbol-plist modual-class) +default-modes-plist-symbol+) new-default-modes)) (defclass modual-class (standard-class) () (:documentation "A metaclass for defining classes supporting changing of modes.")) (defmethod validate-superclass ((c1 modual-class) (c2 standard-class)) t) (defmethod compute-slots ((c modual-class)) (append (call-next-method) (list (make-instance 'standard-effective-slot-definition :name '%original-class-name :allocation :instance :documentation "The original name of the class the `modual-mixin' is part of, the actual name will change as modes are added and removed.")))) (defmethod make-instance ((class modual-class) &rest initargs) (declare (ignore initargs)) (let ((instance (call-next-method))) (setf (slot-value instance '%original-class-name) (class-name class)) (dolist (class (reverse (class-precedence-list class)) instance) (when (symbolp (class-name class)) (dolist (mode-and-initargs (default-modes (class-name class))) (apply #'enable-mode instance (first mode-and-initargs) (rest mode-and-initargs))))))) (defgeneric available-modes (modual) (:documentation "Return all available modes for `modual'. Not all of the modes may be applicable, use the `applicable-modes' function if you're only interested in these.") (:method-combination append) (:method append ((modual t)) '())) (defgeneric mode-directly-applicable-p (modual mode-name) (:documentation "Return true if the mode of the name `mode-name' can be directly enabled for `modual'. If the mode of name `mode-name' is unapplicable, an error of type `nonapplicable-mode' will be signalled. This allows a sort of \"opt-out\" where a mode can forcefully prevent another specific mode from being enabled. ") (:method-combination or) (:method or ((modual t) mode-name) nil)) (defgeneric mode-applicable-p (modual mode-name) (:documentation "Return true if the mode of the name `mode-name' can be enabled for `modual' or some sub-object of `modual'. If the mode of name `mode-name' is unapplicable, an error of type `nonapplicable-mode' will be signalled. This allows a sort of \"opt-out\" where a mode can forcefully prevent another specific mode from being enabled. ") (:method-combination or) (:method or ((modual t) mode-name) (mode-directly-applicable-p modual mode-name))) (defgeneric enabled-modes (modual) (:documentation "Return a list of the names of the modes directly enabled for `modual'.") (:method ((modual t)) '())) (defgeneric mode-enabled-p (modual mode-name) (:documentation "Return true if `mode-name' is enabled for `modual' or any modual \"sub-objects\"." ) (:method-combination or) (:method or ((modual t) mode-name) (member mode-name (enabled-modes modual) :test #'equal))) (define-condition nonapplicable-mode (error) ((%modual :accessor modual :initarg :modual :initform (error "The modual used in the error-causing operation must be supplied") :documentation "The modual that the mode is attempted to be enabled for") (%mode-name :accessor mode-name :initarg :mode-name :initform (error "The name of the problematic mode must be supplied") :documentation "The name of the mode that cannot be enabled for the view")) (:documentation "This error is signalled if a mode is attempted enabled for a modual that the mode is not applicable to.") (:report (lambda (condition stream) (format stream "The mode ~A is not applicable for ~A" (mode-name condition) (modual condition))))) (defun nonapplicable-mode (modual mode-name) "Signal an error of type `nonapplicable-mode' with `modual' and `mode-name' as arguments." (error 'nonapplicable-mode :modual modual :mode-name mode-name)) (defgeneric enable-mode (modual mode-name &rest initargs) (:documentation "Enable the mode of the name `mode-name' for `modual', using `initargs' as options for the mode. If the mode is already enabled, do nothing. If the mode is not applicable to `modual', signal an `nonapplicable-mode' error.") (:method :around ((modual t) mode-name &rest initargs) (declare (ignore initargs)) (unless (mode-enabled-p modual mode-name) (call-next-method)))) (defgeneric disable-mode (modual mode-name) (:documentation "Disable the mode of the name `mode-name' for `modual'. If a mode of the provided name is not enabled, do nothing.") (:method :around ((modual t) mode-name) (when (mode-enabled-p modual mode-name) (call-next-method)))) ;;; In a perfect world, we would just combine `change-class' with ;;; anonymous classes to transparently add and remove mode classes ;;; (the "stealth mixin" concept). However, anonymous classes are the ;;; ugly child of CL, not well supported at all, so we'll have to do ;;; some ugly hacks involving the `eval'ing of constructed `defclass' ;;; forms, and caching the created classes to prevent memory leaking. (defvar *class-cache* (make-hash-table :test #'equal) "A hash table mapping the name of a \"modual\" class to a second hash table. This second hash table maps a list of mode names to a class implementing this particular set of modes for the modual class. Note that the order in which the modes appear in the list is significant.") (defun make-class-implementing-modes (modual modes) "Generate a class that is a subclass of `modual' that implements all the modes listed as names in `modes'." ;; Avert thine eyes, thy of gentle spirit. (if (null modes) (find-class modual) ;; We're kind and put the active modes into the class name. (eval `(defclass ,(gensym (format nil "~A~{-~A~}" (string modual) modes)) (,modual ,@modes) ((%enabled-modes :reader enabled-modes :initform ',modes)) (:metaclass modual-class))))) (defun find-class-implementing-modes (modual modes) "Find, possibly create, the class implementing `modual' (a class name) with `modes' (a list of mode names) as the enabled modes." (let* ((modual-cache-hit (gethash modual *class-cache*)) (modes-cache-hit (and modual-cache-hit (gethash modes modual-cache-hit)))) (or modes-cache-hit (setf (gethash modes (or modual-cache-hit (setf (gethash modual *class-cache*) (make-hash-table :test #'equal)))) (make-class-implementing-modes modual modes))))) (defun change-class-for-enabled-mode (modual mode-name &rest initargs) "Change the class of `modual' so that it has a mode of name `mode-name', created with the provided `initargs'." (apply #'change-class modual (find-class-implementing-modes (slot-value modual '%original-class-name) (cons mode-name (enabled-modes modual))) initargs)) (defun change-class-for-disabled-mode (modual mode-name) "Change the class of `modual' so that it does not have a mode of name `mode-name'." (change-class modual (find-class-implementing-modes (slot-value modual '%original-class-name) (remove mode-name (enabled-modes modual) :test #'equal)))) (defmethod enable-mode ((modual t) mode-name &rest initargs) (if (mode-directly-applicable-p modual mode-name) (apply #'change-class-for-enabled-mode modual mode-name initargs) (nonapplicable-mode modual mode-name))) (defmethod disable-mode ((modual t) mode-name) (when (mode-directly-applicable-p modual mode-name) (change-class-for-disabled-mode modual mode-name))) (defmacro add-default-modes (modual-class &body modes) "Add `modes' to the list of default modes for `modual-class'. Will not replace any already existing modes. The elements in `modes' can either be a single symbol, the name of a mode, or a cons of the name of a mode and a list of initargs for the mode. In the former case, no initargs will be given. Please do not use default modes as a programming tool, they should be reserved for user-oriented functionality." (dolist (mode modes) (let ((mode-name (unlisted mode))) (check-type mode-name symbol) ;; Take care not to add the same mode twice, this is risky enough ;; as it is. (setf (default-modes modual-class) (cons (listed mode) (delete mode-name (default-modes modual-class) :key #'first)))))) (defmacro remove-default-modes (modual-class &body modes) "Remove `modes' from the list of default modes for `modual-class'. `Modes' must be a list of names of modes in the form of symbols. If a provided mode is not set as a default mode, nothing will be done." (dolist (mode modes) (check-type mode symbol) ;; Take care not to add the same mode twice, this is risky enough ;; as it is. (setf (default-modes modual-class) (delete mode (default-modes modual-class) :key #'first)))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/ESA/esa.asd0000640000175000017500000000303210524227170016642 0ustar pdmpdm;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2005-2006 by ;;; Robert Strandh (strandh@labri.u-bordeaux.fr) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; ASDF system definition for ESA. (defpackage :esa.system (:use :cl :asdf)) (in-package :esa.system) (defsystem :esa :depends-on (:mcclim) :components ((:file "packages") (:file "utils" :depends-on ("packages")) (:file "colors" :depends-on ("packages")) (:file "esa" :depends-on ("colors" "packages" "utils")) (:file "esa-buffer" :depends-on ("packages" "esa")) (:file "esa-io" :depends-on ("packages" "esa" "esa-buffer")) (:file "esa-command-parser" :depends-on ("packages" "esa"))))cl-mcclim-0.9.6.dfsg.cvs20100315.orig/ESA/esa.lisp0000644000175000017500000021312711345155772017070 0ustar pdmpdm;;; -*- Mode: Lisp; Package: ESA -*- ;;; (c) copyright 2005 by ;;; Robert Strandh (strandh@labri.fr) ;;; (c) copyright 2006-2007 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Emacs-Style Application (in-package :esa) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Querying ESAs. (defvar *esa-instance* nil "This symbol should be bound to an ESA instance, though any object will do, provided the proper methods are defined. It will be used as the argument to the various \"query\" functions defined by ESA. For the vast majority of ESAs, `*esa-instance*' will probably have the same value as `*application-frame*'.") (defgeneric buffers (esa) (:documentation "Return a list of all the buffers of the application.")) (defgeneric esa-current-buffer (esa) (:documentation "Return the current buffer of APPLICATION-FRAME.")) (defgeneric (setf esa-current-buffer) (new-buffer esa) (:documentation "Replace the current buffer of APPLICATION-FRAME with NEW-BUFFER.")) (defun current-buffer () "Return the currently active buffer of the running ESA." (esa-current-buffer *esa-instance*)) (defun (setf current-buffer) (new-buffer) "Return the currently active buffer of the running ESA." (setf (esa-current-buffer *esa-instance*) new-buffer)) (defgeneric windows (esa) (:documentation "Return a list of all the windows of the ESA.") (:method ((esa application-frame)) '())) (defgeneric esa-current-window (esa) (:documentation "Return the current window of ESA.")) (defun current-window () "Return the currently active window of the running ESA instance." (esa-current-window *esa-instance*)) (defvar *previous-command* nil "When a command is being executed, the command previously executed by the application.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Info pane, a pane that displays some information about another pane (defclass info-pane (application-pane) ((master-pane :initarg :master-pane :reader master-pane)) (:default-initargs :background +gray85+ :scroll-bars nil :borders nil)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Minibuffer pane (defgeneric minibuffer (application-frame) (:documentation "Return the minibuffer of `application-frame'.")) (defvar *minibuffer* nil "The minibuffer pane of the running application.") (defvar *minimum-message-time* 1 "The minimum number of seconds a minibuffer message will be displayed." ) (defclass minibuffer-pane (application-pane) ((message :initform nil :accessor message :documentation "An output record containing whatever message is supposed to be displayed in the minibuffer.") (message-time :initform 0 :accessor message-time :documentation "The universal time at which the current message was set.")) (:default-initargs :scroll-bars nil :display-function 'display-minibuffer :display-time :command-loop :incremental-redisplay t)) (defmethod handle-repaint ((pane minibuffer-pane) region) (when (and (message pane) (> (get-universal-time) (+ *minimum-message-time* (message-time pane)))) (window-clear pane) (setf (message pane) nil)) (call-next-method)) (defmethod (setf message) :after (new-value (pane minibuffer-pane)) (change-space-requirements pane)) (defmethod pane-needs-redisplay ((pane minibuffer-pane)) ;; Always call the display function, never clear the window. This ;; allows us to time-out the message in the minibuffer. (values t nil)) (defun display-minibuffer (frame pane) (declare (ignore frame)) (handle-repaint pane +everywhere+)) (defmethod stream-accept :around ((pane minibuffer-pane) type &rest args) (declare (ignore args)) (when (message pane) (setf (message pane) nil)) (window-clear pane) ;; FIXME: this isn't the friendliest way of indicating a parse ;; error: there's no feedback, unlike emacs' quite nice "[no ;; match]". (unwind-protect (loop (handler-case (with-input-focus (pane) (return (call-next-method))) (parse-error () nil))) (window-clear pane))) (defmethod stream-accept ((pane minibuffer-pane) type &rest args &key (view (stream-default-view pane)) &allow-other-keys) ;; default CLIM prompting is OK for now... (apply #'prompt-for-accept pane type view args) ;; but we need to turn some of ACCEPT-1 off. (apply #'accept-1-for-minibuffer pane type args)) (defmethod compose-space ((pane minibuffer-pane) &key width height) (declare (ignore width height)) (with-sheet-medium (medium pane) (let* ((sr (call-next-method)) (height (max (text-style-height (medium-merged-text-style medium) medium) (bounding-rectangle-height (stream-output-history pane))))) (make-space-requirement :height height :min-height height :max-height height :width (space-requirement-width sr) :min-width (space-requirement-min-width sr) :max-width (space-requirement-max-width sr))))) ;;; simpler version of McCLIM's internal operators of the same names: ;;; HANDLE-EMPTY-INPUT to make default processing work, EMPTY-INPUT-P ;;; and INVOKE-HANDLE-EMPTY-INPUT to support it. We don't support ;;; recursive bouncing to see who most wants to handle the empty ;;; input, but that's OK, because we are always conceptually one-level ;;; deep in accept (even if sometimes we call ACCEPT recursively for ;;; e.g. command-names and arguments). (defmacro handle-empty-input ((stream) input-form &body handler-forms) "see climi::handle-empty-input" (let ((input-cont (gensym "INPUT-CONT")) (handler-cont (gensym "HANDLER-CONT"))) `(flet ((,input-cont () ,input-form) (,handler-cont () ,@handler-forms)) (declare (dynamic-extent #',input-cont #',handler-cont)) (invoke-handle-empty-input ,stream #',input-cont #',handler-cont)))) ;;; The code that signalled the error might have consumed the gesture, or ;;; not. ;;; XXX Actually, it would be a violation of the `accept' protocol to consume ;;; the gesture, but who knows what random accept methods are doing. (defun empty-input-p (stream begin-scan-pointer activation-gestures delimiter-gestures) (let ((scan-pointer (stream-scan-pointer stream)) (fill-pointer (fill-pointer (stream-input-buffer stream)))) ;; activated? (cond ((and (eql begin-scan-pointer scan-pointer) (eql scan-pointer fill-pointer)) t) ((or (eql begin-scan-pointer scan-pointer) (eql begin-scan-pointer (1- scan-pointer))) (let ((gesture (aref (stream-input-buffer stream) begin-scan-pointer))) (and (characterp gesture) (flet ((gesture-matches-p (g) (if (characterp g) (char= gesture g) ;; FIXME: not quite portable -- ;; apparently ;; EVENT-MATCHES-GESTURE-NAME-P need ;; not work on raw characters (event-matches-gesture-name-p gesture g)))) (or (some #'gesture-matches-p activation-gestures) (some #'gesture-matches-p delimiter-gestures)))))) (t nil)))) (defun invoke-handle-empty-input (stream input-continuation handler-continuation) (unless (input-editing-stream-p stream) (return-from invoke-handle-empty-input (funcall input-continuation))) (let ((begin-scan-pointer (stream-scan-pointer stream)) (activation-gestures *activation-gestures*) (delimiter-gestures *delimiter-gestures*)) (block empty-input (handler-bind ((parse-error #'(lambda (c) (declare (ignore c)) (when (empty-input-p stream begin-scan-pointer activation-gestures delimiter-gestures) (return-from empty-input nil))))) (return-from invoke-handle-empty-input (funcall input-continuation)))) (funcall handler-continuation))) (defun accept-1-for-minibuffer (stream type &key (view (stream-default-view stream)) (default nil defaultp) (default-type nil default-type-p) provide-default insert-default (replace-input t) history active-p prompt prompt-mode display-default query-identifier (activation-gestures nil activationsp) (additional-activation-gestures nil additional-activations-p) (delimiter-gestures nil delimitersp) (additional-delimiter-gestures nil additional-delimiters-p)) (declare (ignore provide-default history active-p prompt prompt-mode display-default query-identifier)) (when (and defaultp (not default-type-p)) (error ":default specified without :default-type")) (when (and activationsp additional-activations-p) (error "only one of :activation-gestures or ~ :additional-activation-gestures may be passed to accept.")) (unless (or activationsp additional-activations-p *activation-gestures*) (setq activation-gestures *standard-activation-gestures*)) (with-input-editing ;; this is the main change from CLIM:ACCEPT-1 -- no sensitizer. (stream :input-sensitizer nil) ;; KLUDGE: no call to CLIMI::WITH-INPUT-POSITION here, but that's ;; OK because we are always going to create a new editing stream ;; for each call to accept/accept-1-for-minibuffer, so the default ;; default for the BUFFER-START argument to REPLACE-INPUT is ;; right. (when (and insert-default (not (stream-rescanning-p stream))) ;; Insert the default value to the input stream. It should ;; become fully keyboard-editable. We do not want to insert ;; the default if we're rescanning, only during initial ;; setup. (presentation-replace-input stream default default-type view)) (with-input-context (type) (object object-type event options) (with-activation-gestures ((if additional-activations-p additional-activation-gestures activation-gestures) :override activationsp) (with-delimiter-gestures ((if additional-delimiters-p additional-delimiter-gestures delimiter-gestures) :override delimitersp) (let ((accept-results nil)) (climi::handle-empty-input (stream) (setq accept-results (multiple-value-list (if defaultp (funcall-presentation-generic-function accept type stream view :default default :default-type default-type) (funcall-presentation-generic-function accept type stream view)))) ;; User entered activation or delimiter gesture ;; without any input. (if defaultp (presentation-replace-input stream default default-type view :rescan nil) (simple-parse-error "Empty input for type ~S with no supplied default" type)) (setq accept-results (list default default-type))) ;; Eat trailing activation gesture ;; XXX what about pointer gestures? ;; XXX and delimiter gestures? ;; ;; deleted check for *RECURSIVE-ACCEPT-P* (let ((ag (read-char-no-hang stream nil stream t))) (unless (or (null ag) (eq ag stream)) (unless (activation-gesture-p ag) (unread-char ag stream)))) (values (car accept-results) (if (cdr accept-results) (cadr accept-results) type))))) ;; A presentation was clicked on, or something. (t (when (and replace-input (getf options :echo t) (not (stream-rescanning-p stream))) (presentation-replace-input stream object object-type view :rescan nil)) (values object object-type))))) (defgeneric invoke-with-minibuffer-stream (minibuffer continuation)) (defmethod invoke-with-minibuffer-stream ((minibuffer minibuffer-pane) continuation) (window-clear minibuffer) (setf (message minibuffer) (with-new-output-record (minibuffer) (setf (message-time minibuffer) (get-universal-time)) (filling-output (minibuffer :fill-width (bounding-rectangle-width minibuffer)) (funcall continuation minibuffer))))) (defmethod invoke-with-minibuffer-stream ((minibuffer pointer-documentation-pane) continuation) (clim-extensions:with-output-to-pointer-documentation (stream (pane-frame minibuffer)) (funcall continuation stream))) (defmethod invoke-with-minibuffer-stream ((minibuffer null) continuation) nil) (defmacro with-minibuffer-stream ((stream-symbol) &body body) "Bind `stream-symbol' to the minibuffer stream and evaluate `body'. This macro makes sure to setup the initial blanking of the minibuffer as well as taking care of for how long the message should be displayed." `(invoke-with-minibuffer-stream *minibuffer* #'(lambda (,stream-symbol) ,@body))) (defun display-message (format-string &rest format-args) "Display a message in the minibuffer. Composes the string based on the `format-string' and the `format-args'." (with-minibuffer-stream (minibuffer) (apply #'format minibuffer format-string format-args))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ESA pane mixin (defclass esa-pane-mixin () (;; allows a certain number of commands to have some minimal memory (previous-command :initform nil :accessor previous-command) (command-table :initarg :command-table :accessor command-table))) (defmethod previous-command ((pane pane)) nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Command processing (defparameter *esa-abort-gestures* `((:keyboard #\g ,(make-modifier-state :control)))) (defparameter *current-gesture* nil) (defparameter *command-processor* nil "While a command is being run, this symbol will be dynamically bound to the current command processor.") (defun find-gestures (gestures start-table) (loop with table = (find-command-table start-table) for (gesture . rest) on gestures for item = (find-keystroke-item gesture table :errorp nil) while item do (if (eq (command-menu-item-type item) :command) (return (if (null rest) item nil)) (setf table (command-menu-item-value item))) finally (return item))) (defun find-gestures-with-inheritance (gestures start-table) (or (find-gestures gestures start-table) (some (lambda (table) (find-gestures-with-inheritance gestures table)) (command-table-inherit-from (find-command-table start-table))))) ;;; In Classic CLIM event-matches-gesture-name-p doesn't accept characters. #+(or mcclim building-mcclim) (defun gesture-matches-gesture-name-p (gesture gesture-name) (event-matches-gesture-name-p gesture gesture-name)) #-(or mcclim building-mcclim) (defun gesture-matches-gesture-name-p (gesture gesture-name) (etypecase gesture (event (event-matches-gesture-name-p gesture gesture-name)) (character (clim-internals::keyboard-event-matches-gesture-name-p gesture gesture-name)))) (defvar *meta-digit-table* (loop for i from 0 to 9 collect (list :keyboard (digit-char i) (make-modifier-state :meta)))) (defun meta-digit (gesture) (position gesture *meta-digit-table* :test #'gesture-matches-gesture-name-p)) (defun proper-gesture-p (gesture) "Return non-NIL if `gesture' is a proper gesture, NIL otherwise. A proper gesture is loosely defined as any gesture that is not just the sole pressing of a modifier key." (or (characterp gesture) (and (typep gesture 'keyboard-event) (or (keyboard-event-character gesture) (not (member (keyboard-event-key-name gesture) '(:control-left :control-right :shift-left :shift-right :meta-left :meta-right :super-left :super-right :hyper-left :hyper-right :shift-lock :caps-lock :alt-left :alt-right))))))) (define-condition unbound-gesture-sequence (simple-condition) ((%gestures :initarg :gestures :reader gestures :initform '() :documentation "A list of the provided gestures that resulted in the signalling of this condition.")) (:report (lambda (condition stream) (declare (ignore condition)) (format stream "Gesture sequence that cannot possibly result in command invocation encountered."))) (:documentation "This condition is signalled during gesture processing, when a sequence of gestures has been entered that does not, and cannot by the addition of more gestures, result in preferring to a command.")) (defclass command-processor () ((%recordingp :initform nil :accessor recordingp) (%executingp :initform nil :accessor executingp) (%recorded-keys :initform '() :accessor recorded-keys) (%remaining-keys :initform '() :accessor remaining-keys) (%accumulated-gestures :initform '() :accessor accumulated-gestures) (%overriding-handler :initform nil :accessor overriding-handler :documentation "When non-NIL, any action on the command processor will be forwarded to this object.") (%command-executor :initform 'execute-frame-command :accessor command-executor :initarg :command-executor :documentation "The object used to execute commands. Will be coerced to a function and called with two arguments, the command processor and the command.")) (:documentation "The command processor is fed gestures and will execute commands or signal conditions when the provided getures unambigiously suggest one of these actions. ESA command processing works through instances of this class.")) (defgeneric process-gesture (command-processor gesture) (:documentation "Tell the command processor to process `gesture'. This might result in either the execution of a command or the signalling of `unbound-gesture-sequence'. This is the fundamental interface to the command processor.")) (defgeneric directly-processing-p (command-processor) (:documentation "Return true if `command-processor' is directly processing commands. In most cases, this means that `overriding-handler' is null.") (:method ((command-processor command-processor)) (null (overriding-handler command-processor)))) (defgeneric command-for-unbound-gestures (thing gestures) (:documentation "Called when `gestures' is input by the user and there is no associated command in the current command table. The function should return either a (possibly incomplete) command or NIL. In the latter case (which is handled by a default method), the gestures will be treated as actual unbound gestures. `Thing' is something that might be interested in commands, at the beginning usually a command processor, but it can call the function for other objects it knows in order to get their opinion. `Gestures' is a list of gestures.") (:method (thing gestures) nil)) (defclass instant-macro-execution-mixin () () (:documentation "Subclasses of this class will immediately process the gestures of a macro when macro processing is started by setting `executingp'. This is essential for event-based command processing schemes.")) (defmethod (setf executingp) :after ((new-val (eql t)) (drei instant-macro-execution-mixin)) (loop until (null (remaining-keys drei)) for gesture = (pop (remaining-keys drei)) do (process-gesture drei gesture) finally (setf (executingp drei) nil))) (defclass asynchronous-command-processor (command-processor instant-macro-execution-mixin) () (:documentation "Helper class that provides behavior necessary for a command processor that expects to receive gestures through asynchronous event handling, and not through `esa-read-gesture'.")) (defmethod process-gesture :before ((command-processor asynchronous-command-processor) gesture) (when (and (find gesture *abort-gestures* :test #'gesture-matches-gesture-name-p) (directly-processing-p command-processor)) (setf (accumulated-gestures command-processor) nil) (signal 'abort-gesture :event gesture))) (defclass dead-key-merging-command-processor (command-processor) ((%dead-key-state :accessor dead-key-state :initform nil :documentation "The state of dead key handling as per `merging-dead-keys'.")) (:documentation "Helper class useful for asynchronous command processors, merges incoming dead keys with the following key.")) (defmethod process-gesture :around ((command-processor dead-key-merging-command-processor) gesture) (merging-dead-keys (gesture (dead-key-state command-processor)) (call-next-method command-processor gesture))) (defclass command-loop-command-processor (command-processor) ((%command-table :reader command-table :initarg :command-table :initform nil) (%end-condition :reader end-condition :initarg :end-condition :initform (constantly nil) :documentation "When this function of zero arguments returns true, the `command-loop-command-processor' will disable itself in its associated super command processor and call its `end-function', effectively dropping out of the sub-command-loop.") (%end-function :reader end-function :initarg :end-function :initform (constantly nil) :documentation "This function of zero arguments will be called when the command processor disables itself.") (%abort-function :reader abort-function :initarg :abort-function :initform (constantly nil) :documentation "This function is called if the command processor encounters an abort gesture.") (%super-command-processor :reader super-command-processor :initarg :super-command-processor :initform (error "Must provide a super command processor.") :documentation "The command processor that the `command-loop-command-processor' object handles gestures for.")) (:default-initargs :command-executor #'(lambda (processor command) (funcall (command-executor (super-command-processor processor)) (super-command-processor processor) command))) (:documentation "This class is used to run sub-command-loops within the primary command loop of an application (for example, to do stuff such as incremental search).")) (defgeneric end-command-loop (command-processor) (:documentation "End the simulated command loop controlled by `command-processor'.") (:method ((command-processor command-processor)) nil)) (defmethod end-command-loop ((command-processor command-loop-command-processor)) (when (overriding-handler command-processor) (end-command-loop (overriding-handler command-processor))) (setf (overriding-handler (super-command-processor command-processor)) nil)) (defmethod process-gesture :around ((command-processor command-loop-command-processor) gesture) (cond ((find gesture *abort-gestures* :test #'gesture-matches-gesture-name-p) ;; It is to be expected that the abort function might signal ;; `abort-gesture'. If that happens, we must end the command ;; loop, but ONLY if this is signalled. (handler-case (funcall (abort-function command-processor)) (abort-gesture (c) (end-command-loop command-processor) (signal c)))) (t (call-next-method) (when (funcall (end-condition command-processor)) (funcall (end-function command-processor)) (end-command-loop command-processor))))) (defun process-gestures-for-numeric-argument (gestures) "Processes a list of gestures for numeric argument information. Returns three values: prefix argument, a bool value indicating whether prefix was given and a list of remaining gestures to handle. Accepts: EITHER C-u, optionally followed by other C-u's, optionally followed by a minus sign, optionally followed by decimal digits; OR An optional M-minus, optionally followed by M-decimal-digits. You cannot mix C-u and M-digits. C-u gives a numarg of 4. Additional C-u's multiply by 4 (e.g. C-u C-u C-u = 64). After C-u you can enter decimal digits, possibly preceded by a minus (but not a plus) sign. C-u 3 4 = 34, C-u - 3 4 = -34. Note that C-u 3 - prints 3 '-'s. M-1 M-2 = 12. M-- M-1 M-2 = -12. As a special case, C-u - and M-- = -1. In the absence of a prefix arg returns 1 (and nil)." (let ((first-gesture (pop gestures))) (cond ((gesture-matches-gesture-name-p first-gesture 'universal-argument) (let ((numarg 4)) (loop for gesture = (first gestures) while (gesture-matches-gesture-name-p gesture 'universal-argument) do (setf numarg (* 4 numarg)) (pop gestures)) (let ((gesture (pop gestures)) (sign +1)) (when (and (characterp gesture) (char= gesture #\-)) (setf gesture (pop gestures) sign -1)) (cond ((and (characterp gesture) (digit-char-p gesture 10)) (setf numarg (digit-char-p gesture 10)) (loop for gesture = (first gestures) while (and (characterp gesture) (digit-char-p gesture 10)) do (setf numarg (+ (* 10 numarg) (digit-char-p gesture 10))) (pop gestures) finally (return (values (* numarg sign) t gestures)))) (t (values (if (minusp sign) -1 numarg) t (when gesture (cons gesture gestures)))))))) ((or (meta-digit first-gesture) (gesture-matches-gesture-name-p first-gesture 'meta-minus)) (let ((numarg 0) (sign +1)) (cond ((meta-digit first-gesture) (setf numarg (meta-digit first-gesture))) (t (setf sign -1))) (loop for gesture = (first gestures) while (meta-digit gesture) do (setf numarg (+ (* 10 numarg) (meta-digit gesture))) (pop gestures) finally (return (values (if (and (= sign -1) (= numarg 0)) -1 (* sign numarg)) t gestures))))) (t (values 1 nil (when first-gesture (cons first-gesture gestures))))))) (defgeneric process-gestures (command-processor) (:documentation "Process the gestures accumulated in `command-processor', returning T if there are no gestures accumulated or the accumulated gestures correspond to a command. In this case, the command will also be executed and the list of accumulated gestures set to NIL. Will return NIL if the accumulated gestures do not yet correspond to a command, but eventually could, if more gestures are provided. Signals `unbound-gesture-sequence' if the accumulated gestures could never refer to a command.")) (defmethod process-gestures ((command-processor command-processor)) (multiple-value-bind (prefix-arg prefix-p gestures) (process-gestures-for-numeric-argument (accumulated-gestures command-processor)) (flet ((commandp (object) (or (listp object) (symbolp object)))) (cond ((null gestures) t) (t (let* ((command-table (command-table command-processor)) (item (or (find-gestures-with-inheritance gestures command-table) (command-for-unbound-gestures command-processor gestures)))) (cond ((not item) (setf (accumulated-gestures command-processor) nil) (error 'unbound-gesture-sequence :gestures gestures)) ((or (commandp item) ; c-f-u-g does not return a menu-item. (eq (command-menu-item-type item) :command)) (let ((command (if (commandp item) item (command-menu-item-value item))) (*current-gesture* (first (last gestures))) (*standard-input* (or *minibuffer* *standard-input*))) (unless (consp command) (setf command (list command))) ;; Call `*partial-command-parser*' to handle numeric ;; argument. (unwind-protect (setq command (funcall *partial-command-parser* (command-table command-processor) *standard-input* command 0 (when prefix-p prefix-arg))) ;; If we are macrorecording, store whatever the user ;; did to invoke this command. (when (recordingp command-processor) (setf (recorded-keys command-processor) (append (accumulated-gestures command-processor) (recorded-keys command-processor)))) (setf (accumulated-gestures command-processor) nil)) (funcall (command-executor command-processor) command-processor command) nil)) (t t)))))))) (defmethod process-gesture :around ((command-processor command-processor) gesture) (with-accessors ((overriding-handler overriding-handler)) command-processor (if overriding-handler (let ((*command-processor* overriding-handler)) (process-gesture overriding-handler gesture)) (call-next-method)))) (defmethod process-gesture ((command-processor command-processor) gesture) (setf (accumulated-gestures command-processor) (nconc (accumulated-gestures command-processor) (list gesture))) (process-gestures command-processor)) (defun esa-read-gesture (&key (command-processor *command-processor*) (stream *standard-input*)) (unless (null (remaining-keys command-processor)) (return-from esa-read-gesture (pop (remaining-keys command-processor)))) (loop for gesture = (read-gesture :stream stream) until (proper-gesture-p gesture) finally (return gesture))) (defun esa-unread-gesture (gesture &key (command-processor *command-processor*) (stream *standard-input*)) (cond ((recordingp command-processor) (cond ((equal (first (recorded-keys command-processor)) gesture) (pop (recorded-keys command-processor))) ((equal (first (accumulated-gestures command-processor)) gesture) (pop (accumulated-gestures command-processor)))) (unread-gesture gesture :stream stream)) ((executingp command-processor) (push gesture (remaining-keys command-processor))) (t (unread-gesture gesture :stream stream)))) (define-gesture-name universal-argument :keyboard (#\u :control)) (define-gesture-name meta-minus :keyboard (#\- :meta)) (defgeneric process-gestures-or-command (command-processor) (:documentation "Process gestures for `command-processor' (typically an application frame), look up the corresponding commands in `command-table' and invoke them using `command-executor'.")) (defmethod process-gestures-or-command :around ((command-processor application-frame)) (with-input-context ('menu-item) (object) (with-input-context (`(command :command-table ,(command-table command-processor))) (object) (call-next-method) (command (funcall (command-executor command-processor) command-processor object))) (menu-item (let ((command (command-menu-item-value object))) (unless (listp command) (setq command (list command))) (when (member *unsupplied-argument-marker* command :test #'eq) (setq command (funcall *partial-command-parser* (command-table command-processor) *standard-input* command 0))) (funcall (command-executor command-processor) command-processor command))))) (defmethod process-gestures-or-command :around ((command-processor command-processor)) (handler-case (call-next-method) (abort-gesture (c) ;; If the user aborts, we want to forget whatever previous ;; gestures he entered since the last command execution. (setf (accumulated-gestures command-processor) nil) (signal c)))) (defmethod process-gestures-or-command ((command-processor command-processor)) ;; Build up a list of gestures and repeatedly pass them to ;; `process-gestures'. This "clumsy" approach is chosen because we ;; want ESA command processing to support asynchronous operation as ;; well, something that either requires this kind of repeated ;; rescanning of accumulated input data or some yet-unimplemented ;; complex state retaining mechanism (such as continuations). (loop (let ((*current-gesture* (esa-read-gesture :command-processor command-processor))) (unless (process-gesture command-processor *current-gesture*) (return))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ESA frame mixin (defclass esa-frame-mixin (command-processor) ((windows :accessor windows))) (defmethod esa-current-buffer ((esa esa-frame-mixin)) (first (buffers esa))) (defmethod esa-current-window ((esa esa-frame-mixin)) (first (windows esa))) (defmethod command-table ((frame esa-frame-mixin)) (find-applicable-command-table frame)) ;; Defaults for non-ESA-frames. (defmethod recordingp ((frame application-frame)) nil) (defmethod executingp ((frame application-frame)) nil) (defmethod recorded-keys ((frame application-frame)) nil) (defmethod remaining-keys ((frame application-frame)) nil) (defmethod minibuffer ((application-frame esa-frame-mixin)) (frame-standard-input application-frame)) (defmethod redisplay-frame-panes :around ((frame esa-frame-mixin) &key force-p) (declare (ignore force-p)) (when (null (remaining-keys frame)) (setf (executingp frame) nil) (call-next-method))) (defmethod execute-frame-command :after ((frame esa-frame-mixin) command) ;; FIXME: I'm not sure that we want to do this for commands sent ;; from other threads; we almost certainly don't want to do it twice ;; in such cases... (setf (previous-command (esa-current-window frame)) command)) (defmethod execute-frame-command :around ((frame esa-frame-mixin) command) (call-next-method) (when (eq frame *application-frame*) (redisplay-frame-panes frame))) (defgeneric find-applicable-command-table (frame) (:documentation "Return the command table object that commands on `frame' should be found in.")) (defmethod find-applicable-command-table ((frame esa-frame-mixin)) (command-table (car (windows frame)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Top level (defvar *extended-command-prompt* "The prompt used when querying the user for an extended command. This only applies when the ESA command parser is being used.") (defgeneric esa-top-level (frame &key command-parser command-unparser partial-command-parser prompt) (:documentation "Run a top-level loop for `frame', reading gestures and invoking the appropriate commands.")) (defmacro define-esa-top-level ((frame command-parser command-unparser partial-command-parser prompt) &key bindings) `(defmethod esa-top-level (,frame &key (,command-parser 'esa-command-parser) ;; FIXME: maybe customize this? Under what ;; circumstances would it be used? Maybe try ;; turning the clim listener into an ESA? (,command-unparser 'command-line-command-unparser) (,partial-command-parser 'esa-partial-command-parser) (,prompt "Extended Command: ")) ,(let ((frame (unlisted frame))) `(with-slots (windows) ,frame (let ((*standard-output* (car windows)) (*standard-input* (frame-standard-input ,frame)) (*minibuffer* (minibuffer ,frame)) (*print-pretty* nil) (*abort-gestures* *esa-abort-gestures*) (*command-parser* ,command-parser) (*command-unparser* ,command-unparser) (*partial-command-parser* ,partial-command-parser) (*extended-command-prompt* ,prompt) (*pointer-documentation-output* (frame-pointer-documentation-output ,frame)) (*esa-instance* ,frame)) (unless (eq (frame-state ,frame) :enabled) (enable-frame ,frame)) (redisplay-frame-panes ,frame :force-p t) (loop do (restart-case (handler-case (let* ((*command-processor* ,frame) (command-table (find-applicable-command-table ,frame)) ,@bindings) ;; for presentation-to-command-translators, ;; which are searched for in ;; (frame-command-table *application-frame*) (redisplay-frame-pane ,frame (frame-standard-input ,frame)) (setf (frame-command-table ,frame) command-table) (process-gestures-or-command ,frame)) (unbound-gesture-sequence (c) (display-message "~A is not bound" (gesture-name (gestures c))) (redisplay-frame-panes ,frame)) (abort-gesture (c) (if (overriding-handler ,frame) (let ((*command-processor* (overriding-handler ,frame))) (process-gesture (overriding-handler ,frame) (climi::%abort-gesture-event c))) (display-message "Quit")) (redisplay-frame-panes ,frame))) (return-to-esa () (setf (overriding-handler ,frame) nil) (setf (remaining-keys ,frame) nil))))))))) (define-esa-top-level (frame command-parser command-unparser partial-command-parser prompt)) (defmacro simple-command-loop (command-table loop-condition &optional end-clauses (abort-clauses '((signal 'abort-gesture :event *current-gesture*)))) `(progn (setf (overriding-handler *command-processor*) (make-instance 'command-loop-command-processor :command-table ,command-table :end-condition #'(lambda () (not ,loop-condition)) :super-command-processor *command-processor* :end-function #'(lambda () ,@end-clauses) :abort-function #'(lambda () ,@abort-clauses))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Event handling. (defgeneric convert-to-gesture (event) (:documentation "Convert `event' (which must be an input event) to a CLIM gesture, or NIL, if this is not possible.")) (defmethod convert-to-gesture ((ev event)) nil) (defmethod convert-to-gesture ((ev character)) ev) (defmethod convert-to-gesture ((ev symbol)) ev) (defmethod convert-to-gesture ((ev key-press-event)) (let ((modifiers (event-modifier-state ev)) (event ev) (char nil)) (when (or (zerop modifiers) (eql modifiers +shift-key+)) (setq char (keyboard-event-character ev))) (if char #+(or mcclim building-mcclim) (climi::char-for-read char) #-(or mcclim building-mcclim) char event))) (defmethod convert-to-gesture ((ev pointer-button-press-event)) ev) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; command table manipulation ;;; Helper to avoid calling find-keystroke-item at load time. In Classic CLIM ;;; that function doesn't work if not connected to a port. (defun compare-gestures (g1 g2) (and (eql (car g1) (car g2)) (eql (apply #'make-modifier-state (cdr g1)) (apply #'make-modifier-state (cdr g2))))) (defun find-gesture-item (table gesture) (map-over-command-table-keystrokes (lambda (name gest item) (declare (ignore name)) (when (compare-gestures gesture gest) (return-from find-gesture-item item))) table) nil) #-(or mcclim building-mcclim) (defun ensure-subtable (table gesture) (let ((item (find-gesture-item table gesture))) (when (or (null item) (not (eq (command-menu-item-type item) :menu))) (let ((name (gensym))) (make-command-table name :errorp nil) (add-menu-item-to-command-table table (symbol-name name) :menu name :keystroke gesture))) (command-menu-item-value (find-gesture-item table gesture)))) #+(or mcclim building-mcclim) (defun ensure-subtable (table gesture) (let* ((event (make-instance 'key-press-event :key-name nil :key-character (car gesture) :modifier-state (apply #'make-modifier-state (cdr gesture)))) (item (find-keystroke-item event table :errorp nil))) (when (or (null item) (not (eq (command-menu-item-type item) :menu))) (let ((name (gensym))) (make-command-table name :errorp nil) (add-menu-item-to-command-table table (symbol-name name) :menu name :keystroke gesture))) (command-menu-item-value (find-keystroke-item event table :errorp nil)))) (defun set-key (command table gestures) ;; WTF? #-(and) (unless (consp command) (setf command (list command))) (let ((gesture (car gestures))) (cond ((null (cdr gestures)) (add-keystroke-to-command-table table gesture :command command :errorp nil) (when (and (listp gesture) (find :meta gesture)) ;; KLUDGE: this is a workaround for poor McCLIM ;; behaviour; really this canonization should happen in ;; McCLIM's input layer. (set-key command table (list (list :escape) (let ((esc-list (remove :meta gesture))) (if (and (= (length esc-list) 2) (find :shift esc-list)) (remove :shift esc-list) esc-list)))))) (t (set-key command (ensure-subtable table gesture) (cdr gestures)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; standard key bindings ;;; global (define-command-table global-esa-table) (define-command (com-quit :name t :command-table global-esa-table) () "Exit. First ask if modified buffers should be saved. If you decide not to save a modified buffer, you will be asked to confirm your decision to exit." (frame-exit *application-frame*)) (set-key 'com-quit 'global-esa-table '((#\x :control) (#\c :control))) (define-command (com-extended-command :command-table global-esa-table) () "Prompt for a command name and arguments, then run it." (let ((item (handler-case (accept `(command :command-table ,(find-applicable-command-table *application-frame*)) ;; this gets erased immediately anyway :prompt "" :prompt-mode :raw) ((or command-not-accessible command-not-present) () (beep) (display-message "No such command") (return-from com-extended-command nil))))) (execute-frame-command *application-frame* item))) (set-key 'com-extended-command 'global-esa-table '((#\x :meta))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Help (defgeneric invoke-with-help-stream (esa title continuation) (:documentation "Invoke `continuation' with a single argument - a stream for writing on-line help for `esa' onto. The stream should have the title, or name, `title' (a string), but the specific meaning of this is left to the respective ESA.")) (defmethod invoke-with-help-stream (frame title continuation) (funcall continuation (open-window-stream :label title :input-buffer (#+(or mcclim building-mcclim) climi::frame-event-queue #-(or mcclim building-mcclim) silica:frame-input-buffer *application-frame*) :width 400))) (defmacro with-help-stream ((stream title) &body body) "Evaluate `body' with `stream' bound to a stream suitable for writing help information on. `Title' must evaluate to a string, and will be used for naming the resulting stream, if that makes sense for the ESA." `(invoke-with-help-stream *esa-instance* ,title #'(lambda (,stream) ,@body))) (defun read-gestures-for-help (command-table) (with-input-focus (t) (loop for gestures = (list (esa-read-gesture)) then (nconc gestures (list (esa-read-gesture))) for item = (find-gestures-with-inheritance gestures command-table) unless item do (return (values nil gestures)) when (eq (command-menu-item-type item) :command) do (return (values (command-menu-item-value item) gestures))))) (defun describe-key-briefly (frame) (let ((command-table (find-applicable-command-table frame))) (multiple-value-bind (command gestures) (read-gestures-for-help command-table) (when (consp command) (setf command (car command))) (display-message "~{~A ~}~:[is not bound~;runs the command ~:*~A~]" (mapcar #'gesture-name gestures) (or (command-line-name-for-command command command-table :errorp nil) command))))) (defgeneric gesture-name (gesture)) (defmethod gesture-name ((char character)) (if (and (graphic-char-p char) (not (char= char #\Space))) (string char) (or (char-name char) char))) (defun translate-name-and-modifiers (key-name modifiers) (with-output-to-string (s) (loop for (modifier name) on (list ;(+alt-key+ "A-") +hyper-key+ "H-" +super-key+ "s-" +meta-key+ "M-" +control-key+ "C-") by #'cddr when (plusp (logand modifier modifiers)) do (princ name s)) (princ (if (typep key-name 'character) (gesture-name key-name) key-name) s))) (defmethod gesture-name ((ev keyboard-event)) (let ((key-name (keyboard-event-key-name ev)) (modifiers (event-modifier-state ev))) (translate-name-and-modifiers key-name modifiers))) (defmethod gesture-name ((gesture list)) (cond ((eq (car gesture) :keyboard) (translate-name-and-modifiers (second gesture) (third gesture))) ;; Assume `gesture' is a list of gestures. (t (format nil "~{~A~#[~; ~; ~]~}" (mapcar #'gesture-name gesture))))) (defun find-keystrokes-for-command (command command-table) (let ((keystrokes '())) (labels ((helper (command command-table prefix) (map-over-command-table-keystrokes #'(lambda (menu-name keystroke item) (declare (ignore menu-name)) (cond ((and (eq (command-menu-item-type item) :command) (or (and (symbolp (command-menu-item-value item)) (eq (command-menu-item-value item) command)) (and (listp (command-menu-item-value item)) (eq (car (command-menu-item-value item)) command)))) (push (cons keystroke prefix) keystrokes)) ((eq (command-menu-item-type item) :menu) (helper command (command-menu-item-value item) (cons keystroke prefix))) (t nil))) command-table))) (helper command command-table nil) keystrokes))) (defun find-keystrokes-for-command-with-inheritance (command start-table) (let ((keystrokes '())) (labels ((helper (table) (let ((keys (find-keystrokes-for-command command table))) (when keys (push keys keystrokes)) (dolist (subtable (command-table-inherit-from (find-command-table table))) (helper subtable))))) (helper start-table)) keystrokes)) (defun find-all-keystrokes-and-commands (command-table) (let ((results '())) (labels ((helper (command-table prefix) (map-over-command-table-keystrokes #'(lambda (menu-name keystroke item) (declare (ignore menu-name)) (cond ((eq (command-menu-item-type item) :command) (push (cons (cons keystroke prefix) (command-menu-item-value item)) results)) ((eq (command-menu-item-type item) :menu) (helper (command-menu-item-value item) (cons keystroke prefix))) (t nil))) command-table))) (helper command-table nil) results))) (defun find-all-keystrokes-and-commands-with-inheritance (start-table) (let ((results '())) (labels ((helper (table) (let ((res (find-all-keystrokes-and-commands table))) (when res (setf results (nconc res results))) (dolist (subtable (command-table-inherit-from (find-command-table table))) (helper subtable))))) (helper start-table)) results)) (defun find-all-commands-and-keystrokes-with-inheritance (start-table) (let ((results '())) (map-over-command-table-commands (lambda (command) (let ((keys (find-keystrokes-for-command-with-inheritance command start-table))) (push (cons command keys) results))) start-table :inherited t) results)) (defun sort-by-name (list) (sort list #'string< :key (lambda (item) (symbol-name (if (listp (cdr item)) (cadr item) (cdr item)))))) (defun sort-by-keystrokes (list) (sort list (lambda (a b) (cond ((and (characterp a) (characterp b)) (char< a b)) ((characterp a) t) ((characterp b) nil) (t (string< (symbol-name a) (symbol-name b))))) :key (lambda (item) (second (first (first item)))))) (defun describe-bindings (stream command-table &optional (sort-function #'sort-by-name)) (formatting-table (stream) (loop for (keys . command) in (funcall sort-function (find-all-keystrokes-and-commands-with-inheritance command-table)) when (consp command) do (setq command (car command)) do (formatting-row (stream) (formatting-cell (stream :align-x :right) (with-text-style (stream '(:sans-serif nil nil)) (present command `(command-name :command-table ,command-table) :stream stream))) (formatting-cell (stream) (with-drawing-options (stream :ink +dark-blue+ :text-style '(:fix nil nil)) (format stream "~&~{~A~^ ~}" (mapcar #'gesture-name (reverse keys)))))) count command into length finally (change-space-requirements stream :height (* length (stream-line-height stream))) (scroll-extent stream 0 0)))) (defun print-docstring-for-command (command-name command-table &optional (stream *standard-output*)) "Print documentation for `command-name', which should be a symbol bound to a function, to `stream'. If no documentation can be found, this fact will be printed to the stream." (declare (ignore command-table)) ;; This needs more regex magic. Also, it is only an interim ;; solution. (with-text-style (stream '(:sans-serif nil nil)) (let* ((command-documentation (or (documentation command-name 'function) "This command is not documented.")) (first-newline (position #\Newline command-documentation)) (first-line (subseq command-documentation 0 first-newline))) ;; First line is special (format stream "~A~%" first-line) (when first-newline (let* ((rest (subseq command-documentation first-newline)) (paras (delete "" (loop for start = 0 then (+ 2 end) for end = (search '(#\Newline #\Newline) rest :start2 start) collecting (nsubstitute #\Space #\Newline (subseq rest start end)) while end) :test #'string=))) (dolist (para paras) (terpri stream) (let ((words (loop with length = (length para) with index = 0 with start = 0 while (< index length) do (loop until (>= index length) while (member (char para index) '(#\Space #\Tab)) do (incf index)) (setf start index) (loop until (>= index length) until (member (char para index) '(#\Space #\Tab)) do (incf index)) until (= start index) collecting (string-trim '(#\Space #\Tab #\Newline) (subseq para start index))))) (loop with margin = (stream-text-margin stream) with space-width = (stream-character-width stream #\Space) with current-width = 0 for word in words for word-width = (stream-string-width stream word) when (> (+ word-width current-width) margin) do (terpri stream) (setf current-width 0) do (princ word stream) (princ #\Space stream) (incf current-width (+ word-width space-width)))) (terpri stream))))))) (defun describe-command-binding-to-stream (gesture command &key (command-table (find-applicable-command-table *application-frame*)) (stream *standard-output*)) "Describe `command' as invoked by `gesture' to `stream'." (let* ((command-name (if (listp command) (first command) command)) (command-args (if (listp command) (rest command))) (real-command-table (or (command-accessible-in-command-table-p command-name command-table) command-table))) (with-text-style (stream '(:sans-serif nil nil)) (princ "The gesture " stream) (with-drawing-options (stream :ink +dark-blue+ :text-style '(:fix nil nil)) (princ gesture stream)) (princ " is bound to the command " stream) (if (command-present-in-command-table-p command-name real-command-table) (with-text-style (stream '(nil :bold nil)) (present command-name `(command-name :command-table ,command-table) :stream stream)) (present command-name 'symbol :stream stream)) (princ " in " stream) (present real-command-table 'command-table :stream stream) (format stream ".~%") (when command-args (apply #'format stream "This binding invokes the command with these arguments: ~@{~A~^, ~}.~%" (mapcar #'(lambda (arg) (cond ((eq arg *unsupplied-argument-marker*) "unsupplied-argument") ((eq arg *numeric-argument-marker*) "numeric-argument") (t arg))) command-args))) (terpri stream) (print-docstring-for-command command-name command-table stream) (scroll-extent stream 0 0)))) (defun describe-command-to-stream (command-name &key (command-table (find-applicable-command-table *application-frame*)) (stream *standard-output*)) "Describe `command' to `stream'." (let ((keystrokes (find-keystrokes-for-command-with-inheritance command-name command-table))) (with-text-style (stream '(:sans-serif nil nil)) (with-text-style (stream '(nil :bold nil)) (present command-name `(command-name :command-table ,command-table) :stream stream)) (princ " calls the function " stream) (present command-name 'symbol :stream stream) (princ " and is accessible in " stream) (if (command-accessible-in-command-table-p command-name command-table) (present (command-accessible-in-command-table-p command-name command-table) 'command-table :stream stream) (princ "an unknown command table" stream)) (format stream ".~%") (when (plusp (length keystrokes)) (princ "It is bound to " stream) (loop for gestures-list on (first keystrokes) do (with-drawing-options (stream :ink +dark-blue+ :text-style '(:fix nil nil)) (format stream "~{~A~^ ~}" (mapcar #'gesture-name (reverse (first gestures-list))))) when (not (null (rest gestures-list))) do (princ ", " stream)) (terpri stream)) (terpri stream) (print-docstring-for-command command-name command-table stream) (scroll-extent stream 0 0)))) ;;; help commands (define-command-table help-table) (define-command (com-describe-key-briefly :name t :command-table help-table) () "Prompt for a key and show the command it invokes." (display-message "Describe key briefly:") (redisplay-frame-panes *application-frame*) (describe-key-briefly *application-frame*)) (set-key 'com-describe-key-briefly 'help-table '((#\h :control) (#\c))) (define-command (com-where-is :name t :command-table help-table) () "Prompt for a command name and show the key that invokes it." (let* ((command-table (find-applicable-command-table *application-frame*)) (command (handler-case (accept `(command-name :command-table ,command-table) :prompt "Where is command") (error () (progn (beep) (display-message "No such command") (return-from com-where-is nil))))) (keystrokes (find-keystrokes-for-command-with-inheritance command command-table))) (display-message "~A is ~:[not on any key~;~:*on ~{~A~^, ~}~]" (command-line-name-for-command command command-table) (mapcar (lambda (keys) (format nil "~{~A~^ ~}" (mapcar #'gesture-name (reverse keys)))) (car keystrokes))))) (set-key 'com-where-is 'help-table '((#\h :control) (#\w))) (define-command (com-describe-bindings :name t :command-table help-table) ((sort-by-keystrokes 'boolean :prompt "Sort by keystrokes?")) "Show which keys invoke which commands. Without a numeric prefix, sorts the list by command name. With a numeric prefix, sorts by key." (let ((command-table (find-applicable-command-table *application-frame*))) (with-help-stream (stream (format nil "Help: Describe Bindings")) (describe-bindings stream command-table (if sort-by-keystrokes #'sort-by-keystrokes #'sort-by-name))))) (set-key `(com-describe-bindings ,*numeric-argument-marker*) 'help-table '((#\h :control) (#\b))) (define-command (com-describe-key :name t :command-table help-table) () "Display documentation for the command invoked by a given gesture sequence. When invoked, this command will wait for user input. If the user inputs a gesture sequence bound to a command available in the syntax of the current buffer, documentation and other details will be displayed in a typeout pane." (let ((command-table (find-applicable-command-table *application-frame*))) (display-message "Describe Key:") (redisplay-frame-panes *application-frame*) (multiple-value-bind (command gestures) (read-gestures-for-help command-table) (let ((gesture-name (format nil "~{~A~#[~; ~; ~]~}" (mapcar #'gesture-name gestures)))) (if command (with-help-stream (out-stream (format nil "~10THelp: Describe Key for ~A" gesture-name)) (describe-command-binding-to-stream gesture-name command :command-table command-table :stream out-stream)) (display-message "Unbound gesture: ~A" gesture-name)))))) (set-key 'com-describe-key 'help-table '((#\h :control) (#\k))) (define-command (com-describe-command :name t :command-table help-table) ((command 'command-name :prompt "Describe command")) "Display documentation for the given command." (let ((command-table (find-applicable-command-table *application-frame*))) (with-help-stream (out-stream (format nil "~10THelp: Describe Command for ~A" (command-line-name-for-command command command-table :errorp nil))) (describe-command-to-stream command :command-table command-table :stream out-stream)))) (set-key `(com-describe-command ,*unsupplied-argument-marker*) 'help-table '((#\h :control) (#\f))) (define-presentation-to-command-translator describe-command (command-name com-describe-command help-table :gesture :select :documentation "Describe command") (object) (list object)) (define-command (com-apropos-command :name t :command-table help-table) ((words '(sequence string) :prompt "Search word(s)")) "Shows commands with documentation matching the search words. Words are comma delimited. When more than two words are given, the documentation must match any two." ;; 23.8.6 "It is unspecified whether accept returns a list or a vector." (setf words (coerce words 'list)) (when words (let* ((command-table (find-applicable-command-table *application-frame*)) (results (loop for (function . keys) in (find-all-commands-and-keystrokes-with-inheritance command-table) when (consp function) do (setq function (car function)) when (let ((documentation (or (documentation function 'function) "")) (score 0)) (cond ((> (length words) 1) (loop for word in words until (> score 1) when (or (search word (symbol-name function) :test #'char-equal) (search word documentation :test #'char-equal)) do (incf score) finally (return (> score 1)))) (t (or (search (first words) (symbol-name function) :test #'char-equal) (search (first words) documentation :test #'char-equal))))) collect (cons function keys)))) (if (null results) (display-message "No results for ~{~A~^, ~}" words) (with-help-stream (out-stream (format nil "~10THelp: Apropos ~{~A~^, ~}" words)) (loop for (command . keys) in results for documentation = (or (documentation command 'function) "Not documented.") do (with-text-style (out-stream '(:sans-serif :bold nil)) (present command `(command-name :command-table ,command-table) :stream out-stream)) (with-drawing-options (out-stream :ink +dark-blue+ :text-style '(:fix nil nil)) (format out-stream "~30T~:[M-x ... RETURN~;~:*~{~A~^, ~}~]" (mapcar (lambda (keystrokes) (format nil "~{~A~^ ~}" (mapcar #'gesture-name (reverse keystrokes)))) (car keys)))) (with-text-style (out-stream '(:sans-serif nil nil)) (format out-stream "~&~2T~A~%" (subseq documentation 0 (position #\Newline documentation)))) count command into length finally (change-space-requirements out-stream :height (* length (stream-line-height out-stream))) (scroll-extent out-stream 0 0))))))) (set-key `(com-apropos-command ,*unsupplied-argument-marker*) 'help-table '((#\h :control) (#\a))) (define-menu-table help-menu-table (help-table) 'com-where-is '(com-describe-bindings nil) '(com-describe-bindings t) 'com-describe-key `(com-describe-command ,*unsupplied-argument-marker*) `(com-apropos-command ,*unsupplied-argument-marker*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Keyboard macros (define-command-table keyboard-macro-table) (define-command (com-start-kbd-macro :name t :command-table keyboard-macro-table) () "Start recording keys to define a keyboard macro. Use C-x ) to finish recording the macro, and C-x e to run it." (setf (recordingp *command-processor*) t) (setf (recorded-keys *command-processor*) '())) (set-key 'com-start-kbd-macro 'keyboard-macro-table '((#\x :control) #\()) (define-command (com-end-kbd-macro :name t :command-table keyboard-macro-table) () "Finish recording keys that define a keyboard macro. Use C-x ( to start recording a macro, and C-x e to run it." (setf (recordingp *command-processor*) nil) (setf (recorded-keys *command-processor*) ;; this won't work if the command was invoked in any old way (reverse (cddr (recorded-keys *command-processor*))))) (set-key 'com-end-kbd-macro 'keyboard-macro-table '((#\x :control) #\))) (define-command (com-call-last-kbd-macro :name t :command-table keyboard-macro-table) ((count 'integer :prompt "How many times?" :default 1)) "Run the last keyboard macro that was defined. Use C-x ( to start and C-x ) to finish recording a keyboard macro." (setf (remaining-keys *command-processor*) (loop repeat count append (recorded-keys *command-processor*))) (setf (executingp *command-processor*) t)) (set-key `(com-call-last-kbd-macro ,*numeric-argument-marker*) 'keyboard-macro-table '((#\x :control) #\e)) (define-menu-table keyboard-macro-menu-table (keyboard-macro-table) 'com-start-kbd-macro 'com-end-kbd-macro `(com-call-last-kbd-macro ,*unsupplied-argument-marker*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; example application (defclass example-info-pane (info-pane) () (:default-initargs :height 20 :max-height 20 :min-height 20 :display-function 'display-info :incremental-redisplay t)) (defun display-info (frame pane) (declare (ignore frame)) (format pane "Pane name: ~s" (pane-name (master-pane pane)))) (defclass example-minibuffer-pane (minibuffer-pane) () (:default-initargs :height 20 :max-height 20 :min-height 20)) (defclass example-pane (esa-pane-mixin application-pane) ((contents :initform "hello" :accessor contents))) (define-application-frame example (esa-frame-mixin standard-application-frame) () (:panes (window (let* ((my-pane (make-pane 'example-pane :width 900 :height 400 :display-function 'display-my-pane :command-table 'global-example-table)) (my-info-pane (make-pane 'example-info-pane :master-pane my-pane :width 900))) (setf (windows *application-frame*) (list my-pane)) (vertically () (scrolling () my-pane) my-info-pane))) (minibuffer (make-pane 'example-minibuffer-pane :width 900))) (:layouts (default (vertically (:scroll-bars nil) window minibuffer))) (:top-level (esa-top-level))) (defun display-my-pane (frame pane) (declare (ignore frame)) (princ (contents pane) *standard-output*)) (defun example (&key (width 900) (height 400)) "Starts up the example application" (let ((frame (make-application-frame 'example :width width :height height))) (run-frame-top-level frame))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Commands and key bindings (define-command-table global-example-table :inherit-from (global-esa-table keyboard-macro-table)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/bezier.lisp0000640000175000017500000007311110705412611017144 0ustar pdmpdm(in-package :clim-internals) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Utilities (defun point-to-complex (point) "convert a point to a complex number" (complex (point-x point) (point-y point))) (defun complex-to-point (complex) "convert a complex number to a point" (make-point (realpart complex) (imagpart complex))) (defun distance (p0 p1) "return the euclidian distance between two points" (multiple-value-bind (x0 y0) (point-position p0) (multiple-value-bind (x1 y1) (point-position p1) (let* ((dx (- x1 x0)) (dx2 (* dx dx)) (dy (- y1 y0)) (dy2 (* dy dy))) (sqrt (+ dx2 dy2)))))) (defun part-way (p0 p1 alpha) "return a point that is part way between two other points" (multiple-value-bind (x0 y0) (point-position p0) (multiple-value-bind (x1 y1) (point-position p1) (make-point (+ (* (- 1 alpha) x0) (* alpha x1)) (+ (* (- 1 alpha) y0) (* alpha y1)))))) (defun dot-dist (p p0 p1) "dot distance between a point and a line" (let ((dx (- (point-x p1) (point-x p0))) (dy (- (point-y p1) (point-y p0)))) (- (* (point-x p) dy) (* (point-y p) dx)))) (defun solve-quadratic (a2 a1 a0 &key complex-roots multiple-roots) (when (zerop a2) (return-from solve-quadratic (- (/ a0 a1)))) (unless (= a2 1) (setf a1 (/ a1 a2) a0 (/ a0 a2))) (let* ((-a1/2 (- (/ a1 2.0))) (r (- (* -a1/2 -a1/2) a0))) (cond ((zerop r) (if multiple-roots (values -a1/2 -a1/2) -a1/2)) ((minusp r) (if complex-roots (values (+ -a1/2 (sqrt r)) (- -a1/2 (sqrt r))) (values))) (t (values (+ -a1/2 (sqrt r)) (- -a1/2 (sqrt r))))))) (defun dist (v z) "compute the distance between a point and a vector represented as a complex number" (- (* (realpart z) (point-y v)) (* (imagpart z) (point-x v)))) (defclass bezier-design (design) ((%or :accessor original-region :initform nil))) (defgeneric medium-draw-bezier-design* (stream design)) (defclass bezier-design-output-record (standard-graphics-displayed-output-record) ((stream :initarg :stream) (design :initarg :design))) (defmethod initialize-instance :after ((record bezier-design-output-record) &key) (with-slots (design) record (setf (rectangle-edges* record) (bounding-rectangle* design)))) (defmethod medium-draw-bezier-design* :around ((stream output-recording-stream) design) (with-sheet-medium (medium stream) (let ((transformed-design (transform-region (medium-transformation medium) design))) (when (stream-recording-p stream) (let ((record (make-instance 'bezier-design-output-record :stream stream :design transformed-design))) (stream-add-output-record stream record))) (when (stream-drawing-p stream) (medium-draw-bezier-design* medium design))))) (defmethod medium-draw-bezier-design* :around ((medium transform-coordinates-mixin) design) (let* ((tr (medium-transformation medium)) (design (transform-region tr design))) (call-next-method medium design))) (defmethod replay-output-record ((record bezier-design-output-record) stream &optional (region +everywhere+) (x-offset 0) (y-offset 0)) (declare (ignore x-offset y-offset region)) (with-slots (design) record (medium-draw-bezier-design* (sheet-medium stream) design))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Bezier curves and areas (defclass bezier-segment () ((p0 :initarg :p0) (p1 :initarg :p1) (p2 :initarg :p2) (p3 :initarg :p3))) (defun make-bezier-segment (p0 p1 p2 p3) (make-instance 'bezier-segment :p0 p0 :p1 p1 :p2 p2 :p3 p3)) (defclass bounding-rectangle-mixin () ((min-x) (min-y) (max-x) (max-y))) (defmethod bounding-rectangle* ((region bounding-rectangle-mixin)) (with-slots (min-x min-y max-x max-y) region (values min-x min-y max-x max-y))) (defclass segments-mixin (bounding-rectangle-mixin) ((%segments :initarg :segments :initform '() :reader %segments))) (defmethod compute-bounding-rectangle* ((segments-mixin segments-mixin)) (multiple-value-bind (final-min-x final-min-y final-max-x final-max-y) (segment-bounding-rectangle (car (%segments segments-mixin))) (loop for segment in (cdr (%segments segments-mixin)) do (multiple-value-bind (min-x min-y max-x max-y) (segment-bounding-rectangle segment) (setf final-min-x (min final-min-x min-x) final-min-y (min final-min-y min-y) final-max-x (max final-max-x max-x) final-max-y (max final-max-y max-y)))) (values final-min-x final-min-y final-max-x final-max-y))) (defmethod initialize-instance :after ((region segments-mixin) &rest args) (declare (ignore args)) (multiple-value-bind (computed-min-x computed-min-y computed-max-x computed-max-y) (compute-bounding-rectangle* region) (with-slots (min-x min-y max-x max-y) region (setf min-x computed-min-x min-y computed-min-y max-x computed-max-x max-y computed-max-y)))) ;;; a path defined as a sequence of Bezier curve segments (defclass bezier-curve (path segments-mixin bounding-rectangle-mixin) ()) (defun make-bezier-thing (class point-seq) (assert (= (mod (length point-seq) 3) 1)) (make-instance class :segments (loop for (p0 p1 p2 p3) on point-seq by #'cdddr until (null p1) collect (make-bezier-segment p0 p1 p2 p3)))) (defun make-bezier-thing* (class coord-seq) (assert (= (mod (length coord-seq) 6) 2)) (make-instance class :segments (loop for (x0 y0 x1 y1 x2 y2 x3 y3 x4 y4) on coord-seq by #'(lambda (x) (nthcdr 6 x)) until (null x1) collect (make-bezier-segment (make-point x0 y0) (make-point x1 y1) (make-point x2 y2) (make-point x3 y3))))) (defun make-bezier-curve (point-seq) (make-bezier-thing 'bezier-curve point-seq)) (defun make-bezier-curve* (coord-seq) (make-bezier-thing* 'bezier-curve coord-seq)) (defun transform-segment (transformation segment) (with-slots (p0 p1 p2 p3) segment (make-bezier-segment (transform-region transformation p0) (transform-region transformation p1) (transform-region transformation p2) (transform-region transformation p3)))) (defmethod transform-region (transformation (path bezier-curve)) (make-instance 'bezier-curve :segments (mapcar (lambda (segment) (transform-segment transformation segment)) (%segments path)))) (defmethod region-equal ((p1 point) (p2 point)) (let ((coordinate-epsilon (* #.(expt 2 10) double-float-epsilon))) (and (<= (abs (- (point-x p1) (point-x p2))) coordinate-epsilon) (<= (abs (- (point-y p1) (point-y p2))) coordinate-epsilon)))) (defmethod region-union ((r1 bezier-curve) (r2 bezier-curve)) (let ((p (slot-value (car (last (%segments r1))) 'p3)) (seg (car (%segments r2)))) (if (region-equal p (slot-value seg 'p0)) (with-slots (p1 p2 p3) seg (make-instance 'bezier-curve :segments (append (%segments r1) (cons (make-bezier-segment p p1 p2 p3) (cdr (%segments r2)))))) (call-next-method)))) ;;; an area defined as a closed path of Bezier curve segments (defclass bezier-area (area bezier-design segments-mixin bounding-rectangle-mixin) ((%trans :initarg :transformation :reader transformation :initform +identity-transformation+))) (defgeneric close-path (path)) (defmethod close-path ((path bezier-curve)) (let ((segments (%segments path))) (assert (region-equal (slot-value (car segments) 'p0) (slot-value (car (last segments)) 'p3))) (make-instance 'bezier-area :segments segments))) (defun path-start (path) (slot-value (car (%segments path)) 'p0)) (defun path-end (path) (slot-value (car (last (%segments path))) 'p3)) (defun make-bezier-area (point-seq) (assert (region-equal (car point-seq) (car (last point-seq)))) (make-bezier-thing 'bezier-area point-seq)) (defun make-bezier-area* (coord-seq) (assert (and (coordinate= (car coord-seq) (car (last coord-seq 2))) (coordinate= (cadr coord-seq) (car (last coord-seq))))) (make-bezier-thing* 'bezier-area coord-seq)) (defmethod segments ((area bezier-area)) (let ((tr (transformation area))) (mapcar (lambda (s) (transform-segment tr s)) (%segments area)))) (defmethod transform-region (transformation (area bezier-area)) (let* ((tr (transformation area)) (result (if (translation-transformation-p transformation) (make-instance 'bezier-area :segments (%segments area) :transformation (compose-transformations transformation tr)) (make-instance 'bezier-area :segments (mapcar (lambda (s) (transform-segment transformation s)) (segments area)))))) (when (translation-transformation-p transformation) (setf (original-region result) (or (original-region area) area))) result)) (defmethod compute-bounding-rectangle* ((area bezier-area)) (multiple-value-bind (lx ly ux uy) (call-next-method) (let ((tr (transformation area))) (transform-rectangle* tr lx ly ux uy)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Special cases of combined Bezier areas ;;; A union of bezier areas. This is not itself a bezier area. (defclass bezier-union (area bezier-design) ((%trans :initarg :transformation :reader transformation :initform +identity-transformation+) (%areas :initarg :areas :initform '() :reader areas))) (defmethod transform-region (transformation (union bezier-union)) (let* ((tr (transformation union)) (new-tr (compose-transformations transformation tr)) (result (if (translation-transformation-p transformation) (make-instance 'bezier-union :areas (areas union) :transformation new-tr) (make-instance 'bezier-union :areas (loop for area in (areas union) collect (transform-region new-tr area)))))) (when (translation-transformation-p transformation) (setf (original-region result) (or (original-region union) union))) result)) (defun bounding-rectangle-of-areas (areas) (multiple-value-bind (final-min-x final-min-y final-max-x final-max-y) (bounding-rectangle* (car areas)) (loop for area in (cdr areas) do (multiple-value-bind (min-x min-y max-x max-y) (bounding-rectangle* area) (setf final-min-x (min final-min-x min-x) final-min-y (min final-min-y min-y) final-max-x (max final-max-x max-x) final-max-y (max final-max-y max-y)))) (values final-min-x final-min-y final-max-x final-max-y))) (defmethod bounding-rectangle* ((design bezier-union)) (multiple-value-bind (lx ly ux uy) (bounding-rectangle-of-areas (areas design)) (transform-rectangle* (transformation design) lx ly ux uy))) (defmethod region-union ((r1 bezier-area) (r2 bezier-area)) (make-instance 'bezier-union :areas (list r1 r2))) (defmethod region-union ((r1 bezier-union) (r2 bezier-area)) (let ((tr (transformation r1))) (make-instance 'bezier-union :areas (cons (untransform-region tr r2) (areas r1)) :transformation tr))) (defmethod region-union ((r1 bezier-area) (r2 bezier-union)) (let ((tr (transformation r2))) (make-instance 'bezier-union :areas (cons (untransform-region tr r1) (areas r2)) :transformation tr))) (defmethod region-union ((r1 bezier-union) (r2 bezier-union)) (let ((tr1 (transformation r1)) (tr2 (transformation r2))) (if (transformation-equal tr1 tr2) (make-instance 'bezier-union :areas (append (areas r1) (areas r2)) :transformation tr1) (let ((len1 (length (areas r1))) (len2 (length (areas r2)))) (if (> len2 len1) (make-instance 'bezier-union :areas (append (mapcar (lambda (r) (untransform-region tr2 (transform-region tr1 r))) (areas r1)) (areas r2)) :transformation tr2) (make-instance 'bezier-union :areas (append (mapcar (lambda (r) (untransform-region tr1 (transform-region tr2 r))) (areas r2)) (areas r1)) :transformation tr1)))))) (defclass bezier-difference (area bezier-design) ((%positive-areas :initarg :positive-areas :initform '() :reader positive-areas) (%negative-areas :initarg :negative-areas :initform '() :reader negative-areas))) (defmethod transform-region (transformation (area bezier-difference)) (let* ((pareas (loop for area in (positive-areas area) collect (transform-region transformation area))) (nareas (loop for area in (negative-areas area) collect (transform-region transformation area))) (result (make-instance 'bezier-difference :positive-areas pareas :negative-areas nareas))) (when (translation-transformation-p transformation) (setf (original-region result) (or (original-region area) area))) result)) (defmethod bounding-rectangle* ((design bezier-difference)) (bounding-rectangle-of-areas (positive-areas design))) (defmethod region-difference ((r1 bezier-area) (r2 bezier-area)) (make-instance 'bezier-difference :positive-areas (list r1) :negative-areas (list r2))) (defmethod region-difference ((r1 bezier-area) (r2 bezier-union)) (let ((tr (transformation r2))) (make-instance 'bezier-difference :positive-areas (list r1) :negative-areas (mapcar (lambda (r) (transform-region tr r)) (areas r2))))) (defmethod region-difference ((r1 bezier-union) (r2 bezier-area)) (let ((tr (transformation r1))) (make-instance 'bezier-difference :positive-areas (mapcar (lambda (r) (transform-region tr r)) (areas r1)) :negative-areas (list r2)))) (defmethod region-difference ((r1 bezier-union) (r2 bezier-union)) (let ((tr1 (transformation r1)) (tr2 (transformation r2))) (make-instance 'bezier-difference :positive-areas (mapcar (lambda (r) (transform-region tr1 r)) (areas r1)) :negative-areas (mapcar (lambda (r) (transform-region tr2 r)) (areas r2))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Converting a path to a polyline or an area to a polygon ;;; convert a cubic bezier segment to a list of ;;; line segments (defun %polygonalize (p0 p1 p2 p3 &key (precision 0.01)) (if (< (- (+ (distance p0 p1) (distance p1 p2) (distance p2 p3)) (distance p0 p3)) precision) (list p3) (let* ((p01 (part-way p0 p1 0.5)) (p12 (part-way p1 p2 0.5)) (p23 (part-way p2 p3 0.5)) (p012 (part-way p01 p12 0.5)) (p123 (part-way p12 p23 0.5)) (p0123 (part-way p012 p123 0.5))) (nconc (%polygonalize p0 p01 p012 p0123 :precision precision) (%polygonalize p0123 p123 p23 p3 :precision precision))))) (defgeneric polygonalize (thing)) (defmethod polygonalize ((segment bezier-segment)) (with-slots (p0 p1 p2 p3) segment (%polygonalize p0 p1 p2 p3))) (defmethod polygonalize ((path bezier-curve)) (let ((segments (%segments path))) (make-polyline (cons (slot-value (car segments) 'p0) (mapcan #'polygonalize segments))))) (defmethod polygonalize ((area bezier-area)) (let ((segments (segments area))) (make-polygon (mapcan #'polygonalize segments)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Reversing a path (defgeneric reverse-path (path)) (defun reverse-segment (bezier-segment) (with-slots (p0 p1 p2 p3) bezier-segment (make-bezier-segment p3 p2 p1 p0))) (defmethod reverse-path ((path bezier-curve)) (make-instance 'bezier-curve :segments (reverse (mapcar #'reverse-segment (%segments path))))) (defmethod reverse-path ((path bezier-area)) (make-instance 'bezier-area :segments (reverse (mapcar #'reverse-segment (%segments path))) :transformation (transformation path))) ;;; slanting transformation are used by Metafont (defun make-slanting-transformation (slant) (make-transformation 1.0 slant 0.0 1.0 0.0 0.0)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Bounding rectangle (defun evaluate-bezier (w0 w1 w2 w3 a) (let ((1-a (- 1.0 a))) (+ (* 1-a 1-a 1-a w0) (* 3.0 1-a 1-a a w1) (* 3.0 1-a a a w2) (* a a a w3)))) (defun dimension-min-max (w0 w1 w2 w3) (when (> w0 w3) (rotatef w0 w3) (rotatef w1 w2)) (when (and (<= w0 w1 w3) (<= w0 w2 w3)) (return-from dimension-min-max (values w0 w3))) (let ((a (+ (- w0) (* 3 w1) (* -3 w2) w3)) (b (+ (* 2 w0) (* -4 w1) (* 2 w2))) (c (- w1 w0))) (if (zerop a) (if (zerop b) (values w0 w3) (let ((candidate (/ (- c) b))) (if (or (<= candidate 0.0) (>= candidate 1.0)) (values w0 w3) (let ((w (evaluate-bezier w0 w1 w2 w3 candidate))) (values (min w w0) (max w w3)))))) (multiple-value-bind (candidate0 candidate1) (solve-quadratic a b c :multiple-roots t) (if (null candidate0) (values w0 w3) (let ((wa (evaluate-bezier w0 w1 w2 w3 candidate0)) (wb (evaluate-bezier w0 w1 w2 w3 candidate1))) (if (or (<= candidate0 0.0) (>= candidate0 1.0)) (if (or (<= candidate1 0.0) (>= candidate1 1.0)) (values w0 w3) (values (min wb w0) (max wb w3))) (if (or (<= candidate1 0.0) (>= candidate1 1.0)) (values (min wa w0) (max wa w3)) (values (min wa wb w0) (max wa wb w3)))))))))) (defun segment-bounding-rectangle (segment) (with-slots (p0 p1 p2 p3) segment (let ((x0 (point-x p0)) (x1 (point-x p1)) (x2 (point-x p2)) (x3 (point-x p3)) (y0 (point-y p0)) (y1 (point-y p1)) (y2 (point-y p2)) (y3 (point-y p3))) (multiple-value-bind (min-x max-x) (dimension-min-max x0 x1 x2 x3) (multiple-value-bind (min-y max-y) (dimension-min-max y0 y1 y2 y3) (values min-x min-y max-x max-y)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Convolution (defun find-split-points-for-side (aa bb cc) (let ((roots '())) (multiple-value-bind (r1 r2) (solve-quadratic aa bb cc) (unless (or (null r1) (<= r1 0.0) (>= r1 1.0)) (push r1 roots)) (unless (or (null r2) (<= r2 0.0) (>= r2 1.0)) (push r2 roots)) roots))) (defun find-split-points (sides segment) (let ((split-points '())) (with-slots (p0 p1 p2 p3) segment (let ((x0 (point-x p0)) (y0 (point-y p0)) (x1 (point-x p1)) (y1 (point-y p1)) (x2 (point-x p2)) (y2 (point-y p2)) (x3 (point-x p3)) (y3 (point-y p3))) (let ((xa (+ (- x0) (* 3 x1) (* -3 x2) x3)) (ya (+ (- y0) (* 3 y1) (* -3 y2) y3)) (xb (* 2 (+ x0 (* -2 x1) x2))) (yb (* 2 (+ y0 (* -2 y1) y2))) (xc (- x1 x0)) (yc (- y1 y0))) (loop for side in sides do (let* ((sr (realpart side)) (si (imagpart side)) (aa (- (* xa si) (* ya sr))) (bb (- (* xb si) (* yb sr))) (cc (- (* xc si) (* yc sr)))) (setf split-points (append (find-split-points-for-side aa bb cc) split-points)))))) (sort (remove-duplicates split-points) #'<)))) (defun split-segment (segment split-points) (if (null split-points) (list segment) (with-slots (p0 p1 p2 p3) segment (let* ((n (floor (length split-points) 2)) (pivot (nth n split-points)) (left (mapcar (lambda (x) (/ x pivot)) (subseq split-points 0 n))) (right (mapcar (lambda (x) (/ (- x pivot) (- 1.0 pivot))) (subseq split-points (1+ n)))) (p01 (part-way p0 p1 pivot)) (p12 (part-way p1 p2 pivot)) (p23 (part-way p2 p3 pivot)) (p012 (part-way p01 p12 pivot)) (p123 (part-way p12 p23 pivot)) (p0123 (part-way p012 p123 pivot))) (append (split-segment (make-bezier-segment p0 p01 p012 p0123) left) (split-segment (make-bezier-segment p0123 p123 p23 p3) right)))))) (defun mid-derivative (p0 p1 p2 p3) (setf p0 (point-to-complex p0) p1 (point-to-complex p1) p2 (point-to-complex p2) p3 (point-to-complex p3)) (let ((a 0.5)) (+ (* a a (+ (- p0) (* 3 p1) (* -3 p2) p3)) (* 2 a (+ p0 (* -2 p1) p2)) (- p1 p0)))) (defun make-line-segment (p0 p1) (make-bezier-segment p0 (part-way p0 p1 1/3) (part-way p0 p1 2/3) p1)) (defun add-points (p0 p1) (make-point (+ (point-x p0) (point-x p1)) (+ (point-y p0) (point-y p1)))) (defun convert-primitive-segment-to-bezier-area (polygon segment) (with-slots (p0 p1 p2 p3) segment (let* ((m (mid-derivative p0 p1 p2 p3)) (right (reduce (lambda (a b) (if (> (dist a m) (dist b m)) a b)) polygon)) (left (reduce (lambda (a b) (if (< (dist a m) (dist b m)) a b)) polygon))) (make-instance 'bezier-area :segments (list (make-bezier-segment (add-points p0 right) (add-points p1 right) (add-points p2 right) (add-points p3 right)) (make-line-segment (add-points p3 right) (add-points p3 left)) (make-bezier-segment (add-points p3 left) (add-points p2 left) (add-points p1 left) (add-points p0 left)) (make-line-segment (add-points p0 left) (add-points p0 right))))))) (defun area-at-point (area point) (let ((transformation (make-translation-transformation (point-x point) (point-y point)))) (transform-region transformation area))) (defun convolve-polygon-and-segment (area polygon segment first) (declare (optimize debug)) (let* ((points (polygon-points polygon)) (sides (loop for (p0 p1) on (append (last points) points) until (null p1) collect (- (point-to-complex p1) (point-to-complex p0)))) (split-points (find-split-points sides segment)) (segments (split-segment segment split-points))) (loop for segment in segments if first collect (area-at-point area (slot-value segment 'p0)) collect (convert-primitive-segment-to-bezier-area (polygon-points polygon) segment) collect (area-at-point area (slot-value segment 'p3))))) (defgeneric convolve-regions (area path)) (defmethod convolve-regions ((area bezier-area) (path bezier-curve)) (let ((polygon (polygonalize area))) (make-instance 'bezier-union :areas (loop for segment in (%segments path) for first = t then nil append (convolve-polygon-and-segment area polygon segment first))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Rendering (defclass scanlines () ((%first-line :initform 0 :accessor first-line) (%chain :initform (make-instance 'flexichain:standard-flexichain) :reader chain))) (defun nb-lines (lines) (flexichain:nb-elements (chain lines))) (defun crossings (lines i) (flexichain:element* (chain lines) (- i (first-line lines)))) (defun line-number-to-index (lines line-number) (let* ((chain (chain lines)) (size (flexichain:nb-elements chain))) ;; make sure there is an element corresponding to the line number (cond ((zerop size) (flexichain:insert* chain 0 '()) (setf (first-line lines) line-number)) ((< line-number (first-line lines)) (loop for i from line-number below (first-line lines) do (flexichain:insert* chain 0 '())) (setf (first-line lines) line-number)) ((>= line-number (+ (first-line lines) size)) (loop for i from (+ (first-line lines) size) to line-number do (flexichain:insert* chain size '())))) (- line-number (first-line lines)))) ;;; insert a single crossing into LINES (defun insert-crossing (lines line-number x inverse-p) (let ((chain (chain lines)) (index (line-number-to-index lines line-number))) (setf (flexichain:element* chain index) (merge 'list (flexichain:element* chain index) (list (cons x inverse-p)) #'< :key #'car)))) ;;; compute the crossings of a line segment and insert ;;; them into LINES (defun compute-crossings (lines p0 p1) (let ((inverse-p nil)) (when (< (point-y p1) (point-y p0)) (rotatef p0 p1) (setf inverse-p t)) (let ((x0 (point-x p0)) (y0 (point-y p0)) (x1 (point-x p1)) (y1 (point-y p1))) (loop for y from (round y0) below (round y1) for x = (+ x0 (* (- x1 x0) (/ (- (+ y 0.5) y0) (- y1 y0)))) do (insert-crossing lines y x inverse-p))))) (defun scan-lines (polygon) (let ((lines (make-instance 'scanlines)) (points (polygon-points polygon))) (loop for (p0 p1) on (append (last points) points) until (null p1) do (compute-crossings lines p0 p1)) lines)) (defun render-scan-lines (array pixel-value line crossings min-x min-y) (let ((level 0) (start nil) (height (array-dimension array 0)) (width (array-dimension array 1))) (loop for (x . inverse-p) in crossings do (when (zerop level) (setf start x)) do (setf level (if inverse-p (1+ level) (1- level))) do (when (zerop level) (loop for c from (round start) below (round x) do (when (and (<= 0 (round (- line min-y)) (1- height)) (<= 0 (- c min-x) (1- width))) (setf (aref array (round (- line min-y)) (- c min-x)) pixel-value))))))) (defun render-polygon (array polygon pixel-value min-x min-y) (let ((lines (scan-lines polygon))) (loop for i from (first-line lines) repeat (nb-lines lines) do (render-scan-lines array pixel-value i (crossings lines i) min-x min-y)))) (defgeneric positive-negative-areas (design)) (defmethod positive-negative-areas ((design bezier-area)) (values (list design) '())) (defmethod positive-negative-areas ((design bezier-union)) (values (areas design) '())) (defmethod positive-negative-areas ((design bezier-difference)) (values (positive-areas design) (negative-areas design))) (defun render-to-array (design) (multiple-value-bind (positive-areas negative-areas) (positive-negative-areas design) (multiple-value-bind (min-x min-y max-x max-y) (bounding-rectangle-of-areas positive-areas) (setf min-x (* 4 (floor min-x)) min-y (* 4 (floor min-y)) max-x (* 4 (ceiling max-x)) max-y (* 4 (ceiling max-y))) (let ((result (make-array (list (- max-y min-y) (- max-x min-x)) :element-type 'bit :initial-element 1)) (transformation (make-scaling-transformation* 4 4))) (loop for area in positive-areas do (let* ((transformed-area (transform-region transformation area)) (polygon (polygonalize transformed-area))) (render-polygon result polygon 0 min-x min-y))) (loop for area in negative-areas do (let* ((transformed-area (transform-region transformation area)) (polygon (polygonalize transformed-area))) (render-polygon result polygon 1 min-x min-y))) result)))) (defparameter *pixmaps* (make-hash-table :test #'equal)) (defun resolve-ink (medium) (if (eq (medium-ink medium) +foreground-ink+) (medium-foreground medium) (medium-ink medium))) (defun make-ink (medium transparency) (let* ((a (/ transparency 16.0)) (1-a (- 1.0 a))) (multiple-value-bind (r g b) (color-rgb (resolve-ink medium)) (make-rgb-color (+ (* a 1.0) (* 1-a r)) (+ (* a 1.0) (* 1-a g)) (+ (* a 1.0) (* 1-a b)))))) (defgeneric ensure-pixmap (medium design)) (defmethod ensure-pixmap (medium rdesign) (let* ((design (or (original-region rdesign) rdesign)) (pixmap (gethash (list (medium-sheet medium) (resolve-ink medium) design) *pixmaps*))) (when (null pixmap) (let* ((picture (render-to-array design)) (height (array-dimension picture 0)) (width (array-dimension picture 1)) (reduced-picture (make-array (list (/ height 4) (/ width 4)) :initial-element 16))) (loop for l from 0 below height do (loop for c from 0 below width do (when (zerop (aref picture l c)) (decf (aref reduced-picture (floor l 4) (floor c 4)))))) (setf pixmap (with-output-to-pixmap (pixmap-medium (medium-sheet medium) :width (/ width 4) :height (/ height 4)) (loop for l from 0 below (/ height 4) do (loop for c from 0 below (/ width 4) do (draw-point* pixmap-medium c l :ink (make-ink medium (aref reduced-picture l c))))))) (setf (gethash (list (medium-sheet medium) (resolve-ink medium) design) *pixmaps*) pixmap))) pixmap)) (defun render-through-pixmap (design medium) (multiple-value-bind (min-x min-y) (bounding-rectangle* design) ;; the design we've got has already been transformed by the ;; medium/user transformation, and COPY-FROM-PIXMAP is in user ;; coordinates. So we need to transform back (or set the medium's ;; transformation to be +IDENTITY-TRANSFORMATION+ temporarily, but ;; that's even uglier) (multiple-value-bind (utmin-x utmin-y) (untransform-position (medium-transformation medium) min-x min-y) (setf min-x (floor utmin-x) min-y (floor utmin-y)) (let ((pixmap (ensure-pixmap medium design))) (copy-from-pixmap pixmap 0 0 (pixmap-width pixmap) (pixmap-height pixmap) (medium-sheet medium) min-x min-y))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Generic drawing (defun draw-bezier-design* (sheet design &rest options) (climi::with-medium-options (sheet options) (medium-draw-bezier-design* sheet design))) (defmethod draw-design (medium (design bezier-design) &rest options &key &allow-other-keys) (apply #'draw-bezier-design* medium design options)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Drawing bezier designs to screen ;;; Fallback method (suitable for CLX) (defmethod medium-draw-bezier-design* (medium design) (render-through-pixmap design medium)) #| ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Test cases (defparameter *r1* (make-bezier-area* '(10 10 20 20 30 20 40 10 30 5 20 5 10 10))) (defparameter *r2* (make-bezier-area* '(15 10 20 12 30 15 35 10 30 8 20 8 15 10))) (defparameter *r3* (region-difference *r1* *r2*)) (defparameter *r4* (make-bezier-curve* '(100 100 120 150 160 160 170 160))) (defparameter *r5* (convolute-regions *r2* *r4*)) |# cl-mcclim-0.9.6.dfsg.cvs20100315.orig/clim1-compat.lisp0000644000175000017500000000214707643343455020177 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2003 by Michael McDonald (mikemac@mikemac.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) (import '(climi::stream-set-cursor-position climi::convert-from-relative-to-absolute-coordinates ) :clim) (export '(clim::stream-set-cursor-position clim::convert-from-relative-to-absolute-coordinates ) :clim)cl-mcclim-0.9.6.dfsg.cvs20100315.orig/pixmap.lisp0000644000175000017500000000671211345155771017205 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2001 by Iban HATCHONDO (hatchond@mei.u-bordeaux.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) (defclass pixmap () ((sheet :initarg :sheet :reader pixmap-sheet) (width :initarg :width :reader pixmap-width) (height :initarg :height :reader pixmap-height) )) (defgeneric pixmap-mirror (mirrored-pixmap)) (defgeneric allocate-pixmap (sheet width height)) (defgeneric deallocate-pixmap (pixmap)) (defgeneric copy-to-pixmap (medium medium-x medium-y width height &optional pixmap pixmap-x pixmap-y)) (defgeneric copy-from-pixmap (pixmap from-x from-y width height medium medium-x medium-y)) (defgeneric copy-area (medium from-x from-y width height to-x to-y)) (defgeneric medium-copy-area (from-drawable from-x from-y width height to-drawable to-x to-y)) (defclass mirrored-pixmap (pixmap) ((port :initform nil :initarg :port :accessor port) (medium :initform nil :accessor pixmap-medium) (region :initform nil :accessor sheet-region) )) ; added this. CHECKME -- BTS (defmethod (setf %sheet-medium) (value (pixmap mirrored-pixmap)) (setf (slot-value pixmap 'medium) value)) (defmethod invalidate-cached-transformations ((sheet mirrored-pixmap)) (values)) (defmethod invalidate-cached-regions ((sheet mirrored-pixmap)) (values)) ; BTS stopped adding. ^-- CHECKME (defmethod initialize-instance :after ((pixmap mirrored-pixmap) &rest args) (declare (ignore args)) (with-slots (width height region) pixmap (setf region (make-bounding-rectangle 0 0 width height)))) (defmethod pixmap-mirror ((pixmap mirrored-pixmap)) (port-lookup-mirror (port pixmap) pixmap)) (defmethod allocate-pixmap ((sheet sheet) width height) (port-allocate-pixmap (port sheet) sheet width height)) (defmethod deallocate-pixmap ((pixmap pixmap)) (port-deallocate-pixmap (port (medium-sheet pixmap)) pixmap)) (defmethod deallocate-pixmap ((pixmap mirrored-pixmap)) (port-deallocate-pixmap (port pixmap) pixmap)) (defmethod sheet-native-transformation ((pixmap mirrored-pixmap)) +identity-transformation+) (defmethod sheet-native-region ((pixmap mirrored-pixmap)) (make-rectangle* 0 0 (pixmap-width pixmap) (pixmap-height pixmap))) (defmethod sheet-device-transformation ((pixmap mirrored-pixmap)) (medium-transformation (pixmap-medium pixmap))) (defmethod sheet-device-region ((pixmap mirrored-pixmap)) (region-intersection (sheet-native-region pixmap) (transform-region (sheet-device-transformation pixmap) (medium-clipping-region (pixmap-medium pixmap))))) (defmethod sheet-direct-mirror ((pixmap mirrored-pixmap)) (port-lookup-mirror (port pixmap) pixmap)) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/panes.lisp0000644000175000017500000035777411345155771017036 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 1998,1999,2000,2001 by Michael McDonald (mikemac@mikemac.com) ;;; (c) copyright 2000 by ;;; Iban Hatchondo (hatchond@emi.u-bordeaux.fr) ;;; Julien Boninfante (boninfan@emi.u-bordeaux.fr) ;;; (c) copyright 2000, 2001 by ;;; Robert Strandh (strandh@labri.u-bordeaux.fr) ;;; (c) copyright 2001 by ;;; Lionel Salabartan (salabart@emi.u-bordeaux.fr) ;;; Arnaud Rouanet (rouanet@emi.u-bordeaux.fr) ;;; (c) copyright 2002, 2003 by ;;; Gilbert Baumann ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; $Id: panes.lisp,v 1.197 2009-08-01 22:11:06 gbaumann Exp $ (in-package :clim-internals) ;;;; ;;;; Ambiguities and Obmissions ;;;; ;; This is a scratch pad, were we can document, what the spec doesn't ;; tells us about CLIM. Reason: While coding, one sees were the spec ;; is vague or wrong; later when the task to update the spec is due, ;; things might be forgotten. --GB ;; ;; - Default of :equalize-width / :equalize-height is T ;; ;; - LAYOUT-PANE is mentioned in the spec's example, but not in the ;; text. ;; ;; - Behaviour of :align-x, :align-y is uncertain. ;; (Should it be specifed on the childs? on the parents?) ;; ;; - BORDER-PANE is not in the spec and just a different name of ;; OUTLINED-PANE, where is it from? --GB ;; ;; - RAISED-PANE, where form? --GB ;; ;; - In XBOX-PANE: I would like to also allow for (1 ) being a ;; proportional content. ;;;; TODO ;; - VBOX/HBOX/VRACK/HRACK: ;; . should align its children ;; Q: Should we cope with proportional content differently? ;; . test units for spacing and fixed width ;; Q: When to resolve? ;; . adopt/disown/enable/disable ;; ;; - TABLE-PANE ;; . test units ;; . adopt/disown/enable/disable ;; . allow for partially filled rows/cols? ;; ;; - GRID-PANE ;; . align children ;; . test units ;; . adopt/disown/enable/disable ;; ;; - SPACING-PANE ;; . align child ;; Or: expand them as we did? ;; . adopt/disown/enable/disable ;; ;; - RESTRAINING-PANE ;; . ??? ;; ;; - LABEL-PANE ;; . test units ;; . adopt/disown/enable/disable ;; . expand child? leave it? ;; ;; - SCROLLER-PANE ;; . much! ;; ;; - we still need to think about what should happen when children ;; get disabled or adopted or disowned. ;; ;; - adjust class names. ;; ;; - advertise layout-child et al ;; ;; - reuse single-child-composite-pane ;; ;; - MAKE-SPACE-REQUIREMENT right? ;; . default arguments in the spec are different ;; . DUIM's default for maxima is not +fill+ but the dimension ;; ;; - what are the appropriate default values for align? ;; ;; - for layout purposes the list of children should be considered in ;; reverse: The first element of children should come last. ;;--GB 2002-02-27 ;;;; CLIM Layout Protocol for Dummies ;; Here is how I interpret the relevant sections of the specification: ;; ;; COMPOSE-SPACE ;; ;; This is called by CLIM, when it wants to find out what the pane ;; thinks are its space requirements. The result of COMPOSE-SPACE is ;; cached by CLIM. ;; ;; ALLOCATE-SPACE ;; ;; This method is called by CLIM when a pane is allocate space. It ;; should layout its possible children. ;; ;; CHANGE-SPACE-REQUIREMENTS ;; ;; This is called by the application programmer to a) indicate that ;; COMPOSE-SPACE may now return something different from previous ;; invocations and/or b) to update the user space requirements ;; options (the :width, :height etc keywords as upon pane creation). ;; ;; NOTE-SPACE-REQUIREMENTS-CHANGED ;; ;; Called by CLIM when the space requirements of a pane have ;; changed. Not called to layout a pane; This is only a kind of signal. ;; ;; LAYOUT-FRAME ;; ;; Maybe called by both CLIM and the application programmer to ;; "invoke the space allocation protocol", that is CLIM calls ;; ALLOCATE-SPACE on the top level sheet. This in turn will probably ;; call COMPOSE-SPACE on its children and layout then accordingly by ;; calling ALLOCATE-SPACE again. ;; ;; The effect is that ALLOCATE-SPACE propagate down the sheet ;; hierarchy. ;; ;; --GB 2003-08-06 ;; For each of the builtin CLIM gadgets there is an abstract gadget class ;; and at least one "concrete" subclass which can be chosen by the ;; frame manager. The CLIM 2.0 spec names one concrete class for each ;; abstract class. Frame managers need a mechanism to look up these ;; concrete classes. The current practice of the CLX backend is to ;; search for classes of various names based on the name of the abstract ;; class. This mostly works as all but two of the specified concrete ;; class names can be produced by appending "-PANE" to the abstract class ;; name. The classes GENERIC-LIST-PANE and GENERIC-OPTION-PANE break this ;; convention. ;; I've extended the CLX frame manager to additionally search the property ;; list of the pane class name when searching for a concrete pane class. The ;; function below can be used where needed to place the concrete class name ;; where it needs to go. ;; This could be easily extended to allow mappings for specific backends.. (defun define-abstract-pane-mapping (abstract-class-name concrete-class-name) (setf (get abstract-class-name 'concrete-pane-class-name) concrete-class-name)) ;;; Default Color Scheme Options #|| ;; Motif-ish (defparameter *3d-dark-color* (make-gray-color .45)) (defparameter *3d-normal-color* (make-gray-color .75)) (defparameter *3d-light-color* (make-gray-color .92)) (defparameter *3d-inner-color* (make-gray-color .65)) ||# ;; Gtk-ish (defparameter *3d-dark-color* (make-gray-color .59)) (defparameter *3d-normal-color* (make-gray-color .84)) (defparameter *3d-light-color* (make-gray-color 1.0)) (defparameter *3d-inner-color* (make-gray-color .75)) ;;; Gadget "Feel" (defparameter *double-click-delay* 0.25 "Maximum time in seconds between clicks in order to produce a double-click") (defparameter *double-click-max-travel* 7 "Maximum distance in device units that the cursor may move between clicks in order to produce a double-click") ;;; ;;; gadgets look ;;; ;; Only used by some gadgets, I suggest using my more flexible and ;; general DRAW-BORDERED-POLYGON. (defun display-gadget-background (gadget color x1 y1 x2 y2) (draw-rectangle* gadget x1 y1 x2 y2 :ink color :filled t)) (defun draw-edges-lines* (pane ink1 x1 y1 ink2 x2 y2) (draw-line* pane x1 y1 x2 y1 :ink ink1) (draw-line* pane x1 y1 x1 y2 :ink ink1) (draw-line* pane x1 y2 x2 y2 :ink ink2) (draw-line* pane x2 y1 x2 y2 :ink ink2)) ;;; Space Requirements (defconstant +fill+ (expt 10 (floor (log most-positive-fixnum 10)))) (defclass space-requirement () ()) (defclass standard-space-requirement (space-requirement) ((width :initform 1 :initarg :width :reader space-requirement-width) (max-width :initform 1 :initarg :max-width :reader space-requirement-max-width) (min-width :initform 1 :initarg :min-width :reader space-requirement-min-width) (height :initform 1 :initarg :height :reader space-requirement-height) (max-height :initform 1 :initarg :max-height :reader space-requirement-max-height) (min-height :initform 1 :initarg :min-height :reader space-requirement-min-height) ) ) (defmethod print-object ((space standard-space-requirement) stream) (with-slots (width height min-width max-width min-height max-height) space (print-unreadable-object (space stream :type t :identity nil) (format stream "width: ~S [~S,~S] height: ~S [~S,~S]" width min-width max-width height min-height max-height)))) (defun make-space-requirement (&key (width 1) (height 1) (min-width 0) (min-height 0) (max-width +fill+) (max-height +fill+)) (assert (<= 0 min-width width max-width) (min-width width max-width)) (assert (<= 0 min-height height max-height) (min-height height max-height)) (make-instance 'standard-space-requirement :width width :max-width max-width :min-width min-width :height height :max-height max-height :min-height min-height)) (defmethod space-requirement-components ((space-req standard-space-requirement)) (with-slots (width min-width max-width height min-height max-height) space-req (values width min-width max-width height min-height max-height))) (defun space-requirement-combine* (function sr1 &key (width 0) (min-width 0) (max-width 0) (height 0) (min-height 0) (max-height 0)) (apply #'make-space-requirement (mapcan #'(lambda (c1 c2 keyword) (list keyword (funcall function c1 c2))) (multiple-value-list (space-requirement-components sr1)) (list width min-width max-width height min-height max-height) '(:width :min-width :max-width :height :min-height :max-height)))) (defun space-requirement-combine (function sr1 sr2) (multiple-value-bind (width min-width max-width height min-height max-height) (space-requirement-components sr2) (space-requirement-combine* function sr1 :width width :min-width min-width :max-width max-width :height height :min-height min-height :max-height max-height))) (defun space-requirement+ (sr1 sr2) (space-requirement-combine #'+ sr1 sr2)) (defun space-requirement+* (space-req &key (width 0) (min-width 0) (max-width 0) (height 0) (min-height 0) (max-height 0)) (space-requirement-combine* #'+ space-req :width width :min-width min-width :max-width max-width :height height :min-height min-height :max-height max-height)) (eval-when (:compile-toplevel :load-toplevel :execute) (defun spacing-value-p (x) (or (and (realp x) (>= x 0)) (and (consp x) (realp (car x)) (consp (cdr x)) (member (cadr x) '(:point :pixel :mm :character :line)) (null (cddr x))) ;; For clim-stream-pane (eq x :compute))) ) (deftype spacing-value () ;; just for documentation `(satisfies spacing-value-p)) ;;; PANES ;; Macros for quick access to space-requirement slots. (defmacro sr-width (pane) `(space-requirement-width (pane-space-requirement ,pane))) (defmacro sr-height (pane) `(space-requirement-height (pane-space-requirement ,pane))) (defmacro sr-max-width (pane) `(space-requirement-max-width (pane-space-requirement ,pane))) (defmacro sr-max-height (pane) `(space-requirement-max-height (pane-space-requirement ,pane))) (defmacro sr-min-width (pane) `(space-requirement-min-width (pane-space-requirement ,pane))) (defmacro sr-min-height (pane) `(space-requirement-min-height (pane-space-requirement ,pane))) (defclass layout-protocol-mixin () ((space-requirement :accessor pane-space-requirement :initform nil :documentation "The cache of the space requirements of the pane. NIL means: need to recompute.") (current-width :accessor pane-current-width :initform nil) (current-height :accessor pane-current-height :initform nil) )) ;;; XXX Move to protocol-classes.lisp. Should this really have all these ;;; superclasses? (define-protocol-class pane (clim-repainting-mixin clim-sheet-input-mixin sheet-transformation-mixin layout-protocol-mixin basic-sheet) ( (text-style :initarg :text-style :initform nil :reader pane-text-style) (name :initarg :name :initform "(Unnamed Pane)" :reader pane-name) (manager :initarg :manager) (port :initarg :port) (frame :initarg :frame :initform *application-frame* :reader pane-frame) (enabledp :initform nil :initarg :enabledp :accessor pane-enabledp) (space-requirement :initform nil :accessor pane-space-requirement) ;; New sizes, for allocating protocol (new-width :initform nil) (new-height :initform nil) (redisplay-needed :accessor pane-redisplay-needed :initarg :redisplay-needed :initform nil)) (:documentation "")) (defmethod print-object ((pane pane) sink) (print-unreadable-object (pane sink :type t :identity t) (prin1 (pane-name pane) sink))) (defun make-pane (type &rest args) (when (eql (symbol-package type) (symbol-package :foo)) (setf type (or (find-symbol (symbol-name type) (find-package :clim)) type))) (apply #'make-pane-1 *pane-realizer* *application-frame* type args)) (defmethod medium-foreground ((pane pane)) (medium-foreground (sheet-medium pane))) (defmethod (setf medium-foreground) (ink (pane pane)) (setf (medium-foreground (sheet-medium pane)) ink)) (defmethod medium-background ((pane pane)) (medium-background (sheet-medium pane))) (defmethod (setf medium-background) (ink (pane pane)) (setf (medium-background (sheet-medium pane)) ink)) (defmethod compose-space ((pane pane) &key width height) (make-space-requirement :width (or width 200) :height (or height 200))) (defmethod allocate-space ((pane pane) width height) (declare (ignorable pane width height)) ) (defmethod pane-needs-redisplay ((pane pane)) (let ((do-redisplay (pane-redisplay-needed pane))) (values do-redisplay (and do-redisplay (not (eq do-redisplay :no-clear)))))) (defmethod (setf pane-needs-redisplay) (value (pane pane)) (setf (pane-redisplay-needed pane) value)) (defmethod window-clear ((pane pane)) nil) ;;; WINDOW STREAM ;; ??? (defclass window-stream (standard-extended-output-stream standard-extended-input-stream) () ) ;;; ;;; Utilities ;;; ;; Since, I hate to duplicate code for HBOX and VBOX, I define this ;; evil macro: (defmacro dada ((&rest substs) &body body) "This is an evil macro." (setf substs (sort substs #'> :key (lambda (s) (length (symbol-name (first s)))))) `(progn ,@(loop for k from 1 below (length (first substs)) collect (labels ((subst-one (new old sym) (let ((p (search (symbol-name old) (symbol-name sym)))) (cond ((not (null p)) (let ((pack (if (eq (symbol-package sym) (find-package :keyword)) (symbol-package sym) *package*))) (intern (concatenate 'string (subseq (symbol-name sym) 0 p) (symbol-name new) (subseq (symbol-name sym) (+ p (length (symbol-name old))))) pack))) (t sym)))) (walk (x) (cond ((symbolp x) (dolist (subst substs) (setf x (subst-one (elt subst k) (first subst) x))) x) ((atom x) x) ((consp x) (cons (walk (car x)) (walk (cdr x))))))) `(locally ,@(walk body)))))) ;;;; Layout Utilities (defun layout-child (child align-x align-y x y width height) "Allocates space to a child of a pane. x, y, width, height designate the area of available space. align-x, align-y name the desired child alignment. If the child does not have enough strechability to cover all of the given area, it is aligned within that area according to the given options. As a special option we allow align-x or align-y be :expand, which means that the child wouldn't be aligned in that direction but its size would be forced." (let* ((sr (compose-space child)) ;; The child's dimension is clamped within its min/max space requirement (child-width (if (eql :expand align-x) width (clamp width (space-requirement-min-width sr) (space-requirement-max-width sr)))) (child-height (if (eql :expand align-y) height (clamp height (space-requirement-min-height sr) (space-requirement-max-height sr)))) ;; Align the child within the available area (child-x (ecase align-x ((:left) x) ((:center) (+ x (/ (- width child-width) 2))) ((:right) (+ x (- width child-width))) ((:expand) x) )) (child-y (ecase align-y ((:top) y) ((:center) (+ y (/ (- height child-height) 2))) ((:bottom) (+ y (- height child-height))) ((:expand) y) ))) ;; Actually layout the child (move-sheet child child-x child-y) (resize-sheet child child-width child-height) (allocate-space child child-width child-height))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; User Space Requirements (defclass space-requirement-options-mixin () ((user-width :initarg :width :initform nil :reader pane-user-width :type (or null spacing-value)) (user-min-width :initarg :min-width :initform nil :reader pane-user-min-width :type (or null spacing-value)) (user-max-width :initarg :max-width :initform nil :reader pane-user-max-width :type (or null spacing-value)) (user-height :initarg :height :initform nil :reader pane-user-height :type (or null spacing-value)) (user-min-height :initarg :min-height :initform nil :reader pane-user-min-height :type (or null spacing-value)) (user-max-height :initarg :max-height :initform nil :reader pane-user-max-height :type (or null spacing-value)) (x-spacing :initarg :x-spacing :initform 0 :reader pane-x-spacing :type (or null spacing-value)) (y-spacing :initarg :y-spacing :initform 0 :reader pane-y-spacing :type (or null spacing-value))) (:documentation "Mixin class for panes which offer the standard user space requirements options.")) (defclass standard-space-requirement-options-mixin (space-requirement-options-mixin) ()) (defun merge-one-option (pane foo user-foo user-min-foo user-max-foo min-foo max-foo) ;; NOTE: The defaulting for :min-foo and :max-foo is different from MAKE-SPACE-REQUIREMENT. ;; MAKE-SPACE-REQUIREMENT has kind of &key foo (min-foo 0) (max-foo +fill+) ;; While user space requirements has &key foo (min-foo foo) (max-foo foo). ;; I as a user would pretty much expect the same behavior, therefore I'll take the ;; following route: ;; When the :foo option is given, I'll let MAKE-SPACE-REQUIREMENT decide. ;; ;; old code: ;; ;; ;; Then we resolve defaulting. sec 29.3.1 says: ;; ;; | If either of the :max-width or :min-width options is not ;; ;; | supplied, it defaults to the value of the :width option. If ;; ;; | either of the :max-height or :min-height options is not ;; ;; | supplied, it defaults to the value of the :height option. ;; (setf user-max-foo (or user-max-foo user-foo) ;; user-min-foo (or user-min-foo user-foo)) ;; --GB 2003-01-23 (when (and (null user-max-foo) (not (null user-foo))) (setf user-max-foo (space-requirement-max-width (make-space-requirement :width (spacing-value-to-device-units pane foo))))) (when (and (null user-min-foo) (not (null user-foo))) (setf user-min-foo (space-requirement-min-width (make-space-requirement :width (spacing-value-to-device-units pane foo))))) ;; when the user has no idea about the preferred size just take the ;; panes preferred size. (setf user-foo (or user-foo foo)) (setf user-foo (spacing-value-to-device-units pane user-foo)) ;; dito for min/max (setf user-min-foo (or user-min-foo min-foo) user-max-foo (or user-max-foo max-foo)) ;; | :max-width, :min-width, :max-height, and :min-height can ;; | also be specified as a relative size by supplying a list of ;; | the form (number :relative). In this case, the number ;; | indicates the number of device units that the pane is ;; | willing to stretch or shrink. (labels ((resolve-relative (dimension sign base) (if (and (consp dimension) (eq (car dimension) :relative)) (+ base (* sign (cadr dimension))) (spacing-value-to-device-units pane dimension)))) (setf user-min-foo (and user-min-foo (resolve-relative user-min-foo -1 user-foo)) user-max-foo (and user-max-foo (resolve-relative user-max-foo +1 user-foo)))) ;; Now we have two space requirements which need to be 'merged'. (setf min-foo (clamp user-min-foo min-foo max-foo) max-foo (clamp user-max-foo min-foo max-foo) foo (clamp user-foo min-foo max-foo)) (values foo min-foo max-foo)) (defmethod merge-user-specified-options ((pane space-requirement-options-mixin) sr) ;; ### I want proper error checking and in case there is an error we ;; should just emit a warning and move on. CLIM should not die from ;; garbage passed in here. (multiple-value-bind (width min-width max-width height min-height max-height) (space-requirement-components sr) (multiple-value-bind (new-width new-min-width new-max-width) (merge-one-option pane width (pane-user-width pane) (pane-user-min-width pane) (pane-user-max-width pane) min-width max-width) (multiple-value-bind (new-height new-min-height new-max-height) (merge-one-option pane height (pane-user-height pane) (pane-user-min-height pane) (pane-user-max-height pane) min-height max-height) (make-space-requirement :width new-width :min-width new-min-width :max-width new-max-width :height new-height :min-height new-min-height :max-height new-max-height))))) (defmethod compose-space :around ((pane space-requirement-options-mixin) &key width height) (declare (ignore width height)) ;; merge user specified options. (let ((sr (call-next-method))) (unless sr (warn "~S has no idea about its space-requirements." pane) (setf sr (make-space-requirement :width 100 :height 100))) (merge-user-specified-options pane sr))) (defmethod change-space-requirements :before ((pane space-requirement-options-mixin) &key (width :nochange) (min-width :nochange) (max-width :nochange) (height :nochange) (min-height :nochange) (max-height :nochange) (x-spacing :nochange) (y-spacing :nochange) &allow-other-keys) (with-slots (user-width user-min-width user-max-width user-height user-min-height user-max-height (user-x-spacing x-spacing) (user-y-spacing y-spacing)) pane (unless (eq width :nochange) (setf user-width width)) (unless (eq min-width :nochange) (setf user-min-width min-width)) (unless (eq max-width :nochange) (setf user-max-width max-width)) (unless (eq height :nochange) (setf user-height height)) (unless (eq min-height :nochange) (setf user-min-height min-height)) (unless (eq max-height :nochange) (setf user-max-height max-height)) (unless (eq x-spacing :nochange) (setf user-x-spacing x-spacing)) (unless (eq y-spacing :nochange) (setf user-y-spacing y-spacing)) )) ;;;; LAYOUT-PROTOCOL-MIXIN ;;; Note ;; This is how I read the relevant section of the specification: ;; ;; - space is only allocated / composed when the space allocation ;; protocol is invoked, that is when layout-frame is called. ;; ;; - CHANGE-SPACE-REQUIREMENTS is only for ;; . reparsing the user space options ;; . flushing the space requirement cache of that pane. ;; ;; - when within CHANGING-SPACE-REQUIREMENTS, the method for ;; CHANGING-SPACE-REQUIREMENTS on the top level sheet should not ;; invoke the layout protocol but remember that the SR of the frame ;; LAYOUT-FRAME then is then called when leaving ;; CHANGING-SPACE-REQUIREMENTS. ;; ;; - NOTE-SPACE-REQUIREMENTS-CHANGED is solely for the user. ;; ;; --GB 2003-03-16 (defmethod allocate-space :around ((pane layout-protocol-mixin) width height) (unless (and (eql (pane-current-width pane) width) (eql (pane-current-height pane) height)) (setf (pane-current-width pane) width (pane-current-height pane) height) (unless (typep pane 'top-level-sheet-pane) (resize-sheet pane width height)) (call-next-method))) (defmethod compose-space :around ((pane layout-protocol-mixin) &key width height) (declare (ignore width height)) (or (pane-space-requirement pane) (setf (pane-space-requirement pane) (call-next-method)))) ;;; changing space requirements ;; Here is what we do: ;; ;; change-space-requirements (pane) := ;; clear space requirements cache ;; call change-space-requirements on parent pane ;; call note-space-requirements-changed ;; ;; This is split into :before, primary and :after method to allow for ;; easy overriding of change-space-requirements without needing to ;; know the details of the space requirement cache and the ;; note-space-requirements-changed notifications. ;; ;; The calls to change-space-requirements travel all the way up to the ;; top-level-sheet-pane which then invokes the layout protocol calling ;; layout-frame. ;; ;; In case this happens within changing-space-requirements layout ;; frame is not called but simply recorded and then called when ;; changing-space-requirements is left. ;; ;; No action is taken in note-space-requirements-changed. We leave ;; that to the user. (defvar *changing-space-requirements* nil "Bound to non-NIL while within the execution of CHANGING-SPACE-REQUIREMENTS.") (defvar *changed-space-requirements* nil "A list of (frame pane resize-frame) tuples recording frames and their panes which changed during the current execution of CHANGING-SPACE-REQUIREMENTS. [This is expected to change]") (defmethod change-space-requirements :before ((pane layout-protocol-mixin) &rest space-req-keys &key resize-frame &allow-other-keys) (declare (ignore resize-frame space-req-keys)) ;; Clear the space requirements cache (setf (pane-space-requirement pane) nil) (setf (pane-current-width pane) nil) (setf (pane-current-height pane) nil) ) (defmethod change-space-requirements ((pane layout-protocol-mixin) &key resize-frame &allow-other-keys) (when (sheet-parent pane) (change-space-requirements (sheet-parent pane) :resize-frame resize-frame))) (defmethod change-space-requirements :after ((pane layout-protocol-mixin) &key resize-frame &allow-other-keys) (declare (ignore resize-frame)) (note-space-requirements-changed (sheet-parent pane) pane)) (defmethod note-space-requirements-changed (pane client) "Just a no-op fallback method." nil) ;;; CHANGING-SPACE-REQUIREMENTS macro (defmacro changing-space-requirements ((&key resize-frame layout) &body body) `(invoke-with-changing-space-requirements (lambda () ,@body) :resize-frame ,resize-frame :layout ,layout)) (defun invoke-with-changing-space-requirements (continuation &key resize-frame layout) (cond (*changed-space-requirements* ;; We are already within changing-space-requirements, so just ;; call the body. This might however lead to surprising ;; behavior in case the outer changing-space-requirements has ;; resize-frame = NIL while the inner has resize-frame = T. (funcall continuation)) (t (let ((*changed-space-requirements* nil)) (let ((*changing-space-requirements* t)) (funcall continuation)) ;; ;; Note: That 'resize-frame' and especially 'layout' are ;; options to this strongly suggests that the authors of ;; the clim specification may have meant that ;; changing-space-requirements records space requirements ;; of the *application-frame* only. ;; ;; We solve this by recording all frames but applying ;; resize-frame and layout only to *application-frame*. ;; (dolist (q *changed-space-requirements*) (destructuring-bind (frame pane resize-frame-2) q (cond ((eq frame *application-frame*) (when layout (setf (frame-current-layout frame) layout)) (cond (resize-frame (layout-frame frame)) (t (layout-frame frame (bounding-rectangle-width pane) (bounding-rectangle-height pane))))) (t (cond (resize-frame-2 (layout-frame frame)) (t (layout-frame frame (bounding-rectangle-width pane) (bounding-rectangle-height pane)))))))) )))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; BASIC PANE (defclass basic-pane (;; layout-protocol-mixin standard-space-requirement-options-mixin sheet-parent-mixin mirrored-sheet-mixin pane) ((foreground :initarg :foreground :reader pane-foreground) (background :initarg :background :reader pane-background) (text-style :initarg :text-style :reader pane-text-style) (align-x :initarg :align-x :type (member :left :center :right) :reader pane-align-x) (align-y :initarg :align-y :type (member :top :center :bottom) :reader pane-align-y)) (:default-initargs :foreground +black+ :background *3d-normal-color* :text-style *default-text-style* :align-x :left :align-y :top)) (defmethod initialize-instance :after ((obj basic-pane) &key text-style) (when (consp text-style) (setf (slot-value obj 'text-style) (apply #'make-text-style text-style)))) (defmethod engraft-medium :after (medium port (pane basic-pane)) (declare (ignore port)) ;; implements 29.2.2, last sentence. (setf (medium-foreground medium) (pane-foreground pane) (medium-background medium) (pane-background pane) (medium-text-style medium) (pane-text-style pane))) ;;;; ;;;; Composite Panes ;;;; (defclass composite-pane (sheet-multiple-child-mixin basic-pane) () (:documentation "protocol class")) (defmethod spacing-value-to-device-units (pane x) (cond ((realp x) x) ((consp x) (ecase (cadr x) (:pixels (car x)) (:point (* (car x) (graft-pixels-per-inch (graft pane)) 1/72)) (:mm (* (car x) (graft-pixels-per-millimeter (graft pane)))) (:character (* (car x) (text-style-character-width (pane-text-style pane) (sheet-medium pane) #\m))) (:line (* (car x) (stream-line-height pane))))))) ;;; SINGLE-CHILD-COMPOSITE PANE (defclass single-child-composite-pane (sheet-single-child-mixin basic-pane) ()) (defmethod initialize-instance :after ((pane single-child-composite-pane) &rest args &key contents &allow-other-keys) (declare (ignore args)) (when contents (sheet-adopt-child pane (first contents)))) (defmethod compose-space ((pane single-child-composite-pane) &key width height) (if (sheet-child pane) (compose-space (sheet-child pane) :width width :height height) (make-space-requirement))) (defmethod allocate-space ((pane single-child-composite-pane) width height) (when (sheet-child pane) (allocate-space (sheet-child pane) width height))) ;;;; TOP-LEVEL-SHEET (defclass top-level-sheet-pane (composite-pane) () (:documentation "For the first pane in the architecture")) (defun top-level-sheet-pane-p (pane) (typep pane 'top-level-sheet-pane)) (defmethod change-space-requirements ((pane top-level-sheet-pane) &rest space-req-keys &key resize-frame &allow-other-keys) (declare (ignore space-req-keys)) (cond (*changing-space-requirements* ;; Record changed space requirements. ;; What happens if we change the requirements successively ;; with different values? Only the first takes effect? ;; -Hefner (unless (find pane *changed-space-requirements* :key #'second) (push (list (pane-frame pane) pane resize-frame) *changed-space-requirements*))) (t (let ((frame (pane-frame pane))) ;; ### we miss the :resize-frame option (cond (resize-frame (layout-frame frame)) (t (layout-frame frame (bounding-rectangle-width pane) (bounding-rectangle-height pane)))))))) (defmethod compose-space ((pane top-level-sheet-pane) &key width height) (declare (ignore width height)) (compose-space (first (sheet-children pane)))) (defmethod allocate-space ((pane top-level-sheet-pane) width height) (unless (pane-space-requirement pane) (setf (pane-space-requirement pane) (compose-space pane))) (when (first (sheet-children pane)) (allocate-space (first (sheet-children pane)) (clamp width (sr-min-width pane) (sr-max-width pane)) (clamp height (sr-min-height pane) (sr-max-height pane))))) #+nil ; old (defmethod handle-event ((pane top-level-sheet-pane) (event window-configuration-event)) (let ((x (window-configuration-event-x event)) (y (window-configuration-event-y event)) (width (window-configuration-event-width event)) (height (window-configuration-event-height event))) ;; avoid going into an infinite loop by not using (setf sheet-transformation) (setf (slot-value pane 'transformation) (make-translation-transformation x y)) (invalidate-cached-transformations pane) ;; avoid going into an infinite loop by not using (setf sheet-region) (setf (slot-value pane 'region) (make-bounding-rectangle 0 0 width height)) (invalidate-cached-regions pane) (allocate-space pane width height))) (defmethod handle-event ((pane top-level-sheet-pane) (event window-configuration-event)) (let ((x (window-configuration-event-x event)) (y (window-configuration-event-y event)) (width (window-configuration-event-width event)) (height (window-configuration-event-height event))) (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) (sheet-region pane) (let ((old-width (- old-x2 old-x1)) (old-height (- old-y2 old-y1))) ;; avoid going into an infinite loop by not using (setf sheet-transformation) (setf (slot-value pane 'transformation) (make-translation-transformation x y)) (invalidate-cached-transformations pane) ;; avoid going into an infinite loop by not using (setf sheet-region) (setf (slot-value pane 'region) (make-bounding-rectangle 0 0 width height)) (when (or (/= width old-width) (/= height old-height)) (invalidate-cached-regions pane) (allocate-space pane width height)))))) (defmethod handle-event ((pane top-level-sheet-pane) (event window-manager-delete-event)) (frame-exit (pane-frame (event-sheet event)))) ;;;; UNMANAGED-TOP-LEVEL-SHEET PANE (defclass unmanaged-top-level-sheet-pane (top-level-sheet-pane) () (:documentation "Top-level sheet without window manager intervention")) (defmethod sheet-native-transformation ((sheet top-level-sheet-pane)) +identity-transformation+) (defmethod change-space-requirements ((pane unmanaged-top-level-sheet-pane) &rest space-req-keys &key resize-frame &allow-other-keys) ;; Special variant for unmanaged-top-level-sheet-pane. Since the ;; pane is unmanaged there is no window manager which can offer the ;; user options to resize this top level pane. ;; ;; This should however be changed by turning on the :resize-frame ;; option of the frame of the unmanaged-top-level-sheet-pane and ;; handle it in the method on top-level-sheet. ;; ;; This is currently not done, since: ;; . we obviously lack the :resize-frame option ;; . of some reason the frame of e.g. a command-menu is the ;; application-frame. I am not sure if this is totally right. ;; ;; --GB 2003-03-16 (declare (ignore space-req-keys resize-frame)) (let ((w (space-requirement-width (compose-space pane))) (h (space-requirement-height (compose-space pane)))) (resize-sheet pane w h) (allocate-space pane w h) )) ;;;; box-layout-mixin ;; Now each child (client) of a box-layout pane is described by the ;; following class: (defclass box-client () ((fillp :initarg :fillp :initform nil :reader box-client-fillp :documentation "Whether this child can stretch infinitly.") (fixed-size :initarg :fixed-size :initform nil :reader box-client-fixed-size :documentation "Possible fixed size of a child.") (proportion :initarg :proportion :initform nil :reader box-client-proportion :documentation "Proportion child should get of excess space.") (pane :initarg :pane :reader box-client-pane :documentation "Either the child pane or NIL."))) (defclass box-layout-mixin () ((box-layout-orientation :initarg :box-layout-orientation :initform :vertical :type (member :vertical :horizontal) :accessor box-layout-orientation) (clients :accessor box-layout-mixin-clients :initform nil) ) (:documentation "Mixin class for layout panes, which want to behave like a HBOX/VBOX.")) ;; First we need to make sure that the list of clients and the list of ;; children agree with each other. (defmethod sheet-adopt-child :after ((sheet box-layout-mixin) child) ;; When the child is already known in the client list we add no new ;; client object. (unless (find child (box-layout-mixin-clients sheet) :key #'box-client-pane) (setf (box-layout-mixin-clients sheet) (append (box-layout-mixin-clients sheet) (list (make-instance 'box-client :pane child)))) (when (and (sheet-enabled-p sheet) (sheet-parent sheet)) (change-space-requirements sheet)))) (defmethod sheet-disown-child :after ((sheet box-layout-mixin) (child sheet) &key errorp) (declare (ignore errorp)) (setf (box-layout-mixin-clients sheet) (remove-if (lambda (client) (eq (box-client-pane client) child)) (box-layout-mixin-clients sheet))) (when (and (sheet-enabled-p sheet) (sheet-parent sheet)) (change-space-requirements sheet))) (defclass rack-layout-mixin (box-layout-mixin) ((box-layout-orientation :initarg :box-layout-orientation :initform :vertical :type (member :vertical :horizontal) :accessor box-layout-orientation)) (:documentation "Mixin class for layout panes, which want to behave like a HRACK/VRACK.")) (defmethod compose-space ((pane box-layout-mixin) &key width height) (declare (ignore width height)) (if (eq (box-layout-orientation pane) :vertical) (box-layout-mixin/vertically-compose-space pane) (box-layout-mixin/horizontally-compose-space pane))) (defmethod allocate-space ((pane box-layout-mixin) width height) (if (eq (box-layout-orientation pane) :vertical) (box-layout-mixin/vertically-allocate-space pane width height) (box-layout-mixin/horizontally-allocate-space pane width height))) (defvar *dump-allocate-space* nil) (dada ((major width height) (minor height width) (xbox hbox vbox) (xrack hrack vrack) (xically horizontally vertically) (major-spacing x-spacing y-spacing) (minor-spacing x-spacing y-spacing) ) (defmethod xically-content-sr** ((pane box-layout-mixin) client) (let (p) (let ((sr (if (box-client-pane client) (compose-space (box-client-pane client)) (make-space-requirement :width 0 :min-width 0 :max-width 0 :height 0 :min-height 0 :max-height 0)))) (cond ((box-client-fillp client) (make-space-requirement :major (space-requirement-major sr) :min-major (space-requirement-min-major sr) :max-major +fill+ :minor (space-requirement-minor sr) :min-minor (space-requirement-min-minor sr) :max-minor (space-requirement-max-minor sr))) ((setq p (box-client-fixed-size client)) (make-space-requirement :major p :min-major p :max-major p :minor (if sr (space-requirement-minor sr) 0) :min-minor (if sr (space-requirement-min-minor sr) 0) :max-minor (if sr (space-requirement-max-minor sr) 0))) (t sr) )))) (defmethod xically-content-sr*** ((pane box-layout-mixin) client major) (let (p) (let ((sr (if (box-client-pane client) (compose-space (box-client-pane client)) (make-space-requirement :width 0 :min-width 0 :max-width 0 :height 0 :min-height 0 :max-height 0)))) (cond ((box-client-fillp client) (make-space-requirement :major (space-requirement-major sr) :min-major (space-requirement-min-major sr) :max-major +fill+ :minor (space-requirement-minor sr) :min-minor (space-requirement-min-minor sr) :max-minor (space-requirement-max-minor sr))) ((setq p (box-client-fixed-size client)) (make-space-requirement :major p :min-major p :max-major p :minor (if sr (space-requirement-minor sr) 0) :min-minor (if sr (space-requirement-min-minor sr) 0) :max-minor (if sr (space-requirement-max-minor sr) 0))) ((setq p (box-client-proportion client)) (make-space-requirement :major (clamp (* p major) (space-requirement-min-major sr) (space-requirement-max-major sr)) :min-major (space-requirement-min-major sr) :max-major (space-requirement-max-major sr) :minor (if sr (space-requirement-minor sr) 0) :min-minor (if sr (space-requirement-min-minor sr) 0) :max-minor (if sr (space-requirement-max-minor sr) 0))) (t sr) )))) (defmethod box-layout-mixin/xically-compose-space ((pane box-layout-mixin)) (let ((n (length (sheet-enabled-children pane)))) (with-slots (major-spacing) pane (loop for client in (box-layout-mixin-clients pane) for sr = (xically-content-sr** pane client) sum (space-requirement-major sr) into major sum (space-requirement-min-major sr) into min-major sum (space-requirement-max-major sr) into max-major maximize (space-requirement-minor sr) into minor maximize (space-requirement-min-minor sr) into min-minor minimize (space-requirement-max-minor sr) into max-minor finally (return (space-requirement+* (make-space-requirement :major major :min-major (min min-major major) :max-major (max max-major major) :minor minor :min-minor (min min-minor minor) :max-minor (max max-minor minor)) :min-major (* (1- n) major-spacing) :max-major (* (1- n) major-spacing) :major (* (1- n) major-spacing) :min-minor 0 :max-minor 0 :minor 0)))))) (defmethod box-layout-mixin/xically-allocate-space-aux* ((box box-layout-mixin) width height) (declare (ignorable width height)) (let ((children (reverse (sheet-enabled-children box)))) (with-slots (major-spacing) box (let* ((content-srs (mapcar #'(lambda (c) (xically-content-sr*** box c major)) (box-layout-mixin-clients box))) (allot (mapcar #'ceiling (mapcar #'space-requirement-major content-srs))) (wanted (reduce #'+ allot)) (excess (- major wanted (* (1- (length children)) major-spacing)))) (when *dump-allocate-space* (format *trace-output* "~&;; ~S ~S~%" 'box-layout-mixin/xically-allocate-space-aux* box) (format *trace-output* "~&;; major = ~D, wanted = ~D, excess = ~D, allot = ~D.~%" major wanted excess allot)) (let ((qvector (mapcar (lambda (c) (cond ((box-client-fillp c) (vector 1 0 0)) (t (vector 0 0 (abs (- (if (> excess 0) (space-requirement-max-major (xically-content-sr*** box c major)) (space-requirement-min-major (xically-content-sr*** box c major))) (space-requirement-major (xically-content-sr*** box c major)))))))) (box-layout-mixin-clients box)))) ;; (when *dump-allocate-space* (format *trace-output* "~&;; old allotment = ~S.~%" allot) (format *trace-output* "~&;; qvector = ~S.~%" qvector) (format *trace-output* "~&;; qvector 0 = ~S.~%" (mapcar #'(lambda (x) (elt x 0)) qvector)) (format *trace-output* "~&;; qvector 1 = ~S.~%" (mapcar #'(lambda (x) (elt x 1)) qvector)) (format *trace-output* "~&;; qvector 2 = ~S.~%" (mapcar #'(lambda (x) (elt x 2)) qvector))) ;; (dotimes (j 3) (let ((sum (reduce #'+ (mapcar (lambda (x) (elt x j)) qvector)))) (unless (zerop sum) (setf allot (mapcar (lambda (allot q) (let ((q (elt q j))) (let ((delta (ceiling (if (zerop sum) 0 (/ (* excess q) sum))))) (decf excess delta) (decf sum q) (+ allot delta)))) allot qvector)) (when *dump-allocate-space* (format *trace-output* "~&;; new excess = ~F, allotment = ~S.~%" excess allot)) ))) ;; (when *dump-allocate-space* (format *trace-output* "~&;; excess = ~F.~%" excess) (format *trace-output* "~&;; new allotment = ~S.~%" allot)) (values allot (mapcar #'ceiling (mapcar #'space-requirement-minor content-srs))) ))))) (defmethod box-layout-mixin/xically-allocate-space-aux* :around ((box rack-layout-mixin) width height) (declare (ignorable width height)) (multiple-value-bind (majors minors) (call-next-method) (values majors (mapcar (lambda (x) x minor) minors)))) ;; Now actually layout the children ;; ;; A rack pane would force the minor dimension of the child. A ;; box pane would just align the child according to the ;; alignment option. We do the same with the minor dimension. ;; (defmethod box-layout-mixin/xically-allocate-space ((pane box-layout-mixin) real-width real-height) (with-slots (major-spacing) pane (multiple-value-bind (majors minors) (box-layout-mixin/xically-allocate-space-aux* pane real-width real-height) (let ((x 0)) (loop for child in (box-layout-mixin-clients pane) for major in majors for minor in minors do (when (box-client-pane child) #+NIL (format *trace-output* "~&;; child ~S at 0, ~D ~D x ~D(~D)~%;; ~S~%" (box-client-pane child) x width height real-height (compose-space (box-client-pane child))) (layout-child (box-client-pane child) (pane-align-x (box-client-pane child)) (pane-align-y (box-client-pane child)) ((lambda (major minor) height width) x 0) ((lambda (major minor) width height) x 0) ((lambda (major minor) height width) width real-width) ((lambda (major minor) height width) real-height height) )) (incf x major) (incf x major-spacing)))))) (defmethod box-layout-mixin/xically-allocate-space ((pane rack-layout-mixin) real-width real-height) (with-slots (major-spacing) pane (multiple-value-bind (majors minors) (box-layout-mixin/xically-allocate-space-aux* pane real-width real-height) (let ((x 0)) (loop for child in (box-layout-mixin-clients pane) for major in majors for minor in minors do (when (box-client-pane child) #+NIL (format *trace-output* "~&;; child ~S at 0, ~D ~D x ~D(~D)~%;; ~S~%" (box-client-pane child) x width height real-height (compose-space (box-client-pane child))) (layout-child (box-client-pane child) :expand :expand ((lambda (major minor) height width) x 0) ((lambda (major minor) width height) x 0) ((lambda (major minor) height width) width real-width) ((lambda (major minor) height width) real-height height) )) (incf x major) (incf x major-spacing))))))) ;; #+nil (defmethod note-sheet-enabled :before ((pane pane)) ;; hmmm (when (panep (sheet-parent pane)) (change-space-requirements pane)) ) ;; #+nil (defmethod note-sheet-disabled :before ((pane pane)) ;; hmmm (when (panep (sheet-parent pane)) (change-space-requirements pane)) ) (defmethod reorder-sheets :after ((pane box-layout-mixin) new-order) ;; Bring the order of the clients in sync with the new order of the ;; children. (setf new-order (reverse new-order)) (let ((new-bcs (loop for bc in (box-layout-mixin-clients pane) collect (cond ((box-client-pane bc) (find (pop new-order) (box-layout-mixin-clients pane) :key #'box-client-pane)) (t bc))))) (assert (null (set-difference new-bcs (box-layout-mixin-clients pane)))) (setf (box-layout-mixin-clients pane) new-bcs)) ;; finally do a re-layout. (change-space-requirements pane) ) ;;;; (eval-when (:compile-toplevel :load-toplevel :execute) (defun make-box-macro-contents (contents) (loop for content in contents collect (if (and (consp content) (or (realp (car content)) (member (car content) '(+fill+ :fill)))) `(list ',(car content) ,(cadr content)) content)))) (macrolet ((frob (macro-name box rack equalize-arg equalize-key) (let ((equalize-key (make-keyword equalize-arg))) `(defmacro ,macro-name ((&rest options &key (,equalize-arg t) &allow-other-keys) &body contents) (with-keywords-removed (options (,equalize-key)) `(make-pane (if ,,equalize-arg ',',rack ',',box) ,@options :contents (list ,@(make-box-macro-contents contents)))))))) (frob horizontally hbox-pane hrack-pane equalize-height :equalize-height) (frob vertically vbox-pane vrack-pane equalize-width :equalize-width)) (defclass box-pane (box-layout-mixin composite-pane permanent-medium-sheet-output-mixin ;arg! ) () (:documentation "Superclass for hbox-pane and vbox-pane that provides the initialization common to both.")) (defmethod initialize-instance :after ((pane box-pane) &key contents) (labels ((parse-box-content (content) "Parses a box/rack content and returns a BOX-CLIENT instance." ;; ### we need to parse more (cond ;; ((panep content) (make-instance 'box-client :pane content)) ;; +fill+ ((or (eql content +fill+) (eql content '+fill+) (eql content :fill)) (make-instance 'box-client :pane nil :fillp t)) ;; (+fill+ ) ((and (consp content) (or (member (car content) '(+fill+ :fill)) (eql (car content) +fill+))) (make-instance 'box-client :pane (cadr content) :fillp t)) ;; ;; ;; what about something like (30 :mm) ? ;; ((and (realp content) (>= content 0)) (make-instance 'box-client :pane nil :fixed-size content)) ;; ( pane) ((and (consp content) (realp (car content)) (>= (car content) 0) (consp (cdr content)) (panep (cadr content)) (null (cddr content))) (let ((number (car content)) (child (cadr content))) (if (< number 1) (make-instance 'box-client :pane child :proportion number) (make-instance 'box-client :pane child :fixed-size number)))) (t (error "~S is not a valid element in the ~S option of ~S." content :contents pane)) ))) (let* ((clients (mapcar #'parse-box-content contents)) (children (remove nil (mapcar #'box-client-pane clients)))) ;; (setf (box-layout-mixin-clients pane) clients) (mapc (curry #'sheet-adopt-child pane) children)))) (defclass hbox-pane (box-pane) () (:default-initargs :box-layout-orientation :horizontal)) (defclass vbox-pane (box-pane) () (:default-initargs :box-layout-orientation :vertical)) (defclass hrack-pane (rack-layout-mixin hbox-pane) () (:default-initargs :box-layout-orientation :horizontal)) (defclass vrack-pane (rack-layout-mixin vbox-pane) () (:default-initargs :box-layout-orientation :vertical)) ;;; TABLE PANE ;; TODO: The table and grid panes should respect the :x-spacing, ;; :y-spacing, and :spacing initargs. (defclass table-pane (composite-pane) ((array :documentation "Two-dimensional array holding the child panes as they are to be arranged.")) ;; (:documentation "The table layout implies that each colums has the same width and each lines has the same height - same rules for max and min -") ) (defmethod initialize-instance :after ((pane table-pane) &key contents &allow-other-keys) ;; check the format: contents should be list of lists of panes (unless (and (listp contents) (every (lambda (x) (and (listp x) (every #'panep x))) contents)) (error "~S option to ~S has bad format; should be a list of lists of panes.~%But its value is ~S." :contents pane contents)) ;; shovel child panes into the array and adopt them (let ((nrows (length contents)) (ncols (reduce #'max (mapcar #'length contents) :initial-value 0))) (with-slots (array) pane (setf array (make-array (list nrows ncols) :initial-element nil)) (loop for row in contents for i from 0 do (loop for cell in row for j from 0 do (setf (aref array i j) cell) (sheet-adopt-child pane cell)))))) (dada ((xically horizontally vertically) (major width height) (minor height width)) ;; (defun stack-space-requirements-xically (srs) (loop for sr in srs sum (space-requirement-major sr) into major sum (space-requirement-min-major sr) into min-major sum (space-requirement-max-major sr) into max-major maximize (space-requirement-minor sr) into minor maximize (space-requirement-min-minor sr) into min-minor minimize (space-requirement-max-minor sr) into max-minor finally (return (make-space-requirement :major major :min-major (min min-major major) :max-major (max max-major major) :minor minor :min-minor (min min-minor minor) :max-minor (max max-minor minor))))) (defun allot-space-xically (srs major) (let* ((allot (mapcar #'space-requirement-major srs)) (wanted (reduce #'+ allot)) (excess (- major wanted)) (qs (mapcar (lambda (sr) (abs (- (if (> excess 0) (space-requirement-max-major sr) (space-requirement-min-major sr)) (space-requirement-major sr)))) srs))) #+nil (format t "~&;; ~S: allot=~S, wanted=~S, excess=~S, qs=~S~%" 'allot-space-xically allot wanted excess qs) (let ((sum (reduce #'+ qs))) (cond ((zerop sum) (let ((n (length qs))) (setf allot (mapcar (lambda (allot q) (let ((delta (floor excess n))) (decf n) (decf excess delta) (decf sum q) (+ allot delta))) allot qs)))) (t (setf allot (mapcar (lambda (allot q) (let ((delta (ceiling (if (zerop sum) 0 (/ (* excess q) sum))))) (decf excess delta) (decf sum q) (+ allot delta))) allot qs))))) allot)) ) (defmethod table-pane-row-space-requirement ((pane table-pane) i) (with-slots (array) pane (stack-space-requirements-horizontally (loop for j from 0 below (array-dimension array 1) collect (compose-space (aref array i j)))))) (defmethod table-pane-col-space-requirement ((pane table-pane) j) (with-slots (array) pane (stack-space-requirements-vertically (loop for i from 0 below (array-dimension array 0) collect (compose-space (aref array i j)))))) (defmethod compose-space ((pane table-pane) &key width height) (declare (ignore width height)) (with-slots (array x-spacing y-spacing) pane ; ---v our problem is here. ; Which problem? --GB (let ((rsrs (loop for i from 0 below (array-dimension array 0) collect (table-pane-row-space-requirement pane i))) (csrs (loop for j from 0 below (array-dimension array 1) collect (table-pane-col-space-requirement pane j))) (xs (* x-spacing (1- (array-dimension array 1)))) (ys (* y-spacing (1- (array-dimension array 0))))) (let ((r (stack-space-requirements-vertically rsrs)) (c (stack-space-requirements-horizontally csrs))) (let ((res (make-space-requirement :width (+ (space-requirement-width r) xs) :min-width (+ (space-requirement-min-width r) xs) :max-width (+ (space-requirement-max-width r) xs) :height (+ (space-requirement-height c) ys) :min-height (+ (space-requirement-min-height c) ys) :max-height (+ (space-requirement-max-height c) ys)))) #+nil (format *trace-output* "~%;;; TABLE-PANE sr = ~S." res) res))))) (defmethod allocate-space ((pane table-pane) width height) (let (rsrs csrs) (declare (ignorable rsrs csrs)) (with-slots (array x-spacing y-spacing) pane ;; allot rows (let* ((xs (* x-spacing (1- (array-dimension array 1)))) (ys (* y-spacing (1- (array-dimension array 0)))) (rows (allot-space-vertically (setq rsrs (loop for i from 0 below (array-dimension array 0) collect (table-pane-row-space-requirement pane i))) (- height ys))) (cols (allot-space-horizontally (setq csrs (loop for j from 0 below (array-dimension array 1) collect (table-pane-col-space-requirement pane j))) (- width xs)))) #+nil (progn (format t "~&;; row space requirements = ~S." rsrs) (format t "~&;; col space requirements = ~S." csrs) (format t "~&;; row allotment: needed = ~S result = ~S (sum ~S)." height rows (reduce #'+ rows)) (format t "~&;; col allotment: needed = ~S result = ~S (sum ~S)." width cols (reduce #'+ cols)) (format t "~&;; align-x = ~S, align-y ~S~%" (pane-align-x pane) (pane-align-y pane))) ;; now finally layout each child (loop for y = 0 then (+ y h y-spacing) for h in rows for i from 0 do (loop for x = 0 then (+ x w x-spacing) for w in cols for j from 0 do (let ((child (aref array i j))) (layout-child child (pane-align-x child) (pane-align-y child) x y w h)))))))) (defun table-pane-p (pane) (typep pane 'table-pane)) (defmacro tabling ((&rest options &key (grid nil) &allow-other-keys) &body contents) (if grid `(make-pane 'grid-pane ,@options :contents (list ,@contents)) `(make-pane 'table-pane ,@options :contents (list ,@contents)))) ;(defmethod sheet-adopt-child :before ((table table-pane) child) ; (declare (ignore child)) ; (when (= (length (sheet-children table)) (table-pane-number table)) ; (error "The table can't adopt more childs than specified by the table-number"))) (defmethod sheet-disowned-child :before ((table table-pane) child &key (error-p t)) (declare (ignore child error-p)) (error "The table pane can't disown one of its child")) ;;; GRID PANE (defclass grid-pane (table-pane) () (:documentation "Be careful : each cells has the same size in the two dimentions. In other words : if the cell sizes are width, height then width = grid-width / number of children per line height = grid-height / number of children per column. =====> this is for all cells.")) (defun grid-p (pane) (typep pane 'grid-pane)) (defmethod compose-space ((grid grid-pane) &key width height) (declare (ignore width height)) (mapc #'compose-space (sheet-children grid)) (with-slots (array) grid (loop with nb-children-pl = (array-dimension array 1) ;(table-pane-number grid) with nb-children-pc = (array-dimension array 0) ;(/ (length (sheet-children grid)) nb-children-pl) for child in (sheet-children grid) and width = 0 then (max width (sr-width child)) and height = 0 then (max height (sr-height child)) and max-width = 5000000 then (min max-width (sr-min-width child)) and max-height = 5000000 then (min max-height (sr-max-height child)) and min-width = 0 then (max min-width (sr-min-width child)) and min-height = 0 then (max min-height (sr-min-height child)) finally (return (make-space-requirement :width (* width nb-children-pl) :height (* height nb-children-pc) :max-width (* width nb-children-pl) :max-height (* max-height nb-children-pc) :min-width (* min-width nb-children-pl) :min-height (* min-height nb-children-pc)))))) (defmethod allocate-space ((grid grid-pane) width height) (with-slots (array) grid (loop with nb-kids-p-l = (array-dimension array 1) ;(table-pane-number grid) with nb-kids-p-c = (array-dimension array 0) ;(/ (length (sheet-children grid)) nb-kids-p-l) for c from nb-kids-p-c downto 1 for row-index from 0 by 1 for tmp-height = height then (decf tmp-height new-height) for new-height = (/ tmp-height c) for y = 0 then (+ y new-height) do (loop for col-index from 0 by 1 for l from nb-kids-p-l downto 1 for child = (aref array row-index col-index) for tmp-width = width then (decf tmp-width new-width) for new-width = (/ tmp-width l) for x = 0 then (+ x new-width) do (move-sheet child x y) (allocate-space child (round new-width) (round new-height)))))) ;;; SPACING PANE (defclass spacing-pane (;;standard-space-requirement-options-mixin single-child-composite-pane permanent-medium-sheet-output-mixin) ((border-width :initarg :thickness :initform 1)) (:documentation "Never trust a random documentation string.")) (defmacro spacing ((&rest options) &body contents) `(make-pane 'spacing-pane ,@options :contents (list ,@contents))) (defun spacing-p (pane) (typep pane 'spacing-pane)) (defmethod initialize-instance :after ((spacing spacing-pane) &key thickness contents &allow-other-keys) (declare (ignorable thickness contents)) (with-slots (user-width user-min-width user-max-width user-height user-min-height user-max-height) spacing #+nil(setf user-width (max (or thickness 0) (or user-width 0))) #+nil(setf user-height (max (or thickness 0) (or user-height 0))))) (defmethod compose-space ((pane spacing-pane) &key width height) (declare (ignore width height)) (with-slots (border-width) pane (let ((sr (call-next-method))) (make-space-requirement :width (+ (* 2 border-width) (space-requirement-width sr)) :height (+ (* 2 border-width) (space-requirement-height sr)) :min-width (+ (* 2 border-width) (space-requirement-min-width sr)) :min-height (+ (* 2 border-width) (space-requirement-min-height sr)) :max-width (+ (* 2 border-width) (space-requirement-max-width sr)) :max-height (+ (* 2 border-width) (space-requirement-max-height sr)))))) (defmethod allocate-space ((pane spacing-pane) width height) (with-slots (border-width) pane (let ((child (first (sheet-children pane))) (new-width (- width border-width border-width)) (new-height (- height border-width border-width))) (layout-child child (pane-align-x pane) (pane-align-y pane) border-width border-width new-width new-height)))) ;;; OUTLINED PANE ;; same as SPACING-PANE but a different default background. (defclass outlined-pane (spacing-pane) () (:default-initargs :background +black+)) (defmacro outlining ((&rest options) &body contents) `(make-pane 'outlined-pane ,@options :contents (list ,@contents))) ;;; BORDER PANE ;; same as outlined-pane, but thickness is now called border-width. (defclass border-pane (outlined-pane) ((border-width :initarg :border-width :initform 1 :reader border-pane-width)) (:documentation "")) (defmacro bordering ((&rest options) &body contents) `(make-pane 'border-pane ,@options :contents (list ,@contents))) (defmethod pane-border ((pane basic-pane)) (let ((parent (sheet-parent pane))) (when (and parent (typep parent 'border-pane)) parent))) ;;; RAISED PANE (defclass raised-pane (border-pane permanent-medium-sheet-output-mixin) () (:default-initargs :border-width 2)) (defmacro raising ((&rest options) &body contents) `(make-pane 'raised-pane ,@options :contents (list ,@contents))) (defmethod handle-repaint ((pane raised-pane) region) (declare (ignore region)) (with-slots (border-width) pane (multiple-value-call #'draw-bordered-rectangle* pane (bounding-rectangle* (sheet-region pane)) :style :outset :border-width border-width))) ;;; LOWERED PANE (defclass lowered-pane (border-pane permanent-medium-sheet-output-mixin) () (:default-initargs :border-width 2)) (defmacro lowering ((&rest options) &body contents) `(make-pane 'lowered-pane ,@options :contents (list ,@contents))) (defmethod handle-repaint ((pane lowered-pane) region) (declare (ignore region)) (with-slots (border-width) pane (multiple-value-call #'draw-bordered-rectangle* pane (bounding-rectangle* (sheet-region pane)) :style :inset :border-width border-width))) ;;; RESTRAINING PANE (defclass restraining-pane (single-child-composite-pane) ()) (defun restraining-pane-p (pane) (typep pane 'restraining-pane)) (defmacro restraining ((&rest options) &body contents) `(make-pane 'restraining-pane ,@options :contents (list ,@contents))) (defmethod note-space-requirements-changed ((pane restraining-pane) child) (declare (ignore pane child))) ;;; BBOARD PANE (defclass bboard-pane (composite-pane) ()) (defmethod compose-space ((bboard bboard-pane) &key width height) (declare (ignore width height)) (make-space-requirement :width 300 :height 300)) ;;; VIEWPORT (defclass viewport-pane (single-child-composite-pane) ()) (defmethod compose-space ((pane viewport-pane) &key width height) (declare (ignorable width height)) ;; I _think_ this is right, it certainly shouldn't be the ;; requirements of the child, apart from the max sizes. If the child ;; does not want to go bigger than a specific size, we should not ;; force it to do so. (let ((child-sr (compose-space (first (sheet-children pane))))) (if child-sr (make-space-requirement :max-width (space-requirement-max-width child-sr) :max-height (space-requirement-max-height child-sr)) (make-space-requirement)))) (defmethod allocate-space ((pane viewport-pane) width height) (with-slots (hscrollbar vscrollbar) (sheet-parent pane) (let* ((child (sheet-child pane)) (child-space (compose-space child)) (child-width (space-requirement-width child-space)) (child-min-width (space-requirement-min-width child-space)) (child-height (space-requirement-height child-space)) (child-min-height (space-requirement-min-height child-space))) (move-and-resize-sheet child (if hscrollbar (- (gadget-value hscrollbar)) 0) (if vscrollbar (- (gadget-value vscrollbar)) 0) (max child-width width) (max child-height height)) ; move-and-resize-sheet does not allocate space for the sheet... ; so we do it manually for this case, which may be wrong - CHECKME ; if this is the right place, reusing the above calculation might be a good idea (allocate-space child (max child-min-width child-width width) (max child-min-height child-height height))))) (defmethod note-input-focus-changed ((pane viewport-pane) state) (note-input-focus-changed (sheet-child pane) state)) ;; This method ensures that when the child changes size, the viewport ;; will move its focus so that it will not display a region outside of ;; `child' (if at all possible, this ideal can be circumvented by ;; creating a child sheet that is smaller than the viewport). I do not ;; believe having a viewport look at "empty" space is ever useful. (defmethod note-space-requirements-changed ((pane viewport-pane) child) (let ((viewport-width (bounding-rectangle-width pane)) (viewport-height (bounding-rectangle-height pane)) (child-width (bounding-rectangle-width child)) (child-height (bounding-rectangle-height child))) (destructuring-bind (horizontal-scroll vertical-scroll) (mapcar #'- (multiple-value-list (transform-position (sheet-transformation child) 0 0))) ;; XXX: We cannot use `scroll-extent', because McCLIM ignores it ;; unless the scrollee happens to be drawing. Very weird, should ;; be fixed. ;; It's not a bug, it's a feature. This requires further thought. -Hefner (move-sheet child (round (- (if (> (+ horizontal-scroll viewport-width) child-width) (- child-width viewport-width) horizontal-scroll))) (round (- (if (> (+ vertical-scroll viewport-height) child-height) (- child-height viewport-height) vertical-scroll)))) (scroller-pane/update-scroll-bars (sheet-parent pane)) #+NIL (scroll-extent child (if (> (+ horizontal-scroll viewport-width) child-width) (max 0 (- child-width viewport-width)) horizontal-scroll) (if (> (+ vertical-scroll viewport-height) child-height) (max 0 (- child-height viewport-height)) vertical-scroll))))) ;;;; ;;;; SCROLLER PANE ;;;; ;;; How scrolling is done ;; The scroll-pane has a child window called the 'viewport', which ;; itself has the scrolled client pane as child. To scroll the client ;; pane is to move it [to possibly negative coordinates]. ;; ;; So the viewport is just a kind of hole, where some part of the ;; scrolled window shows through. ;; ;;; How the scroll bars are set up ;; The scroll-bar's min/max values match the min/max arguments to ;; scroll-extent. The thumb-size is then calculated accordingly. ;; (defparameter *scrollbar-thickness* 17) (defvar clim-extensions:*default-vertical-scroll-bar-position* :right "Default for the :VERTICAL-SCROLL-BAR-POSITION init arg of a SCROLLER-PANE. Set it to :LEFT to have the vertical scroll bar of a SCROLLER-PANE appear on the ergonomic left hand side, or leave set to :RIGHT to have it on the distant right hand side of the scroller.") (defclass scroller-pane (composite-pane) ((scroll-bar :type scroll-bar-spec ; (member t :vertical :horizontal nil) ;; ### Note: I added NIL here, so that the application ;; programmer can switch off scroll bars alltogether. ;; The spec though has it neither in the description of ;; SCROLLER-PANE, nor in the description of ;; MAKE-CLIM-STREAM-PANE, but in OPEN-WINDOW-STREAM. ;; ;; One might argue that in case of no scroll-bars the ;; application programmer can just skip the scroller ;; pane altogether. Bu I think that the then needed ;; special casing on having a scroller pane or a bare ;; viewport at hand is an extra burden, that can be ;; avoided. ;; --GB 2005-11-29 :initform t :initarg :scroll-bar :accessor scroller-pane-scroll-bar) (viewport :initform nil) (vscrollbar :initform nil) (hscrollbar :initform nil) (suggested-width :initform 300 :initarg :suggested-width) (suggested-height :initform 300 :initarg :suggested-height) (vertical-scroll-bar-position :initform clim-extensions:*default-vertical-scroll-bar-position* :initarg :vertical-scroll-bar-position :type (member :left :right) :documentation "Whether to put the vertical scroll bar on the left hand or right hand side of the scroller pane.")) (:default-initargs :x-spacing 4 :y-spacing 4)) (defgeneric scroll-bar-values (scroll-bar) (:documentation "Returns the min value, max value, thumb size, and value of a scroll bar. When Setf-ed, updates the scroll bar graphics")) (defgeneric* (setf scroll-bar-values) (min-value max-value thumb-size value scroll-bar)) (defmacro scrolling ((&rest options) &body contents) `(let ((viewport (make-pane 'viewport-pane :contents (list ,@contents)))) (make-pane 'scroller-pane ,@options :contents (list viewport)))) ;;; Layout (defmethod compose-space ((pane scroller-pane) &key width height) (declare (ignore width height)) (with-slots (viewport vscrollbar hscrollbar suggested-width suggested-height x-spacing y-spacing scroll-bar) pane (if viewport (let ((req ;; v-- where does this requirement come from? ;; a: just an arbitrary default (make-space-requirement :width suggested-width :height suggested-height :max-width +fill+ :max-height +fill+ :min-width (max (* 2 x-spacing) (if (null scroll-bar) 0 30)) :min-height (max (* 2 y-spacing) (if (null scroll-bar) 0 30)))) (viewport-child (first (sheet-children viewport)))) (when vscrollbar (setq req (space-requirement+* (space-requirement-combine #'max req (compose-space vscrollbar)) :height *scrollbar-thickness* :min-height *scrollbar-thickness* :max-height *scrollbar-thickness*))) (when hscrollbar (setq req (space-requirement+* (space-requirement-combine #'max req (compose-space hscrollbar)) :width *scrollbar-thickness* :min-width *scrollbar-thickness* :max-width *scrollbar-thickness*))) (let* ((viewport-sr (compose-space viewport :width suggested-width :height suggested-height)) (max-width (+ (space-requirement-max-width viewport-sr) (if vscrollbar *scrollbar-thickness* 0) ;; I don't know why this is necessary. (if (extended-output-stream-p viewport-child) (* 4 (stream-vertical-spacing viewport-child)) 0))) (max-height (+ (space-requirement-max-height viewport-sr) (if hscrollbar *scrollbar-thickness* 0) ;; I don't know why this is necessary. (if (extended-output-stream-p viewport-child) (* 4 (stream-vertical-spacing viewport-child)) 0)))) (setq req (make-space-requirement :width (min (space-requirement-width req) max-width) :height (min (space-requirement-height req) max-height) :min-width (min (space-requirement-min-width req) max-width) :min-height (min (space-requirement-min-height req) max-height) :max-width max-width :max-height max-height))) req) (make-space-requirement)))) (defmethod allocate-space ((pane scroller-pane) width height) (with-slots (viewport vscrollbar hscrollbar x-spacing y-spacing vertical-scroll-bar-position) pane (let* ((vsbar-width (if vscrollbar (space-requirement-width (compose-space vscrollbar)) 0)) (hsbar-height (if hscrollbar (space-requirement-height (compose-space hscrollbar)) 0)) (viewport-width (- width vsbar-width)) (viewport-height (- height hsbar-height))) (when vscrollbar (move-sheet vscrollbar (ecase vertical-scroll-bar-position (:left 0) (:right (- width vsbar-width))) 0) (allocate-space vscrollbar vsbar-width (- height hsbar-height))) (when hscrollbar (move-sheet hscrollbar (ecase vertical-scroll-bar-position (:left vsbar-width) (:right 0)) (- height hsbar-height)) (allocate-space hscrollbar (- width vsbar-width) hsbar-height)) ;; ;; Recalculate the gadget-values of the scrollbars ;; (when vscrollbar (let* ((scrollee (first (sheet-children viewport))) (min 0) (max (- (max (space-requirement-height (compose-space scrollee)) viewport-height) viewport-height)) (ts viewport-height) (val (if (zerop (gadget-max-value vscrollbar)) 0 (* (/ (gadget-value vscrollbar) (gadget-max-value vscrollbar)) max)))) (setf (scroll-bar-values vscrollbar) (values min max ts val)))) (when hscrollbar (let* ((scrollee (first (sheet-children viewport))) (min 0) (max (- (max (space-requirement-width (compose-space scrollee)) viewport-width) viewport-width)) (ts viewport-width) (val (if (zerop (gadget-max-value hscrollbar)) 0 (* (/ (gadget-value hscrollbar) (gadget-max-value hscrollbar)) max)))) (setf (scroll-bar-values hscrollbar) (values min max ts val)))) (when viewport (move-sheet viewport (+ x-spacing (ecase vertical-scroll-bar-position (:left vsbar-width) (:right 0))) (+ y-spacing 0)) (allocate-space viewport (- viewport-width (* 2 x-spacing)) (- viewport-height (* 2 y-spacing))))))) ;;;; Initialization (defmethod scroller-pane/vertical-drag-callback ((pane scroller-pane) new-value) "Callback for the vertical scroll-bar of a scroller-pane." (with-slots (viewport hscrollbar vscrollbar) pane (let ((scrollee (first (sheet-children viewport)))) (when (pane-viewport scrollee) (move-sheet scrollee (round (if hscrollbar (- (gadget-value hscrollbar)) 0)) (round (- new-value))))))) (defmethod scroller-pane/horizontal-drag-callback ((pane scroller-pane) new-value) "Callback for the horizontal scroll-bar of a scroller-pane." (with-slots (viewport hscrollbar vscrollbar) pane (let ((scrollee (first (sheet-children viewport)))) (when (pane-viewport scrollee) (move-sheet scrollee (round (- new-value)) (round (if vscrollbar (- (gadget-value vscrollbar)) 0))))))) (defmethod scroller-pane/update-scroll-bars ((pane scroller-pane)) (with-slots (viewport hscrollbar vscrollbar) pane (let* ((scrollee (first (sheet-children viewport))) (scrollee-sr (sheet-region scrollee)) (viewport-sr (sheet-region viewport))) ;; (when hscrollbar (setf (scroll-bar-values hscrollbar) (values (bounding-rectangle-min-x scrollee-sr) (max (- (bounding-rectangle-max-x scrollee-sr) (bounding-rectangle-width viewport-sr)) (bounding-rectangle-min-x scrollee-sr)) (bounding-rectangle-width viewport-sr) (- (nth-value 0 (transform-position (sheet-transformation scrollee) 0 0)))))) ;; (when vscrollbar (setf (scroll-bar-values vscrollbar) (values (bounding-rectangle-min-y scrollee-sr) (max (- (bounding-rectangle-max-y scrollee-sr) (bounding-rectangle-height viewport-sr)) (bounding-rectangle-min-y scrollee-sr)) (bounding-rectangle-height viewport-sr) (- (nth-value 1 (transform-position (sheet-transformation scrollee) 0 0))))))))) (defmethod initialize-instance :after ((pane scroller-pane) &key contents &allow-other-keys) (sheet-adopt-child pane (first contents)) (with-slots (scroll-bar viewport vscrollbar hscrollbar) pane (setq viewport (first (sheet-children pane))) ;; make the background of the viewport match the background of the ;; things scrolled. ;; This doesn't appear to work, hence the "gray space" bugs. Actually ;; handy for observing when the space requirements get messed up.. -Hefner (when (first (sheet-children viewport)) (setf (slot-value pane 'background) ;### hmm ... (pane-background (first (sheet-children viewport))))) ;; make sure that we have ok options for the scroll-bar argument... (check-type scroll-bar scroll-bar-spec) ; (member :vertical :horizontal :both t nil)) (when (member scroll-bar '(:vertical :both t)) (setq vscrollbar (make-pane 'scroll-bar :orientation :vertical :client (first (sheet-children viewport)) :drag-callback (lambda (gadget new-value) (declare (ignore gadget)) (scroller-pane/vertical-drag-callback pane new-value)) :scroll-up-page-callback #'(lambda (scroll-bar) (scroll-page-callback scroll-bar 1)) :scroll-down-page-callback #'(lambda (scroll-bar) (scroll-page-callback scroll-bar -1)) :scroll-up-line-callback #'(lambda (scroll-bar) (scroll-line-callback scroll-bar 1)) :scroll-down-line-callback #'(lambda (scroll-bar) (scroll-line-callback scroll-bar -1)) :value-changed-callback (lambda (gadget new-value) (declare (ignore gadget)) (scroller-pane/vertical-drag-callback pane new-value)) :min-value 0 :max-value 1)) (sheet-adopt-child pane vscrollbar)) (when (member scroll-bar '(:horizontal :both t)) (setq hscrollbar (make-pane 'scroll-bar :orientation :horizontal :client (first (sheet-children viewport)) :drag-callback (lambda (gadget new-value) (declare (ignore gadget)) (scroller-pane/horizontal-drag-callback pane new-value)) :scroll-up-page-callback #'(lambda (scroll-bar) (scroll-page-callback scroll-bar 1)) :scroll-down-page-callback #'(lambda (scroll-bar) (scroll-page-callback scroll-bar -1)) :scroll-up-line-callback #'(lambda (scroll-bar) (scroll-line-callback scroll-bar 1)) :scroll-down-line-callback #'(lambda (scroll-bar) (scroll-line-callback scroll-bar -1)) :value-changed-callback (lambda (gadget new-value) (declare (ignore gadget)) (scroller-pane/horizontal-drag-callback pane new-value)) :min-value 0 :max-value 1)) (sheet-adopt-child pane hscrollbar)))) ;;;; Scrolling itself ;;;; Accounting for changed space requirements (defmethod change-space-requirements ((pane clim-extensions:viewport-pane) &rest ignore) (declare (ignore ignore)) (let* ((client (first (sheet-children pane))) (sr (compose-space client)) (width (max (bounding-rectangle-width pane) (space-requirement-width sr))) (height (max (bounding-rectangle-height pane) (space-requirement-height sr)))) (resize-sheet client width height) (allocate-space client width height) (scroller-pane/update-scroll-bars (sheet-parent pane)))) ;;;; (defun scroll-page-callback (scroll-bar direction) (let ((client (gadget-client scroll-bar))) (setf (gadget-value scroll-bar :invoke-callback t) (clamp (- (gadget-value scroll-bar) (* direction (funcall (if (eq (gadget-orientation scroll-bar) :vertical) #'bounding-rectangle-height #'bounding-rectangle-width) (pane-viewport-region client)))) (gadget-min-value scroll-bar) (gadget-max-value scroll-bar))))) (defun scroll-line-callback (scroll-bar direction) (let ((client (gadget-client scroll-bar))) (setf (gadget-value scroll-bar :invoke-callback t) (clamp (- (gadget-value scroll-bar) (* direction (if (extended-output-stream-p client) (stream-line-height client) 10))) ; picked an arbitrary number - BTS (gadget-min-value scroll-bar) (gadget-max-value scroll-bar))))) (defmethod pane-viewport ((pane basic-pane)) (let ((parent (sheet-parent pane))) (when (and parent (typep parent 'viewport-pane)) parent))) ;;; Default for streams that aren't even panes. (defmethod pane-viewport-region ((pane t)) nil) (defmethod pane-viewport-region ((pane basic-pane)) (let ((viewport (pane-viewport pane))) (and viewport (untransform-region (sheet-delta-transformation pane viewport) (sheet-region viewport))))) (defmethod pane-scroller ((pane basic-pane)) (let ((viewport (pane-viewport pane))) (when viewport (sheet-parent viewport)))) (defmethod scroll-extent ((pane basic-pane) x y) (when (pane-viewport pane) (move-sheet pane (round (- x)) (round (- y))) (when (pane-scroller pane) (scroller-pane/update-scroll-bars (pane-scroller pane))))) ;;; LABEL PANE (defclass label-pane (composite-pane permanent-medium-sheet-output-mixin) ((label :type string :initarg :label :accessor label-pane-label :initform "") (alignment :type (member :bottom :top) :initform :top :initarg :label-alignment :reader label-pane-label-alignment) (background :initform *3d-normal-color*)) (:default-initargs :align-y :center :text-style (make-text-style :sans-serif nil nil)) (:documentation "")) (defmacro labelling ((&rest options) &body contents) `(make-pane 'label-pane ,@options :contents (list ,@contents))) (defmethod label-pane-margins ((pane label-pane)) (let ((m0 2) (a (text-style-ascent (pane-text-style pane) pane)) (d (text-style-descent (pane-text-style pane) pane))) (values ;; margins of inner sheet region (+ a (* 2 m0)) (+ a (if (eq (label-pane-label-alignment pane) :top) d 0) (* 2 m0)) (+ a (* 2 m0)) (+ a (if (eq (label-pane-label-alignment pane) :top) 0 d) (* 2 m0)) ;; margins of surrounding border (+ m0 (/ a 2)) (+ m0 (/ a 2)) (+ m0 (/ a 2)) (+ m0 (if (eq (label-pane-label-alignment pane) :top) 0 d) (/ a 2)) ;; position of text (+ m0 (if (sheet-children pane) (+ a m0 m0 d) 0)) (+ m0 a)))) (defmethod compose-space ((pane label-pane) &key width height) (declare (ignore width height)) (let* ((w (text-size pane (label-pane-label pane))) (a (text-style-ascent (pane-text-style pane) pane)) (d (text-style-descent (pane-text-style pane) pane)) (m0 2) (h (+ a d m0 m0))) (cond ((and (sheet-children pane) ;; ### this other test below seems to be neccessary since ;; somebody decided that (NIL) is a valid return value ;; from sheet-children. --GB 2002-11-10 (first (sheet-children pane))) (let ((sr2 (compose-space (first (sheet-children pane))))) (multiple-value-bind (right top left bottom) (label-pane-margins pane) (make-space-requirement ;; label! :width (+ left right (max (+ w m0 m0) (space-requirement-width sr2))) :min-width (+ left right (max (+ w m0 m0) (space-requirement-min-width sr2))) :max-width (+ left right (max (+ w m0 m0) (space-requirement-max-width sr2))) :height (+ top bottom (space-requirement-height sr2)) :min-height (+ top bottom (space-requirement-min-height sr2)) :max-height (+ top bottom (space-requirement-max-height sr2)))))) (t (incf w m0) (incf w m0) (let ((sr1 (make-space-requirement :width w :min-width w :height h :min-height h :max-height h))) (when (sheet-children pane) (let ((sr2 (compose-space (first (sheet-children pane))))) (setf sr1 (make-space-requirement :width (max (space-requirement-width sr1) (space-requirement-width sr2)) :min-width (max (space-requirement-min-width sr1) (space-requirement-min-width sr2)) :max-width (max (space-requirement-max-width sr1) (space-requirement-max-width sr2)) :height (+ (space-requirement-height sr1) (space-requirement-height sr2)) :min-height (+ (space-requirement-min-height sr1) (space-requirement-min-height sr2)) :max-height (+ (space-requirement-max-height sr1) (space-requirement-max-height sr2)))))) sr1))))) (defmethod allocate-space ((pane label-pane) width height) (multiple-value-bind (right top left bottom) (label-pane-margins pane) (when (sheet-children pane) (multiple-value-bind (x1 y1 x2 y2) (values 0 0 width height) (move-sheet (first (sheet-children pane)) (+ x1 left) (+ y1 top)) (allocate-space (first (sheet-children pane)) (- (- x2 right) (+ x1 left)) (- (- y2 bottom) (+ y1 top))))))) (defmethod handle-repaint ((pane label-pane) region) (declare (ignore region)) (let ((m0 2) (a (text-style-ascent (pane-text-style pane) pane)) (d (text-style-descent (pane-text-style pane) pane)) (tw (text-size pane (label-pane-label pane)))) (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region pane) (multiple-value-bind (iright itop ileft ibottom bright btop bleft bbottom) (label-pane-margins pane) (declare (ignorable iright itop ileft ibottom)) (multiple-value-bind (tx ty) (values (ecase (pane-align-x pane) (:left (+ x1 m0 (if (sheet-children pane) (+ a m0 m0 d) 0))) (:right (- x2 m0 (if (sheet-children pane) (+ a m0 m0 d) 0) tw)) (:center (- (/ (- x2 x1) 2) (/ tw 2)))) (ecase (label-pane-label-alignment pane) (:top (+ y1 m0 a)) (:bottom (- y2 m0 d)))) (draw-text* pane (label-pane-label pane) tx ty) ;;; (when (sheet-children pane) (with-drawing-options (pane :clipping-region (region-difference (sheet-region pane) (make-rectangle* (- tx m0) (- ty a) (+ tx tw m0) (+ ty d)))) (draw-bordered-rectangle* pane (+ x1 bleft) (+ y1 btop) (- x2 bright) (- y2 bbottom) :style :groove)))))))) (defmethod initialize-instance :after ((pane label-pane) &key contents &allow-other-keys) (when contents (sheet-adopt-child pane (first contents)))) ;;; GENERIC FUNCTIONS (defgeneric* (setf window-viewport-position) (x y clim-stream-pane)) ;;; Mixin for panes which want the mouse wheel to scroll vertically (defclass mouse-wheel-scroll-mixin () ()) (defparameter *mouse-scroll-distance* 4 "Number of lines by which to scroll the window in response to the scroll wheel") (defgeneric scroll-quantum (pane) (:documentation "Returns the number of pixels respresenting a 'line', used to computed distance to scroll in response to mouse wheel events.")) (defmethod scroll-quantum (pane) 10) ; TODO: Connect this with the scroller-pane motion (defun find-viewport-for-scroll (pane) "Find a viewport in the chain of parents which contains 'pane', returning this viewport and the sheet immediately contained within." (cond ((not (typep pane 'basic-pane)) (values nil nil)) ((pane-viewport pane) (values (pane-viewport pane) pane)) (t (find-viewport-for-scroll (sheet-parent pane))))) (defun scroll-sheet (sheet vertical horizontal) (multiple-value-bind (viewport sheet) (find-viewport-for-scroll sheet) (declare (ignore viewport)) (with-bounding-rectangle* (vx0 vy0 vx1 vy1) (pane-viewport-region sheet) (with-bounding-rectangle* (sx0 sy0 sx1 sy1) (sheet-region sheet) (let ((viewport-height (- vy1 vy0)) (viewport-width (- vx1 vx0)) (delta (* *mouse-scroll-distance* (scroll-quantum sheet)))) ;; The coordinates (x,y) of the new upper-left corner of the viewport ;; must be "sx0 < x < sx1 - viewport-width" and ;; "sy0 < y < sy1 - viewport-height" (scroll-extent sheet (max sx0 (min (- sx1 viewport-width) (+ vx0 (* delta horizontal)))) (max sy0 (min (- sy1 viewport-height) (+ vy0 (* delta vertical)))))))))) ;; Note that handling this from dispatch-event is evil, and we shouldn't. (defmethod dispatch-event :around ((sheet mouse-wheel-scroll-mixin) (event pointer-button-press-event)) (if (find-viewport-for-scroll sheet) (let ((button (pointer-event-button event))) (cond ((eq button +pointer-wheel-up+) (scroll-sheet sheet -1 0)) ((eq button +pointer-wheel-down+) (scroll-sheet sheet 1 0)) ((eq button +pointer-wheel-left+) (scroll-sheet sheet 0 -1)) ((eq button +pointer-wheel-right+) (scroll-sheet sheet 0 1)) (t (call-next-method)))) ; not a scroll wheel button (call-next-method))) ; no viewport ;;; ;;; 29.4 CLIM Stream Panes ;;; ;;; A class that implements the display function invocation. It's put ;;; in a super class of clim-stream-pane so that redisplay-frame-pane ;;; on updating-output-stream-mixin can override that method. (defclass pane-display-mixin () ((display-function :initform 'clim-stream-pane-default-display-function :initarg :display-function :accessor pane-display-function))) (defmethod redisplay-frame-pane ((frame application-frame) (pane pane-display-mixin) &key force-p) (declare (ignore force-p)) (invoke-display-function frame pane) (fit-pane-to-output pane)) (defgeneric pane-double-buffering (pane)) (defmethod pane-double-buffering (pane) (declare (ignore pane)) nil) (defclass clim-stream-pane (updating-output-stream-mixin pane-display-mixin permanent-medium-sheet-output-mixin #-clim-mp standard-repainting-mixin standard-extended-input-stream standard-extended-output-stream standard-output-recording-stream ;; sheet-leaf-mixin sheet-multiple-child-mixin ; needed for GADGET-OUTPUT-RECORD basic-pane) ((redisplay-needed :initarg :display-time) (scroll-bars :type scroll-bar-spec ; (member t :vertical :horizontal nil) :initform nil :initarg :scroll-bars :accessor pane-scroll-bars) ; Should inherit from label-pane for this one ?? (label :type string :initform "" :initarg :label :reader pane-label) (text-margin :initarg :text-margin :reader pane-text-margin) (vertical-spacing :initarg :vertical-spacing :reader pane-vertical-spacing) (end-of-line-action :initform :wrap :initarg :end-of-line-action :reader pane-end-of-line-action) (end-of-page-action :initform :scroll :initarg :end-of-page-action :reader pane-end-of-page-action) (double-buffering :initform nil :initarg :double-buffering :reader pane-double-buffering) ;; Slots of space-requirement-options-mixin defined with accessors for our ;; convenience (user-width :accessor pane-user-width) (user-min-width :accessor pane-user-min-width) (user-max-width :accessor pane-user-max-width) (user-height :accessor pane-user-height) (user-min-height :accessor pane-user-min-height) (user-max-height :accessor pane-user-max-height)) (:documentation "This class implements a pane that supports the CLIM graphics, extended input and output, and output recording protocols.")) (defmethod interactive-stream-p ((stream clim-stream-pane)) t) (defun invoke-display-function (frame pane) (let ((display-function (pane-display-function pane))) (cond ((consp display-function) (apply (car display-function) frame pane (cdr display-function))) (display-function (funcall display-function frame pane)) (t nil)))) ;;; Handle :compute in the space requirement options ;;; XXX This should be expanded to handle all the options, not just ;;; height and width. (defmethod compose-space :around ((pane clim-stream-pane) &key width height) (declare (ignore width height)) (flet ((compute (val default) (if (eq val :compute) default val))) (if (or (eq (pane-user-width pane) :compute) (eq (pane-user-height pane) :compute)) (progn (with-output-recording-options (pane :record t :draw nil) ;; multiple-value-letf anyone? (multiple-value-bind (x y) (stream-cursor-position pane) (unwind-protect (invoke-display-function *application-frame* pane) (setf (stream-cursor-position pane) (values x y))))) (with-bounding-rectangle* (x1 y1 x2 y2) (stream-output-history pane) ;; Should we now get rid of the output history? ;; Why should we? --GB 2003-03-16 (reset-output-history pane) (let ((width (- x2 x1)) (height (- y2 y1))) ;; I don't want this letf here --GB 2003-01-23 (letf (((pane-user-width pane) (compute (pane-user-width pane) width)) ((pane-user-height pane) (compute (pane-user-height pane) height))) (prog1 (call-next-method)))))) (call-next-method)))) (defmethod compose-space ((pane clim-stream-pane) &key width height) (declare (ignorable width height)) (let ((w (bounding-rectangle-width (stream-output-history pane))) (h (bounding-rectangle-height (stream-output-history pane)))) (make-space-requirement :width w :min-width w :max-width +fill+ :height h :min-height h :max-height +fill+))) (defmethod window-clear ((pane clim-stream-pane)) (stream-close-text-output-record pane) (let ((output-history (stream-output-history pane))) (with-bounding-rectangle* (left top right bottom) output-history (when (sheet-viewable-p pane) (medium-clear-area (sheet-medium pane) left top right bottom))) (clear-output-record output-history)) (window-erase-viewport pane) (let ((cursor (stream-text-cursor pane))) (when cursor (setf (cursor-position cursor) (values 0 0)))) (scroll-extent pane 0 0) (change-space-requirements pane :width 0 :height 0)) (defmethod window-refresh ((pane clim-stream-pane)) (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region pane) (draw-rectangle* (sheet-medium pane) x1 y1 x2 y2 :ink +background-ink+)) (stream-replay pane)) (defun clim-stream-pane-default-display-function (frame pane) (declare (ignore frame)) (stream-replay pane)) (defmethod window-viewport ((pane clim-stream-pane)) (or (pane-viewport-region pane) (sheet-region pane))) (defmethod window-erase-viewport ((pane clim-stream-pane)) (with-bounding-rectangle* (x1 y1 x2 y2) (or (pane-viewport-region pane) (sheet-region pane)) (draw-rectangle* (sheet-medium pane) x1 y1 x2 y2 :ink +background-ink+))) (defmethod window-viewport-position ((pane clim-stream-pane)) (multiple-value-bind (x y) (bounding-rectangle* (stream-output-history pane)) (values x y))) (defmethod* (setf window-viewport-position) (x y (pane clim-stream-pane)) (scroll-extent pane x y) (values x y)) (defmethod stream-set-input-focus ((stream clim-stream-pane)) (with-slots (port) stream (prog1 (port-keyboard-input-focus port) (setf (port-keyboard-input-focus port) stream)))) #+nil (defmethod stream-set-input-focus ((stream null)) (let ((frame *application-frame*)) (prog1 (frame-keyboard-input-focus frame) (setf (frame-keyboard-input-focus frame) nil)))) ;;; output any buffered stuff before input (defmethod stream-read-gesture :before ((stream clim-stream-pane) &key timeout peek-p input-wait-test input-wait-handler pointer-button-press-handler) (declare (ignore timeout peek-p input-wait-test input-wait-handler pointer-button-press-handler)) (force-output stream)) (defmethod redisplay-frame-pane ((frame application-frame) (pane symbol) &key force-p) (let ((actual-pane (get-frame-pane frame pane))) (when actual-pane (redisplay-frame-pane frame actual-pane :force-p force-p)))) (define-presentation-method presentation-type-history-for-stream ((type t) (stream clim-stream-pane)) (funcall-presentation-generic-function presentation-type-history type)) (defmethod change-space-requirements :around ((pane clim-stream-pane) &key (width nil) (max-width nil) (height nil) (max-height nil) &allow-other-keys) (with-slots (seos-current-width seos-current-height) pane (setf seos-current-width (or max-width width seos-current-width)) (setf seos-current-height (or max-height height seos-current-height))) (call-next-method)) ;;; INTERACTOR PANES (defclass interactor-pane (cut-and-paste-mixin mouse-wheel-scroll-mixin clim-stream-pane) () (:default-initargs :display-time nil :end-of-line-action :scroll :scroll-bars :vertical :incremental-redisplay t)) (defmethod initialize-instance :after ((pane interactor-pane) &rest args) (declare (ignore args)) #+ignore (let ((cursor (stream-text-cursor pane))) (setf (cursor-visibility cursor) t))) ;;; KLUDGE: this is a hack to get keyboard focus (click-to-focus) ;;; roughly working for interactor panes. It's a hack somewhat ;;; analogous to the mouse-wheel / select-and-paste handling in ;;; DISPATCH-EVENT, just in a slightly different place. (defmethod frame-input-context-button-press-handler :before ((frame standard-application-frame) (stream interactor-pane) button-press-event) (let ((previous (stream-set-input-focus stream))) (when (and previous (typep previous 'gadget)) (let ((client (gadget-client previous)) (id (gadget-id previous))) (disarmed-callback previous client id))))) ;;; APPLICATION PANES (defclass application-pane (cut-and-paste-mixin mouse-wheel-scroll-mixin clim-stream-pane) () (:default-initargs :display-time :command-loop :scroll-bars t)) ;;; COMMAND-MENU PANE (defclass command-menu-pane (clim-stream-pane) () (:default-initargs :display-time :command-loop :incremental-redisplay t :scroll-bars t :display-function 'display-command-menu)) ;;; TITLE PANE (defclass title-pane (clim-stream-pane) () (:default-initargs :display-time t :scroll-bars nil :display-function 'display-title)) ;;; Pointer Documentation Pane (defparameter *default-pointer-documentation-background* +black+) (defparameter *default-pointer-documentation-foreground* +white+) (defvar *background-message-minimum-lifetime* 1 "The amount of seconds a background message will be kept alive.") (defclass pointer-documentation-pane (clim-stream-pane) ((background-message :initform nil :accessor background-message :documentation "An output record, or NIL, that will be shown when there is no pointer documentation to show.") (background-message-time :initform 0 :accessor background-message-time :documentation "The universal time at which the current background message was set.")) (:default-initargs :display-time nil :scroll-bars nil :default-view +pointer-documentation-view+ :height '(2 :line) :min-height '(2 :line) :max-height '(2 :line) :text-style (make-text-style :sans-serif :roman :normal) :foreground *default-pointer-documentation-foreground* :background *default-pointer-documentation-background* :end-of-line-action :allow :end-of-page-action :allow)) (defmethod stream-accept :before ((stream pointer-documentation-pane) type &rest args) (declare (ignore args)) (window-clear stream) (when (background-message stream) (setf (background-message stream) nil) (redisplay-frame-pane (pane-frame stream) stream))) (defmethod stream-accept :around ((pane pointer-documentation-pane) type &rest args) (declare (ignore args)) (unwind-protect (loop (handler-case (with-input-focus (pane) (return (call-next-method))) (parse-error () nil))) (window-clear pane))) ;;; CONSTRUCTORS (defun make-clim-stream-pane (&rest options &key (type 'clim-stream-pane) (scroll-bars :vertical) (border-width 1) &allow-other-keys) (with-keywords-removed (options (:type :scroll-bars :border-width)) ;; The user space requirement options belong to the scroller .. (let* ((space-keys '(:width :height :max-width :max-height :min-width :min-height)) (user-sr nil) (pane-options nil) (borderp (and border-width (> border-width 0)))) (loop for (key value) on options by #'cddr if (and (member key space-keys :test #'eq) (not (eq value :compute))) nconc (list key value) into space-options else nconc (list key value) into other-options end finally (progn (setq user-sr space-options) (setq pane-options other-options))) (let ((pane (apply #'make-pane type (append pane-options (unless (or scroll-bars borderp) user-sr))))) (when scroll-bars (setq pane (apply #'make-pane 'scroller-pane :scroll-bar scroll-bars :contents (list (make-pane 'viewport-pane :contents (list pane))) (unless borderp user-sr)))) (when borderp (setq pane (apply #'make-pane 'border-pane :border-width border-width :contents (list pane) user-sr))) pane)))) (defun make-clim-interactor-pane (&rest options) (apply #'make-clim-stream-pane :type 'interactor-pane options)) (defun make-clim-application-pane (&rest options) (apply #'make-clim-stream-pane :type 'application-pane options)) (defun make-clim-pointer-documentation-pane (&rest options) (apply #'make-clim-stream-pane :type 'pointer-documentation-pane options)) ;;; 29.4.5 Creating a Standalone CLIM Window (defclass window-stream (cut-and-paste-mixin mouse-wheel-scroll-mixin clim-stream-pane) ()) (defmethod close ((stream window-stream) &key abort) (declare (ignore abort)) (let ((frame (pane-frame stream))) (when frame (disown-frame (frame-manager frame) frame))) (when (next-method-p) (call-next-method))) (define-application-frame a-window-stream (standard-encapsulating-stream standard-extended-input-stream fundamental-character-output-stream standard-application-frame) ((stream) (scroll-bars :initform :vertical :initarg :scroll-bars)) (:panes (io (scrolling (:height 400 :width 700 :scroll-bar (slot-value *application-frame* 'scroll-bars)) (setf (slot-value *application-frame* 'stream) (make-pane 'window-stream :width 700 :height 2000))))) (:layouts (:default io))) (defun open-window-stream (&key port left top right bottom width height foreground background text-style (vertical-spacing 2) end-of-line-action end-of-page-action output-record (draw t) (record t) (initial-cursor-visibility :off) text-margin save-under input-buffer (scroll-bars :vertical) borders label) (declare (ignorable foreground background text-style vertical-spacing end-of-line-action end-of-page-action output-record draw record initial-cursor-visibility text-margin save-under borders label)) (setf port (or port (find-port))) (let* ((fm (find-frame-manager :port port)) (frame (make-application-frame 'a-window-stream :frame-event-queue input-buffer :frame-manager fm :pretty-name (or label "") :left left :top top :right right :bottom bottom :width width :height height :scroll-bars scroll-bars))) ;; Adopt and enable the pane (when (eq (frame-state frame) :disowned) (adopt-frame fm frame)) (unless (or (eq (frame-state frame) :enabled) (eq (frame-state frame) :shrunk)) (enable-frame frame)) ;; Start a new thread to run the event loop, if necessary. #+clim-mp (unless input-buffer (clim-sys:make-process (lambda () (let ((*application-frame* frame)) (redisplay-frame-panes frame :force-p t) (standalone-event-loop))))) (slot-value frame 'stream))) (defun standalone-event-loop () "An simple event loop for applications that want all events to be handled by handle-event methods, which also handles FRAME-EXIT." (let ((frame *application-frame*)) (handler-case (let ((queue (frame-event-queue frame))) (loop for event = (event-queue-read queue) ;; EVENT-QUEUE-READ in single-process mode calls PROCESS-NEXT-EVENT itself. do (handle-event (event-sheet event) event))) (frame-exit () (disown-frame (frame-manager frame) frame))))) ;;; These below were just hot fixes, are there still needed? Are even ;;; half-way correct? --GB ;;; ;;; These are needed, and are correct. "Implementations should also ;;; provide a ``trampoline'' for this generic function for output sheets; the ;;; trampoline will simply call the method for the medium. -- moore ;;; ;;; Thanks! --GB ;;; ;;; Why are they placed here? -- APD (defmethod text-size ((sheet sheet) string &rest more) (apply #'text-size (sheet-medium sheet) string more)) (defmethod text-style-ascent (ts (sheet sheet)) (text-style-ascent ts (sheet-medium sheet))) (defmethod text-style-descent (ts (sheet sheet)) (text-style-descent ts (sheet-medium sheet))) (defmethod text-style-height (ts (sheet sheet)) (text-style-height ts (sheet-medium sheet))) (defmethod text-style-width (ts (sheet sheet)) (text-style-width ts (sheet-medium sheet))) ; timer-event convenience (defmethod schedule-timer-event ((pane pane) token delay) (warn "Are you sure you want to use schedule-timer-event? It probably doesn't work.") (schedule-event pane (make-instance 'timer-event :token token :sheet pane) delay)) (defgeneric fit-pane-to-output (pane) (:method (pane) (declare (ignore pane)))) (defmethod fit-pane-to-output ((stream clim-stream-pane)) ;;; Guard against infinite recursion of size is set to :compute, as this ;;; could get called from the display function. We'll call compose-space ;;; here, which will invoke the display function again.. (when (and (sheet-mirror stream) (not (or (eq (pane-user-width stream) :compute) (eq (pane-user-height stream) :compute)))) (let* ((output (stream-output-history stream)) (fit-width (bounding-rectangle-max-x output)) (fit-height (bounding-rectangle-max-y output))) (multiple-value-bind (width min-width max-width height min-height max-height) (space-requirement-components (compose-space stream)) (change-space-requirements stream :min-width (max fit-width min-width) :min-height (max fit-height min-height) :width (max fit-width width) :height (max fit-height height) :max-width max-width :max-height max-height))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/clim-listener.asd0000644000175000017500000000207711345155771020256 0ustar pdmpdm;;; -*- lisp -*- (defpackage :clim-listener.system (:use :cl :asdf)) (in-package :clim-listener.system) (defsystem :clim-listener :depends-on (:mcclim #+sbcl :sb-posix) :components ((:module "Apps/Listener" :pathname #.(make-pathname :directory '(:relative "Apps" "Listener")) :components ((:file "package") (:file "appearance" :depends-on ("package")) (:file "util" :depends-on ("package")) (:file "icons" :depends-on ("package" "util")) (:file "file-types" :depends-on ("package" "icons" "util")) (:file "asdf" :depends-on ("package")) (:file "dev-commands" :depends-on ("package" "appearance" "icons" "file-types" "util" "asdf")) (:file "wholine" :depends-on ("package" "dev-commands" "util")) (:file "listener" :depends-on ("package" "wholine" "file-types" "icons" "dev-commands" "util")) #+CMU (:file "cmu-hacks" :depends-on ("package")))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/protocol-classes.lisp0000644000175000017500000001516311345155772021204 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2006 by Tim Moore (moore@bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Collect all the class definitions in the Spec in one file that is compiled ;;; and loaded early. (in-package :clim-internals) (defmacro define-protocol-class (name super-classes &optional slots &rest options) (let* ((sym-name (symbol-name name)) (protocol-predicate (intern (concatenate 'string sym-name (if (find #\- sym-name) "-" "") (symbol-name '#:p)))) (predicate-docstring (concatenate 'string "Protocol predicate checking for class " sym-name))) `(progn (defclass ,name ,super-classes ,slots ,@options) (let ((the-class (find-class ',name))) (setf (documentation the-class 'type) "CLIM protocol class") (defmethod initialize-instance :after ((object ,name) &key &allow-other-keys) (when (eq (class-of object) the-class) (error "~S is a protocol class and thus can't be instantiated" ',name)))) (defgeneric ,protocol-predicate (object) (:method ((object t)) nil) (:method ((object ,name)) t) (:documentation ,predicate-docstring)) ',name))) ;;; 3.1 General Regions (define-protocol-class bounding-rectangle ()) (define-protocol-class region (design)) (define-protocol-class path (region bounding-rectangle)) (define-protocol-class area (region bounding-rectangle)) (define-protocol-class region-set (region bounding-rectangle)) (define-protocol-class point (region bounding-rectangle)) (define-protocol-class polyline (path)) (define-protocol-class polygon (area)) (define-protocol-class line (polyline)) (define-protocol-class rectangle (polygon)) (define-protocol-class ellipse (area)) (define-protocol-class elliptical-arc (path)) ;;; 5.1 Transformations (define-protocol-class transformation ()) ;;; 7.1 Basic Sheet Classes (define-protocol-class sheet (bounding-rectangle)) ;;; 8.2 Standard Device Events (define-protocol-class event () ()) ;;; 8.3.1 Output Properties (define-protocol-class medium () ()) ;;; 9.2 Ports (define-protocol-class port ()) ;;; 10.3 Line Styles (define-protocol-class line-style ()) ;;; 11.1 Text Styles (define-protocol-class text-style () ()) ;;; 13.2 Basic Designs (define-protocol-class design ()) ;;; 13.3 Color class (define-protocol-class color (design)) ;;; 13.4 (define-protocol-class opacity (design)) ;;; 15.2 Extended Output Streams (define-protocol-class extended-output-stream (fundamental-character-output-stream) ;; CLIM Specification says that E-O-S is a subclass of ;; OUTPUT-STREAM, but it does not says what is it. ()) ;;; 15.3 The Text Cursor (define-protocol-class cursor ()) ;;; 16.2 Output Records (define-protocol-class output-record (bounding-rectangle) ()) (define-protocol-class displayed-output-record (output-record) ()) ;;; 16.3.2 Graphics Displayed Output Records (define-protocol-class graphics-displayed-output-record (displayed-output-record) ()) ;;; 16.3.3 Text Displayed Output Record (define-protocol-class text-displayed-output-record (displayed-output-record) ()) ;;; 16.4 Output Recording Streams (define-protocol-class output-recording-stream () ()) ;;; 17.3.1 Table Formatting Protocol (define-protocol-class table-output-record (output-record)) ;;; 17.3.2 Row and Column Formatting Protocol (define-protocol-class row-output-record (output-record)) (define-protocol-class column-output-record (output-record)) ;;; 17.3.3 Cell Formatting Protocol (define-protocol-class cell-output-record (output-record)) ;;; 17.3.4 Item List Formatting Protocol (define-protocol-class item-list-output-record () ()) ;;; 18.2 The Graph Formatting Protocol (define-protocol-class graph-output-record (output-record)) (define-protocol-class graph-node-output-record (output-record)) ;;; 21.3 Incremental Redisplay Protocol (define-protocol-class updating-output-record (output-record)) ;;; 22.2 Extended Input Streams (define-protocol-class extended-input-stream (fundamental-character-input-stream) ()) ;;; 22.4 The Pointer Protocol (define-protocol-class pointer () ()) ;;; 23.2 Presentations (define-protocol-class presentation ()) ;;; 23.6 Views (define-protocol-class view ()) ;;; 24.1.1 The Input Editing Stream Protocol (define-protocol-class input-editing-stream ()) ;;; 27.2 Command Tables (define-protocol-class command-table () ()) ;;; 28.2 Application Frames (define-protocol-class application-frame () ()) ;;; 28.5 Frame Managers ;;; XXX The slot definitions shouldn't be here, but there is no ;;; standard-frame-manager and I don't want to add these slots to all the frame ;;; manager classes right now. (define-protocol-class frame-manager () ((port :initarg :port :reader port) (frames :initform nil :reader frame-manager-frames))) ;;; 30.3 Basic Gadget Classes ;;; XXX Slots definitions should be banished. (define-protocol-class gadget (pane) ((id :initarg :id :initform (gensym "GADGET") :accessor gadget-id) (client :initarg :client :initform *application-frame* :accessor gadget-client) (armed-callback :initarg :armed-callback :initform nil :reader gadget-armed-callback) (disarmed-callback :initarg :disarmed-callback :initform nil :reader gadget-disarmed-callback) ;; [Arthur] I'm not so sure about the value for :initform. ;; Maybe T is better? Or maybe we should call ;; ACTIVATE-GADGET after creating a gadget? ;; ;; I think, T is correct here --GB (active-p :initform t :initarg :active :reader gadget-active-p) ;; ;; I am not so lucky with the armed slot in GADGET --GB (armed :initform nil) )) ;;; C.1 Encapsulating Streams (define-protocol-class encapsulating-stream () ()) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/grafts.lisp0000644000175000017500000000601107636702773017175 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) (defclass graft (sheet-multiple-child-mixin mirrored-sheet-mixin basic-sheet) ((orientation :initform :default :initarg :orientation :reader graft-orientation) (units :initform :device :initarg :units :reader graft-units) (mirror :initarg :mirror) ) ) (defmethod initialize-instance :after ((graft graft) &rest args) (declare (ignore args)) (port-register-mirror (port graft) graft (slot-value graft 'mirror))) ; (setf (graft graft) graft)) (defun graftp (x) (typep x 'graft)) (defmethod graft ((graft graft)) graft) (defmethod sheet-grafted-p ((sheet basic-sheet)) (if (sheet-parent sheet) (sheet-grafted-p (sheet-parent sheet)) nil)) (defmethod sheet-grafted-p ((graft graft)) t) (defmethod sheet-viewable-p ((graft graft)) (sheet-enabled-p graft)) (defun find-graft (&key (port nil) (server-path *default-server-path*) (orientation :default) (units :device)) (if (null port) (setq port (find-port :server-path server-path))) (block find-graft (map-over-grafts #'(lambda (graft) (if (and (eq orientation (graft-orientation graft)) (eq units (graft-units graft))) (return-from find-graft graft))) port) (return-from find-graft (make-graft port :orientation orientation :units units)))) (defun map-over-grafts (function port) (mapc function (port-grafts port))) (defmacro with-graft-locked (graft &body body) `(let ((graft ,graft)) ,@body)) #-(and) (defmethod graft-width ((graft graft) &key (units :device)) (if (eq units :device) 1000 1)) #-(and) (defmethod graft-height ((graft graft) &key (units :device)) (if (eq units :device) 1000 1)) (defun graft-pixels-per-millimeter (graft) ;; We assume square pixels here --GB (/ (graft-width graft :units :device) (graft-width graft :units :millimeters))) (defun graft-pixels-per-inch (graft) ;; We assume square pixels here --GB (/ (graft-width graft :units :device) (graft-width graft :units :inches))) (defmethod sheet-native-transformation ((sheet graft)) +identity-transformation+) (defmethod sheet-native-region ((sheet graft)) +everywhere+) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/coordinates.lisp0000644000175000017500000000460707666171003020217 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-INTERNALS; -*- ;;; -------------------------------------------------------------------------------------- ;;; Title: The coordinate Datatype ;;; Created: 1998-12-05 18:06 ;;; Author: Gilbert Baumann ;;; License: LGPL (See file COPYING for details). ;;; $Id: coordinates.lisp,v 1.6 2003/05/31 18:18:43 gilbert Exp $ ;;; -------------------------------------------------------------------------------------- ;;; (c) copyright 1998,1999,2003 by Gilbert Baumann ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) #|| (deftype coordinate () 'double-float) (defun coordinate (n) "Coerces N to be a coordinate." (declare (type number n)) (coerce n 'coordinate)) (defun coordinate-epsilon () ;; tweak if you like (* #.(expt 2 10) double-float-epsilon)) (defun coordinate= (x y) (< (abs (- x y)) (coordinate-epsilon))) (defun coordinate<= (x y) (<= (- x y) (coordinate-epsilon))) (defun coordinate/= (x y) (not (coordinate= x y))) ||# (deftype coordinate () 'real) (declaim (inline coordinate)) (defun coordinate (n) n) (declaim (inline coordinate-epsilon)) (defun coordinate-epsilon () 0) (declaim (inline coordinate=)) (defun coordinate= (x y) (= x y)) (declaim (inline coordinate<=)) (defun coordinate<= (x y) (<= x y)) (declaim (inline coordinate/=)) (defun coordinate/= (x y) (/= x y)) ;; $Log: coordinates.lisp,v $ ;; Revision 1.6 2003/05/31 18:18:43 gilbert ;; Took the easy route: I switched COORDINATE to being just REAL in an ;; attempt to keep McCLIM running using the latest CMUCL. This is however ;; a questionable thing as it hides the real type errors. ;; cl-mcclim-0.9.6.dfsg.cvs20100315.orig/dead-keys.lisp0000644000175000017500000002016711006434763017550 0ustar pdmpdm;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;; (c) copyright 2008 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Define various dead keys - perhaps this should be more ;;; backend-agnostic? Bah... (in-package :clim-internals) (defvar *dead-key-table* (make-hash-table :test 'equal) "A hash table mapping keyboard event names and characters to either a similar hash table or characters.") (defun set-dead-key-combination (character gestures table) "Set `gestures' to result in `character' in the hash table `table' (see `*dead-key-table*' for the format of the hash table)." (assert (not (null gestures))) (if (null (rest gestures)) ;; Just add it directly to this table. (setf (gethash (first gestures) table) character) ;; Ensure that the subtable exists. (let ((new-table (setf (gethash (first gestures) table) (gethash (first gestures) table (make-hash-table :test 'equal))))) (set-dead-key-combination character (rest gestures) new-table)))) (defmacro define-dead-key-combination (character (&rest gestures)) "Define a dead key combination that results in `character' when `gestures' (either characters or key names) is entered." (assert (>= (length gestures) 2)) `(set-dead-key-combination ,character ',gestures *dead-key-table*)) (define-dead-key-combination (code-char 193) (:dead-acute #\a)) (define-dead-key-combination (code-char 201) (:dead-acute #\e)) (define-dead-key-combination (code-char 205) (:dead-acute #\i)) (define-dead-key-combination (code-char 211) (:dead-acute #\o)) (define-dead-key-combination (code-char 218) (:dead-acute #\u)) (define-dead-key-combination (code-char 221) (:dead-acute #\y)) (define-dead-key-combination (code-char 225) (:dead-acute #\a)) (define-dead-key-combination (code-char 233) (:dead-acute #\e)) (define-dead-key-combination (code-char 237) (:dead-acute #\i)) (define-dead-key-combination (code-char 243) (:dead-acute #\o)) (define-dead-key-combination (code-char 250) (:dead-acute #\u)) (define-dead-key-combination (code-char 253) (:dead-acute #\y)) (define-dead-key-combination (code-char 199) (:dead-acute #\c)) (define-dead-key-combination (code-char 231) (:dead-acute #\c)) (define-dead-key-combination (code-char 215) (:dead-acute #\x)) (define-dead-key-combination (code-char 247) (:dead-acute #\-)) (define-dead-key-combination (code-char 222) (:dead-acute #\t)) (define-dead-key-combination (code-char 254) (:dead-acute #\t)) (define-dead-key-combination (code-char 223) (:dead-acute #\s)) (define-dead-key-combination (code-char 39) (:dead-acute #\space)) (define-dead-key-combination (code-char 197) (:dead-acute :dead-acute #\a)) (define-dead-key-combination (code-char 229) (:dead-acute :dead-acute #\a)) (define-dead-key-combination (code-char 192) (:dead-grave #\a)) (define-dead-key-combination (code-char 200) (:dead-grave #\e)) (define-dead-key-combination (code-char 204) (:dead-grave #\i)) (define-dead-key-combination (code-char 210) (:dead-grave #\o)) (define-dead-key-combination (code-char 217) (:dead-grave #\u)) (define-dead-key-combination (code-char 224) (:dead-grave #\a)) (define-dead-key-combination (code-char 232) (:dead-grave #\e)) (define-dead-key-combination (code-char 236) (:dead-grave #\i)) (define-dead-key-combination (code-char 242) (:dead-grave #\o)) (define-dead-key-combination (code-char 249) (:dead-grave #\u)) (define-dead-key-combination (code-char 96) (:dead-grave #\space)) (define-dead-key-combination (code-char 96) (:dead-grave :dead-grave)) (define-dead-key-combination (code-char 196) (:dead-diaeresis #\a)) (define-dead-key-combination (code-char 203) (:dead-diaeresis #\e)) (define-dead-key-combination (code-char 207) (:dead-diaeresis #\i)) (define-dead-key-combination (code-char 214) (:dead-diaeresis #\o)) (define-dead-key-combination (code-char 220) (:dead-diaeresis #\u)) (define-dead-key-combination (code-char 228) (:dead-diaeresis #\a)) (define-dead-key-combination (code-char 235) (:dead-diaeresis #\e)) (define-dead-key-combination (code-char 239) (:dead-diaeresis #\i)) (define-dead-key-combination (code-char 246) (:dead-diaeresis #\o)) (define-dead-key-combination (code-char 252) (:dead-diaeresis #\u)) (define-dead-key-combination (code-char 255) (:dead-diaeresis #\y)) (define-dead-key-combination (code-char 168) (:dead-diaeresis #\space)) (define-dead-key-combination (code-char 168) (:dead-diaeresis :dead-diaeresis)) (define-dead-key-combination (code-char 195) (:dead-tilde #\a)) (define-dead-key-combination (code-char 209) (:dead-tilde #\n)) (define-dead-key-combination (code-char 227) (:dead-tilde #\a)) (define-dead-key-combination (code-char 241) (:dead-tilde #\n)) (define-dead-key-combination (code-char 198) (:dead-tilde #\e)) (define-dead-key-combination (code-char 230) (:dead-tilde #\e)) (define-dead-key-combination (code-char 208) (:dead-tilde #\d)) (define-dead-key-combination (code-char 240) (:dead-tilde #\d)) (define-dead-key-combination (code-char 245) (:dead-tilde #\o)) (define-dead-key-combination (code-char 126) (:dead-tilde #\space)) (define-dead-key-combination (code-char 126) (:dead-tilde :dead-tilde)) (define-dead-key-combination (code-char 194) (:dead-circumflex #\a)) (define-dead-key-combination (code-char 202) (:dead-circumflex #\e)) (define-dead-key-combination (code-char 206) (:dead-circumflex #\i)) (define-dead-key-combination (code-char 212) (:dead-circumflex #\o)) (define-dead-key-combination (code-char 219) (:dead-circumflex #\u)) (define-dead-key-combination (code-char 226) (:dead-circumflex #\a)) (define-dead-key-combination (code-char 234) (:dead-circumflex #\e)) (define-dead-key-combination (code-char 238) (:dead-circumflex #\i)) (define-dead-key-combination (code-char 244) (:dead-circumflex #\o)) (define-dead-key-combination (code-char 251) (:dead-circumflex #\u)) (define-dead-key-combination (code-char 94) (:dead-circumflex #\space)) (define-dead-key-combination (code-char 94) (:dead-circumflex :dead-circumflex)) (defmacro merging-dead-keys ((gesture state) &body body) "Accumulate dead keys and subsequent characters. `Gesture' should be a symbol bound to either a gesture or an input event. `Body' will be evaluated either with the `gesture' binding unchanged, or with `gesture' bound to the result of merging preceding dead keys. `State' must be a place, initially NIL, that will contain the state of dead-key handling, enabling asynchronous use of the macro." `(flet ((invoke-body (,gesture) ,@body)) (when (null ,state) (setf ,state *dead-key-table*)) (if (typep ,gesture '(or keyboard-event character)) (let ((value (gethash (if (characterp ,gesture) ,gesture (keyboard-event-key-name ,gesture)) ,state))) (etypecase value (null (cond ((eq ,state *dead-key-table*) (invoke-body ,gesture)) ((or (and (typep ,gesture 'keyboard-event) (keyboard-event-character ,gesture)) (characterp ,gesture)) (setf ,state *dead-key-table*)))) (character (setf ,state *dead-key-table*) (invoke-body value)) (hash-table (setf ,state value) (invoke-body value)))) (progn (setf ,state *dead-key-table*) (invoke-body ,gesture))))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/mcclim-gif-bitmaps.asd0000644000175000017500000000207411212713462021136 0ustar pdmpdm;;; -*- Mode: Lisp -*- ;;; (c) copyright 2008 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (asdf:defsystem :mcclim-gif-bitmaps :description "Support for GIF images in McCLIM bitmap reading functions." :depends-on (:mcclim :skippy) :components ((:file "gif" :pathname #P"Extensions/Bitmap-formats/gif"))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/mcclim-jpeg-bitmaps.asd0000644000175000017500000000210211212713462021306 0ustar pdmpdm;;; -*- Mode: Lisp -*- ;;; (c) copyright 2008 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (asdf:defsystem :mcclim-jpeg-bitmaps :description "Support for JPEG images in McCLIM bitmap reading functions." :depends-on (:mcclim :cl-jpeg) :components ((:file "jpeg" :pathname #P"Extensions/Bitmap-formats/jpeg"))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/mcclim-png-bitmaps.asd0000644000175000017500000000210711247400247021154 0ustar pdmpdm;;; -*- Mode: Lisp -*- ;;; (c) copyright 2009 by ;;; Samium Gromoff (_deepfire@feelingofgreen.ru) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (asdf:defsystem :mcclim-png-bitmaps :description "Support for PNG images in McCLIM bitmap reading functions." :depends-on (:mcclim :png-read) :components ((:file "png" :pathname #P"Extensions/Bitmap-formats/png"))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/mcclim-tiff-bitmaps.asd0000644000175000017500000000214311213221274021312 0ustar pdmpdm;;; -*- Mode: Lisp -*- ;;; (c) copyright 2009 by ;;; Cyrus Harmon (ch-lisp@bobobeach.com) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (asdf:defsystem :mcclim-tiff-bitmaps :description "Support for TIFF images in McCLIM bitmap reading functions." :depends-on (:mcclim :retrospectiff) :components ((:file "tiff" :pathname #P"Extensions/Bitmap-formats/tiff"))) cl-mcclim-0.9.6.dfsg.cvs20100315.orig/xpm.lisp0000644000175000017500000012255711000705156016503 0ustar pdmpdm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-INTERNALS; -*- ;;; --------------------------------------------------------------------------- ;;; Title: XPM Parser ;;; Created: 2003-05-25 ;;; Authors: Gilbert Baumann ;;; Andy Hefner ;;; License: LGPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2003 by Gilbert Baumann ;;; (c) copyright 2006 by Andy Hefner ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) ;;;; Notes ;;; This is essentially a rewrite/transliteration of Gilbert's original code, ;;; modified to improve performance. This is achieved primarily by using ;;; read-sequence into an (unsigned-byte 8) array and parsing directly ;;; from this array (the original code read a list of strings using read-line ;;; and further divided these into substrings in various places. It is ;;; substantially faster than the original code, but there are opportunities ;;; to further improve performance by perhaps several times, including: ;;; - Use an array rather than hash table to resolve color tokens ;;; (I avoided doing this for now due to a pathological case of a file ;;; with a small palette but high CPP and sparse color tokens) ;;; - Stricter type declarations (some but not all of the code assumes cpp<3) ;;; - In the worst case (photographs), we spent most of our time parsing ;;; the palette (it may have thousands or millions of entries). ;;; - For the above case, we should be generating an RGB or RGBA image ;;; rather than an indexed-pattern (and consing a ton of color objects). ;;; - People who save photographs in XPM format are morons, so it isn't ;;; worth optimizing. ;;; Gilbert's Notes: ;; - We lose when the XPM image only specifies colors for say the mono ;; visual. ;; ;; - We need a little refactoring: ;; ;; . The list of colors below is now actually the second place we have ;; that. ;; ;; . Parsing of #rgb style colors is now the upteens place we have ;; that in general. ;; ;; => Put that in utils.lisp and document its interface. ;; ;; - The ASCII-centric approach of XPM makes it suitable for embedding ;; it into sources files. I want a macro which takes a list of ;; strings according the XPM format and turns it into a make-pattern ;; call. ;; ;; - This needs to be incorporated into READ-BITMAP-FILE or what ever ;; that is called. ;; ;; - We might be interested in the hot spot also. ;; ;; --GB 2003-05-25 ;;;; Summary of the File Format ;; [as of the XPM-3.4i documentation by Arnaud Le Hors]. ;; | The XPM Format ;; | ;; | The XPM format presents a C syntax, in order to provide the ability to ;; | include XPM files in C and C++ programs. It is in fact an array of ;; | strings composed of six different sections as follows: ;; | ;; | /* XPM */ ;; | static char* [] = { ;; | ;; | ;; | ;; | ;; | }; ;; | ;; | The words are separated by a white space which can be composed of ;; | space and tabulation characters. The section is a string ;; | containing four or six integers in base 10 that correspond to: the ;; | pixmap width and height, the number of colors, the number of ;; | characters per pixel (so there is no limit on the number of colors), ;; | and, optionally the hotspot coordinates and the XPMEXT tag if there is ;; | any extension following the section. ;; | ;; | [ ] [XPMEXT] ;; | ;; | The Colors section contains as many strings as there are colors, and ;; | each string is as follows: ;; | ;; | { }+ ;; | ;; | Where is the length string (not surrounded ;; | by anything) representing the pixels, is the specified color, ;; | and is a keyword describing in which context this color should ;; | be used. Currently the keys may have the following values: ;; | ;; | m for mono visual ;; | s for symbolic name ;; | g4 for 4-level grayscale ;; | g for grayscale with more than 4 levels ;; | c for color visual ;; | ;; | Colors can be specified by giving the colorname, a # followed by the ;; | RGB code in hexadecimal, or a % followed by the HSV code (not ;; | implemented). The symbolic name provides the ability of specifying the ;; | colors at load time and not to hardcode them in the file. ;; | ;; | Also the string None can be given as a colorname to mean ;; | ``transparent''. Transparency is supported by the XPM library by ;; | providing a masking bitmap in addition to the pixmap. This mask can ;; | then be used either as a clip-mask of an Xlib GC, or a shape-mask of a ;; | window using the X11 Nonrectangular Window Shape Extension [XShape]. ;; | The section is composed by strings of * ;; | characters, where every length ;; | string must be one of the previously defined groups in the ;; | section. ;; | ;; | Then follows the section which must be labeled, if not ;; | empty, in the section as previously described. This section ;; | may be composed by several subsections which may be of two ;; | types: ;; | ;; | . one stand alone string composed as follows: ;; | ;; | XPMEXT ;; | ;; | . or a block composed by several strings: ;; | ;; | XPMEXT ;; | ;; | ;; | Finally, if not empty, this section must end by the following string: ;; | ;; | XPMENDEXT ;; | ;; | Extensions can be used to store any type of data one might want to ;; | store along with a pixmap, as long as they are properly encoded so ;; | they do not conflict with the general syntax. To avoid possible ;; | conflicts with extension names in shared files, they should be ;; | prefixed by the name of the company. This would ensure uniqueness. ;; | (deftype xpm-data-array () `(simple-array (unsigned-byte 8) 1)) (deftype array-index () #-sbcl '(integer 0 #.array-dimension-limit) #+sbcl 'sb-int:index) (deftype xpm-pixcode () `(unsigned-byte 24)) ; Bogus upper limit for speed.. =/ (defmacro xpm-over-array ((arrayform elt0 idx0 elt1 idx1 start) &body body) (let ((arraysym (gensym)) (lengthsym (gensym))) `(let* ((,arraysym ,arrayform) (,lengthsym (length ,arraysym))) (declare (type xpm-data-array ,arraysym) (optimize (speed 3))) (loop for ,idx0 of-type array-index from ,start below (1- ,lengthsym) as ,idx1 of-type array-index = (1+ ,idx0) as ,elt0 = (aref ,arraysym ,idx0) as ,elt1 = (aref ,arraysym ,idx1) do (progn ,@body))))) (declaim (inline xpm-whitespace-p) (ftype (function ((unsigned-byte 8)) t) xpm-whitespace-p)) (defun xpm-white-space-p (code) (declare (type (unsigned-byte 8) code) (optimize (speed 3))) (or (= code 32) ; #\Space (= code 9) ; #\Tab (= code 10))) ; #\Newline (defun xpm-token-terminator-p (code) (declare (type (unsigned-byte 8) code)) (or (xpm-white-space-p code) (= code 34))) ; #\" (defun xpm-token-bounds (data start) (xpm-over-array (data b0 start b1 i1 start) (when (not (xpm-white-space-p b0)) (xpm-over-array (data b0 end b1 i1 start) (when (xpm-token-terminator-p b0) (return-from xpm-token-bounds (values start end)))) (error "Unbounded token"))) (error "Missing token")) (defun xpm-extract-color-token (data start end) (declare (type xpm-data-array data) (type array-index start end) (optimize (speed 3))) (let ((x 0)) (declare (type xpm-pixcode x)) ; Bah, this didn't help. (loop for i from start below end do (setf x (+ (ash x 8) (elt data i)))) x)) (defun xpm-parse-color (data cpp index) (declare (type xpm-data-array data) (type (integer 1 4) cpp) ; ??? =p (type array-index index) (optimize (speed 3) (safety 0))) (let* ((color-token-end (the array-index (+ index cpp))) (code (xpm-extract-color-token data index color-token-end)) (string-end (1- (xpm-exit-string data color-token-end))) (color (xpm-parse-color-spec data color-token-end string-end))) (declare (type array-index color-token-end string-end) (type xpm-pixcode code)) (unless color (error "Color ~S does not parse." (map 'string #'code-char (subseq data color-token-end string-end)))) (values code color (1+ string-end)))) (declaim (inline xpm-key-p)) (defun xpm-key-p (x) (or (= x 109) (= x 115) (= x 103) (= x 99))) (defun xpm-parse-color-spec (data start end) ;; Gilbert says: ;; > Lossage! ;; > There exist files which say e.g. "c light yellow". ;; > How am I supposed to parse that? ;; > ;; > It seems that the C code just parse everything until one of keys. ;; > That is we do the same although it is quite stupid. ;(declare (optimize (debug 3) (safety 3))) (declare (optimize (speed 3) (space 0) (safety 0)) (type xpm-data-array data) (type array-index start end)) (let ((original-start start) key last-was-key color-token-start color-token-end) (declare (type (or null array-index) color-token-start color-token-end) (type (or null (unsigned-byte 8)) key)) (flet ((find-token (start end) (let* ((p1 (position-if-not #'xpm-white-space-p data :start start :end end)) (p2 (and p1 (or (position-if #'xpm-white-space-p data :start p1 :end end) end)))) (values p1 p2))) (quux (key color-token-start color-token-end) (let ((ink (xpm-parse-single-color key data color-token-start color-token-end))) (when ink (return-from xpm-parse-color-spec ink)))) (stringize () (map 'string #'code-char (subseq data original-start end)))) (loop (multiple-value-bind (p1 p2) (find-token start end) (unless p1 (when last-was-key (error "Premature end of color line (no color present after key): ~S." (stringize))) (when color-token-start (quux key color-token-start color-token-end)) (error "We failed to parse a color out of ~S." (stringize))) (cond (last-was-key (setf last-was-key nil color-token-start p1 color-token-end p2)) ((xpm-key-p (elt data p1)) (when color-token-start (quux key color-token-start color-token-end)) (setf last-was-key t color-token-start nil color-token-end nil key (elt data p1))) (t (when (null color-token-start) (error "Color not prefixed by a key: ~S." (stringize))) (setf last-was-key nil) (setf color-token-end p2))) (setf start p2)))))) (defun xpm-subvector-eql-p (data start end vector) ; FIXME: Guarantee type of input 'vector' and strengthen declaration (declare (type xpm-data-array data) (type array-index start end) (type simple-array vector) (optimize (speed 3))) (and (= (length vector) (- end start)) (loop for i from start below end do (unless (= (elt data i) (elt vector (- i start))) (return nil)) return t))) (defun xpm-parse-single-color (key data start end) (declare (type xpm-data-array data) (type array-index start end) (type (unsigned-byte 8) key) (optimize (speed 3))) (cond ((and (= key 115) (or (xpm-subvector-eql-p data start end #|"None"|# #(78 111 110 101)) (xpm-subvector-eql-p data start end #|"background"|# #(98 97 99 107 103 114 111 117 110 100)))) clim:+transparent-ink+) ((= key 99) (xpm-parse-single-color-2 data start end)) (t (error "Unimplemented key type ~A" key)))) (declaim (ftype (function ((unsigned-byte 8)) t) xpm-hex-digit-p)) (defun xpm-hex-digit-p (byte) (declare (type (unsigned-byte 8) byte) (optimize (speed 3))) (or (<= 48 byte 57) (<= 65 byte 70) (<= 97 byte 102))) (defun xpm-parse-integer-hex (data start end) (declare (type xpm-data-array data) (type array-index start end) (optimize (speed 3))) (let ((accumulator 0)) ; stupid optimizer.. (loop for index from start below end as byte = (elt data index) do (setf accumulator (+ (ash accumulator 4) (cond ((<= 48 byte 57) (- byte 48)) ((<= 65 byte 70) (- byte 65 -10)) ((<= 97 byte 102) (- byte 97 -10)) (t (error "Unknown hex digit ~A, this should be impossible." byte))))) finally (return accumulator)))) (defun xpm-parse-single-color-2 (data start end) (declare (type xpm-data-array data) (type array-index start end) (optimize (speed 3))) (or (and (= (elt data start) 35) ; 35 = #\# (= 0 (mod (- end start 1) 3)) (loop for i from (1+ start) below end do (unless (xpm-hex-digit-p (elt data i)) (return nil)) finally (return t)) (let* ((n (- end start 1)) (w (* 4 (/ n 3))) (m (1- (expt 2 w))) (x (xpm-parse-integer-hex data (1+ start) end))) (clim:make-rgb-color (/ (ldb (byte w (* 2 w)) x) m) (/ (ldb (byte w (* 1 w)) x) m) (/ (ldb (byte w (* 0 w)) x) m)))) (xpm-find-named-color (map 'string #'code-char (subseq data start end))))) (defun xpm-parse-header (data &optional (index 0)) (setf index (xpm-find-next-c-string data index)) (flet ((token (name) (multiple-value-bind (p1 p2) (xpm-token-bounds data index) (unless p1 (error "~A field missing in header." name)) (setf index p2) (parse-integer (map 'string #'code-char (subseq data p1 p2)) :radix 10 :junk-allowed nil)))) (values (token "width") (token "height") (token "ncolors") (token "cpp") (xpm-exit-string data index)))) (defun xpm-parse* (data) (declare (type xpm-data-array data)) (multiple-value-bind (width height ncolors cpp index) (xpm-parse-header data) (let ((color-hash (make-hash-table :test #'eql)) (designs (make-array ncolors)) (j 0)) (dotimes (i ncolors) (multiple-value-bind (code ink post-index) (xpm-parse-color data cpp (xpm-find-next-c-string data index)) (setf (aref designs j) ink (gethash code color-hash) j index post-index) (incf j))) ;; It is considerably faster still to make the array below of element type '(unsigned-byte 8), ;; but this would be wrong by failing to load many legal XPM files. To support both, most ;; of this file would have to be compiled twice for the different types, which is more ;; trouble than its worth. =( (let ((res (make-array (list height width) #|:element-type '(unsigned-byte 8)|#))) ;(line-start (xpm-find-next-c-string data index)) (setf index (xpm-find-next-c-string data index)) (dotimes (y height) (dotimes (x width) (when (= 34 (elt data index)) ; Reached closing quote for this line of pixels? (setf index (xpm-find-next-c-string data (1+ index)))) (setf (aref res y x) (or (gethash (xpm-extract-color-token data index (+ index cpp)) color-hash) (error "Color code ~S not defined." (subseq data index (+ index cpp))))) (incf index cpp))) (values res designs))))) (declaim (ftype (function (xpm-data-array array-index) array-index) xpm-scan-comment)) (defun xpm-scan-comment (data start) (declare (optimize (speed 3))) (xpm-over-array (data b0 i0 b1 i1 start) (when (and (= b0 42) (= b1 47)) (return-from xpm-scan-comment (1+ i1)))) (error "Unterminated comment starting at byte ~A" (- start 2))) (defun xpm-find-next-c-string (data start) (declare (optimize (speed 3)) (type array-index start)) (xpm-over-array (data b0 i0 b1 i1 start) (cond ((and (= b0 47) ; 47 = #\/ (= b1 42)) ; 42 = #\* (setf i0 (1- (xpm-scan-comment data (1+ i1))))) ((= b0 34) (return i1))))) (declaim (ftype (function (xpm-data-array array-index) array-index) xpm-exit-string)) (defun xpm-exit-string (data start) (declare (optimize (speed 3))) (xpm-over-array (data byte index next-byte next-index start) (when (= byte 34) (return-from xpm-exit-string next-index)) ; 34 = #\" (when (= byte 92) (incf index))) ; 92 = #\\ (escape sequence) (error "Unterminated string")) ;(loop for index of-type array-index from start below length ; as byte = (elt data index) ; do (cond ; ( ; 42 = #\* ; (incf index 2) ; ;; a comment ; (do ((c1 0 c2) ; (c2 (elt data index) (elt data index))) ; (and (= c1 42) (= c2 (defun xpm-parse-stream (input) ;; For not needing to parse an actual subset of C, we take a very lazy approach. ;; We just seek out for the first #\" and parse a C string from there. (let ((data (make-array (file-length input) :element-type '(unsigned-byte 8) :adjustable nil :fill-pointer nil))) (read-sequence data input) (xpm-parse* data))) (defun xpm-parse-file (pathname) (with-open-file (input pathname :element-type '(unsigned-byte 8)) (xpm-parse-stream input))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; X11 Colors ;;; (defparameter *xpm-x11-colors* '((255 250 250 "snow") (248 248 255 "ghost white") (248 248 255 "GhostWhite") (245 245 245 "white smoke") (245 245 245 "WhiteSmoke") (220 220 220 "gainsboro") (255 250 240 "floral white") (255 250 240 "FloralWhite") (253 245 230 "old lace") (253 245 230 "OldLace") (250 240 230 "linen") (250 235 215 "antique white") (250 235 215 "AntiqueWhite") (255 239 213 "papaya whip") (255 239 213 "PapayaWhip") (255 235 205 "blanched almond") (255 235 205 "BlanchedAlmond") (255 228 196 "bisque") (255 218 185 "peach puff") (255 218 185 "PeachPuff") (255 222 173 "navajo white") (255 222 173 "NavajoWhite") (255 228 181 "moccasin") (255 248 220 "cornsilk") (255 255 240 "ivory") (255 250 205 "lemon chiffon") (255 250 205 "LemonChiffon") (255 245 238 "seashell") (240 255 240 "honeydew") (245 255 250 "mint cream") (245 255 250 "MintCream") (240 255 255 "azure") (240 248 255 "alice blue") (240 248 255 "AliceBlue") (230 230 250 "lavender") (255 240 245 "lavender blush") (255 240 245 "LavenderBlush") (255 228 225 "misty rose") (255 228 225 "MistyRose") (255 255 255 "white") ( 0 0 0 "black") ( 47 79 79 "dark slate gray") ( 47 79 79 "DarkSlateGray") ( 47 79 79 "dark slate grey") ( 47 79 79 "DarkSlateGrey") (105 105 105 "dim gray") (105 105 105 "DimGray") (105 105 105 "dim grey") (105 105 105 "DimGrey") (112 128 144 "slate gray") (112 128 144 "SlateGray") (112 128 144 "slate grey") (112 128 144 "SlateGrey") (119 136 153 "light slate gray") (119 136 153 "LightSlateGray") (119 136 153 "light slate grey") (119 136 153 "LightSlateGrey") (190 190 190 "gray") (190 190 190 "grey") (211 211 211 "light grey") (211 211 211 "LightGrey") (211 211 211 "light gray") (211 211 211 "LightGray") ( 25 25 112 "midnight blue") ( 25 25 112 "MidnightBlue") ( 0 0 128 "navy") ( 0 0 128 "navy blue") ( 0 0 128 "NavyBlue") (100 149 237 "cornflower blue") (100 149 237 "CornflowerBlue") ( 72 61 139 "dark slate blue") ( 72 61 139 "DarkSlateBlue") (106 90 205 "slate blue") (106 90 205 "SlateBlue") (123 104 238 "medium slate blue") (123 104 238 "MediumSlateBlue") (132 112 255 "light slate blue") (132 112 255 "LightSlateBlue") ( 0 0 205 "medium blue") ( 0 0 205 "MediumBlue") ( 65 105 225 "royal blue") ( 65 105 225 "RoyalBlue") ( 0 0 255 "blue") ( 30 144 255 "dodger blue") ( 30 144 255 "DodgerBlue") ( 0 191 255 "deep sky blue") ( 0 191 255 "DeepSkyBlue") (135 206 235 "sky blue") (135 206 235 "SkyBlue") (135 206 250 "light sky blue") (135 206 250 "LightSkyBlue") ( 70 130 180 "steel blue") ( 70 130 180 "SteelBlue") (176 196 222 "light steel blue") (176 196 222 "LightSteelBlue") (173 216 230 "light blue") (173 216 230 "LightBlue") (176 224 230 "powder blue") (176 224 230 "PowderBlue") (175 238 238 "pale turquoise") (175 238 238 "PaleTurquoise") ( 0 206 209 "dark turquoise") ( 0 206 209 "DarkTurquoise") ( 72 209 204 "medium turquoise") ( 72 209 204 "MediumTurquoise") ( 64 224 208 "turquoise") ( 0 255 255 "cyan") (224 255 255 "light cyan") (224 255 255 "LightCyan") ( 95 158 160 "cadet blue") ( 95 158 160 "CadetBlue") (102 205 170 "medium aquamarine") (102 205 170 "MediumAquamarine") (127 255 212 "aquamarine") ( 0 100 0 "dark green") ( 0 100 0 "DarkGreen") ( 85 107 47 "dark olive green") ( 85 107 47 "DarkOliveGreen") (143 188 143 "dark sea green") (143 188 143 "DarkSeaGreen") ( 46 139 87 "sea green") ( 46 139 87 "SeaGreen") ( 60 179 113 "medium sea green") ( 60 179 113 "MediumSeaGreen") ( 32 178 170 "light sea green") ( 32 178 170 "LightSeaGreen") (152 251 152 "pale green") (152 251 152 "PaleGreen") ( 0 255 127 "spring green") ( 0 255 127 "SpringGreen") (124 252 0 "lawn green") (124 252 0 "LawnGreen") ( 0 255 0 "green") (127 255 0 "chartreuse") ( 0 250 154 "medium spring green") ( 0 250 154 "MediumSpringGreen") (173 255 47 "green yellow") (173 255 47 "GreenYellow") ( 50 205 50 "lime green") ( 50 205 50 "LimeGreen") (154 205 50 "yellow green") (154 205 50 "YellowGreen") ( 34 139 34 "forest green") ( 34 139 34 "ForestGreen") (107 142 35 "olive drab") (107 142 35 "OliveDrab") (189 183 107 "dark khaki") (189 183 107 "DarkKhaki") (240 230 140 "khaki") (238 232 170 "pale goldenrod") (238 232 170 "PaleGoldenrod") (250 250 210 "light goldenrod yellow") (250 250 210 "LightGoldenrodYellow") (255 255 224 "light yellow") (255 255 224 "LightYellow") (255 255 0 "yellow") (255 215 0 "gold") (238 221 130 "light goldenrod") (238 221 130 "LightGoldenrod") (218 165 32 "goldenrod") (184 134 11 "dark goldenrod") (184 134 11 "DarkGoldenrod") (188 143 143 "rosy brown") (188 143 143 "RosyBrown") (205 92 92 "indian red") (205 92 92 "IndianRed") (139 69 19 "saddle brown") (139 69 19 "SaddleBrown") (160 82 45 "sienna") (205 133 63 "peru") (222 184 135 "burlywood") (245 245 220 "beige") (245 222 179 "wheat") (244 164 96 "sandy brown") (244 164 96 "SandyBrown") (210 180 140 "tan") (210 105 30 "chocolate") (178 34 34 "firebrick") (165 42 42 "brown") (233 150 122 "dark salmon") (233 150 122 "DarkSalmon") (250 128 114 "salmon") (255 160 122 "light salmon") (255 160 122 "LightSalmon") (255 165 0 "orange") (255 140 0 "dark orange") (255 140 0 "DarkOrange") (255 127 80 "coral") (240 128 128 "light coral") (240 128 128 "LightCoral") (255 99 71 "tomato") (255 69 0 "orange red") (255 69 0 "OrangeRed") (255 0 0 "red") (255 105 180 "hot pink") (255 105 180 "HotPink") (255 20 147 "deep pink") (255 20 147 "DeepPink") (255 192 203 "pink") (255 182 193 "light pink") (255 182 193 "LightPink") (219 112 147 "pale violet red") (219 112 147 "PaleVioletRed") (176 48 96 "maroon") (199 21 133 "medium violet red") (199 21 133 "MediumVioletRed") (208 32 144 "violet red") (208 32 144 "VioletRed") (255 0 255 "magenta") (238 130 238 "violet") (221 160 221 "plum") (218 112 214 "orchid") (186 85 211 "medium orchid") (186 85 211 "MediumOrchid") (153 50 204 "dark orchid") (153 50 204 "DarkOrchid") (148 0 211 "dark violet") (148 0 211 "DarkViolet") (138 43 226 "blue violet") (138 43 226 "BlueViolet") (160 32 240 "purple") (147 112 219 "medium purple") (147 112 219 "MediumPurple") (216 191 216 "thistle") (255 250 250 "snow1") (238 233 233 "snow2") (205 201 201 "snow3") (139 137 137 "snow4") (255 245 238 "seashell1") (238 229 222 "seashell2") (205 197 191 "seashell3") (139 134 130 "seashell4") (255 239 219 "AntiqueWhite1") (238 223 204 "AntiqueWhite2") (205 192 176 "AntiqueWhite3") (139 131 120 "AntiqueWhite4") (255 228 196 "bisque1") (238 213 183 "bisque2") (205 183 158 "bisque3") (139 125 107 "bisque4") (255 218 185 "PeachPuff1") (238 203 173 "PeachPuff2") (205 175 149 "PeachPuff3") (139 119 101 "PeachPuff4") (255 222 173 "NavajoWhite1") (238 207 161 "NavajoWhite2") (205 179 139 "NavajoWhite3") (139 121 94 "NavajoWhite4") (255 250 205 "LemonChiffon1") (238 233 191 "LemonChiffon2") (205 201 165 "LemonChiffon3") (139 137 112 "LemonChiffon4") (255 248 220 "cornsilk1") (238 232 205 "cornsilk2") (205 200 177 "cornsilk3") (139 136 120 "cornsilk4") (255 255 240 "ivory1") (238 238 224 "ivory2") (205 205 193 "ivory3") (139 139 131 "ivory4") (240 255 240 "honeydew1") (224 238 224 "honeydew2") (193 205 193 "honeydew3") (131 139 131 "honeydew4") (255 240 245 "LavenderBlush1") (238 224 229 "LavenderBlush2") (205 193 197 "LavenderBlush3") (139 131 134 "LavenderBlush4") (255 228 225 "MistyRose1") (238 213 210 "MistyRose2") (205 183 181 "MistyRose3") (139 125 123 "MistyRose4") (240 255 255 "azure1") (224 238 238 "azure2") (193 205 205 "azure3") (131 139 139 "azure4") (131 111 255 "SlateBlue1") (122 103 238 "SlateBlue2") (105 89 205 "SlateBlue3") ( 71 60 139 "SlateBlue4") ( 72 118 255 "RoyalBlue1") ( 67 110 238 "RoyalBlue2") ( 58 95 205 "RoyalBlue3") ( 39 64 139 "RoyalBlue4") ( 0 0 255 "blue1") ( 0 0 238 "blue2") ( 0 0 205 "blue3") ( 0 0 139 "blue4") ( 30 144 255 "DodgerBlue1") ( 28 134 238 "DodgerBlue2") ( 24 116 205 "DodgerBlue3") ( 16 78 139 "DodgerBlue4") ( 99 184 255 "SteelBlue1") ( 92 172 238 "SteelBlue2") ( 79 148 205 "SteelBlue3") ( 54 100 139 "SteelBlue4") ( 0 191 255 "DeepSkyBlue1") ( 0 178 238 "DeepSkyBlue2") ( 0 154 205 "DeepSkyBlue3") ( 0 104 139 "DeepSkyBlue4") (135 206 255 "SkyBlue1") (126 192 238 "SkyBlue2") (108 166 205 "SkyBlue3") ( 74 112 139 "SkyBlue4") (176 226 255 "LightSkyBlue1") (164 211 238 "LightSkyBlue2") (141 182 205 "LightSkyBlue3") ( 96 123 139 "LightSkyBlue4") (198 226 255 "SlateGray1") (185 211 238 "SlateGray2") (159 182 205 "SlateGray3") (108 123 139 "SlateGray4") (202 225 255 "LightSteelBlue1") (188 210 238 "LightSteelBlue2") (162 181 205 "LightSteelBlue3") (110 123 139 "LightSteelBlue4") (191 239 255 "LightBlue1") (178 223 238 "LightBlue2") (154 192 205 "LightBlue3") (104 131 139 "LightBlue4") (224 255 255 "LightCyan1") (209 238 238 "LightCyan2") (180 205 205 "LightCyan3") (122 139 139 "LightCyan4") (187 255 255 "PaleTurquoise1") (174 238 238 "PaleTurquoise2") (150 205 205 "PaleTurquoise3") (102 139 139 "PaleTurquoise4") (152 245 255 "CadetBlue1") (142 229 238 "CadetBlue2") (122 197 205 "CadetBlue3") ( 83 134 139 "CadetBlue4") ( 0 245 255 "turquoise1") ( 0 229 238 "turquoise2") ( 0 197 205 "turquoise3") ( 0 134 139 "turquoise4") ( 0 255 255 "cyan1") ( 0 238 238 "cyan2") ( 0 205 205 "cyan3") ( 0 139 139 "cyan4") (151 255 255 "DarkSlateGray1") (141 238 238 "DarkSlateGray2") (121 205 205 "DarkSlateGray3") ( 82 139 139 "DarkSlateGray4") (127 255 212 "aquamarine1") (118 238 198 "aquamarine2") (102 205 170 "aquamarine3") ( 69 139 116 "aquamarine4") (193 255 193 "DarkSeaGreen1") (180 238 180 "DarkSeaGreen2") (155 205 155 "DarkSeaGreen3") (105 139 105 "DarkSeaGreen4") ( 84 255 159 "SeaGreen1") ( 78 238 148 "SeaGreen2") ( 67 205 128 "SeaGreen3") ( 46 139 87 "SeaGreen4") (154 255 154 "PaleGreen1") (144 238 144 "PaleGreen2") (124 205 124 "PaleGreen3") ( 84 139 84 "PaleGreen4") ( 0 255 127 "SpringGreen1") ( 0 238 118 "SpringGreen2") ( 0 205 102 "SpringGreen3") ( 0 139 69 "SpringGreen4") ( 0 255 0 "green1") ( 0 238 0 "green2") ( 0 205 0 "green3") ( 0 139 0 "green4") (127 255 0 "chartreuse1") (118 238 0 "chartreuse2") (102 205 0 "chartreuse3") ( 69 139 0 "chartreuse4") (192 255 62 "OliveDrab1") (179 238 58 "OliveDrab2") (154 205 50 "OliveDrab3") (105 139 34 "OliveDrab4") (202 255 112 "DarkOliveGreen1") (188 238 104 "DarkOliveGreen2") (162 205 90 "DarkOliveGreen3") (110 139 61 "DarkOliveGreen4") (255 246 143 "khaki1") (238 230 133 "khaki2") (205 198 115 "khaki3") (139 134 78 "khaki4") (255 236 139 "LightGoldenrod1") (238 220 130 "LightGoldenrod2") (205 190 112 "LightGoldenrod3") (139 129 76 "LightGoldenrod4") (255 255 224 "LightYellow1") (238 238 209 "LightYellow2") (205 205 180 "LightYellow3") (139 139 122 "LightYellow4") (255 255 0 "yellow1") (238 238 0 "yellow2") (205 205 0 "yellow3") (139 139 0 "yellow4") (255 215 0 "gold1") (238 201 0 "gold2") (205 173 0 "gold3") (139 117 0 "gold4") (255 193 37 "goldenrod1") (238 180 34 "goldenrod2") (205 155 29 "goldenrod3") (139 105 20 "goldenrod4") (255 185 15 "DarkGoldenrod1") (238 173 14 "DarkGoldenrod2") (205 149 12 "DarkGoldenrod3") (139 101 8 "DarkGoldenrod4") (255 193 193 "RosyBrown1") (238 180 180 "RosyBrown2") (205 155 155 "RosyBrown3") (139 105 105 "RosyBrown4") (255 106 106 "IndianRed1") (238 99 99 "IndianRed2") (205 85 85 "IndianRed3") (139 58 58 "IndianRed4") (255 130 71 "sienna1") (238 121 66 "sienna2") (205 104 57 "sienna3") (139 71 38 "sienna4") (255 211 155 "burlywood1") (238 197 145 "burlywood2") (205 170 125 "burlywood3") (139 115 85 "burlywood4") (255 231 186 "wheat1") (238 216 174 "wheat2") (205 186 150 "wheat3") (139 126 102 "wheat4") (255 165 79 "tan1") (238 154 73 "tan2") (205 133 63 "tan3") (139 90 43 "tan4") (255 127 36 "chocolate1") (238 118 33 "chocolate2") (205 102 29 "chocolate3") (139 69 19 "chocolate4") (255 48 48 "firebrick1") (238 44 44 "firebrick2") (205 38 38 "firebrick3") (139 26 26 "firebrick4") (255 64 64 "brown1") (238 59 59 "brown2") (205 51 51 "brown3") (139 35 35 "brown4") (255 140 105 "salmon1") (238 130 98 "salmon2") (205 112 84 "salmon3") (139 76 57 "salmon4") (255 160 122 "LightSalmon1") (238 149 114 "LightSalmon2") (205 129 98 "LightSalmon3") (139 87 66 "LightSalmon4") (255 165 0 "orange1") (238 154 0 "orange2") (205 133 0 "orange3") (139 90 0 "orange4") (255 127 0 "DarkOrange1") (238 118 0 "DarkOrange2") (205 102 0 "DarkOrange3") (139 69 0 "DarkOrange4") (255 114 86 "coral1") (238 106 80 "coral2") (205 91 69 "coral3") (139 62 47 "coral4") (255 99 71 "tomato1") (238 92 66 "tomato2") (205 79 57 "tomato3") (139 54 38 "tomato4") (255 69 0 "OrangeRed1") (238 64 0 "OrangeRed2") (205 55 0 "OrangeRed3") (139 37 0 "OrangeRed4") (255 0 0 "red1") (238 0 0 "red2") (205 0 0 "red3") (139 0 0 "red4") (255 20 147 "DeepPink1") (238 18 137 "DeepPink2") (205 16 118 "DeepPink3") (139 10 80 "DeepPink4") (255 110 180 "HotPink1") (238 106 167 "HotPink2") (205 96 144 "HotPink3") (139 58 98 "HotPink4") (255 181 197 "pink1") (238 169 184 "pink2") (205 145 158 "pink3") (139 99 108 "pink4") (255 174 185 "LightPink1") (238 162 173 "LightPink2") (205 140 149 "LightPink3") (139 95 101 "LightPink4") (255 130 171 "PaleVioletRed1") (238 121 159 "PaleVioletRed2") (205 104 137 "PaleVioletRed3") (139 71 93 "PaleVioletRed4") (255 52 179 "maroon1") (238 48 167 "maroon2") (205 41 144 "maroon3") (139 28 98 "maroon4") (255 62 150 "VioletRed1") (238 58 140 "VioletRed2") (205 50 120 "VioletRed3") (139 34 82 "VioletRed4") (255 0 255 "magenta1") (238 0 238 "magenta2") (205 0 205 "magenta3") (139 0 139 "magenta4") (255 131 250 "orchid1") (238 122 233 "orchid2") (205 105 201 "orchid3") (139 71 137 "orchid4") (255 187 255 "plum1") (238 174 238 "plum2") (205 150 205 "plum3") (139 102 139 "plum4") (224 102 255 "MediumOrchid1") (209 95 238 "MediumOrchid2") (180 82 205 "MediumOrchid3") (122 55 139 "MediumOrchid4") (191 62 255 "DarkOrchid1") (178 58 238 "DarkOrchid2") (154 50 205 "DarkOrchid3") (104 34 139 "DarkOrchid4") (155 48 255 "purple1") (145 44 238 "purple2") (125 38 205 "purple3") ( 85 26 139 "purple4") (171 130 255 "MediumPurple1") (159 121 238 "MediumPurple2") (137 104 205 "MediumPurple3") ( 93 71 139 "MediumPurple4") (255 225 255 "thistle1") (238 210 238 "thistle2") (205 181 205 "thistle3") (139 123 139 "thistle4") ( 0 0 0 "gray0") ( 0 0 0 "grey0") ( 3 3 3 "gray1") ( 3 3 3 "grey1") ( 5 5 5 "gray2") ( 5 5 5 "grey2") ( 8 8 8 "gray3") ( 8 8 8 "grey3") ( 10 10 10 "gray4") ( 10 10 10 "grey4") ( 13 13 13 "gray5") ( 13 13 13 "grey5") ( 15 15 15 "gray6") ( 15 15 15 "grey6") ( 18 18 18 "gray7") ( 18 18 18 "grey7") ( 20 20 20 "gray8") ( 20 20 20 "grey8") ( 23 23 23 "gray9") ( 23 23 23 "grey9") ( 26 26 26 "gray10") ( 26 26 26 "grey10") ( 28 28 28 "gray11") ( 28 28 28 "grey11") ( 31 31 31 "gray12") ( 31 31 31 "grey12") ( 33 33 33 "gray13") ( 33 33 33 "grey13") ( 36 36 36 "gray14") ( 36 36 36 "grey14") ( 38 38 38 "gray15") ( 38 38 38 "grey15") ( 41 41 41 "gray16") ( 41 41 41 "grey16") ( 43 43 43 "gray17") ( 43 43 43 "grey17") ( 46 46 46 "gray18") ( 46 46 46 "grey18") ( 48 48 48 "gray19") ( 48 48 48 "grey19") ( 51 51 51 "gray20") ( 51 51 51 "grey20") ( 54 54 54 "gray21") ( 54 54 54 "grey21") ( 56 56 56 "gray22") ( 56 56 56 "grey22") ( 59 59 59 "gray23") ( 59 59 59 "grey23") ( 61 61 61 "gray24") ( 61 61 61 "grey24") ( 64 64 64 "gray25") ( 64 64 64 "grey25") ( 66 66 66 "gray26") ( 66 66 66 "grey26") ( 69 69 69 "gray27") ( 69 69 69 "grey27") ( 71 71 71 "gray28") ( 71 71 71 "grey28") ( 74 74 74 "gray29") ( 74 74 74 "grey29") ( 77 77 77 "gray30") ( 77 77 77 "grey30") ( 79 79 79 "gray31") ( 79 79 79 "grey31") ( 82 82 82 "gray32") ( 82 82 82 "grey32") ( 84 84 84 "gray33") ( 84 84 84 "grey33") ( 87 87 87 "gray34") ( 87 87 87 "grey34") ( 89 89 89 "gray35") ( 89 89 89 "grey35") ( 92 92 92 "gray36") ( 92 92 92 "grey36") ( 94 94 94 "gray37") ( 94 94 94 "grey37") ( 97 97 97 "gray38") ( 97 97 97 "grey38") ( 99 99 99 "gray39") ( 99 99 99 "grey39") (102 102 102 "gray40") (102 102 102 "grey40") (105 105 105 "gray41") (105 105 105 "grey41") (107 107 107 "gray42") (107 107 107 "grey42") (110 110 110 "gray43") (110 110 110 "grey43") (112 112 112 "gray44") (112 112 112 "grey44") (115 115 115 "gray45") (115 115 115 "grey45") (117 117 117 "gray46") (117 117 117 "grey46") (120 120 120 "gray47") (120 120 120 "grey47") (122 122 122 "gray48") (122 122 122 "grey48") (125 125 125 "gray49") (125 125 125 "grey49") (127 127 127 "gray50") (127 127 127 "grey50") (130 130 130 "gray51") (130 130 130 "grey51") (133 133 133 "gray52") (133 133 133 "grey52") (135 135 135 "gray53") (135 135 135 "grey53") (138 138 138 "gray54") (138 138 138 "grey54") (140 140 140 "gray55") (140 140 140 "grey55") (143 143 143 "gray56") (143 143 143 "grey56") (145 145 145 "gray57") (145 145 145 "grey57") (148 148 148 "gray58") (148 148 148 "grey58") (150 150 150 "gray59") (150 150 150 "grey59") (153 153 153 "gray60") (153 153 153 "grey60") (156 156 156 "gray61") (156 156 156 "grey61") (158 158 158 "gray62") (158 158 158 "grey62") (161 161 161 "gray63") (161 161 161 "grey63") (163 163 163 "gray64") (163 163 163 "grey64") (166 166 166 "gray65") (166 166 166 "grey65") (168 168 168 "gray66") (168 168 168 "grey66") (171 171 171 "gray67") (171 171 171 "grey67") (173 173 173 "gray68") (173 173 173 "grey68") (176 176 176 "gray69") (176 176 176 "grey69") (179 179 179 "gray70") (179 179 179 "grey70") (181 181 181 "gray71") (181 181 181 "grey71") (184 184 184 "gray72") (184 184 184 "grey72") (186 186 186 "gray73") (186 186 186 "grey73") (189 189 189 "gray74") (189 189 189 "grey74") (191 191 191 "gray75") (191 191 191 "grey75") (194 194 194 "gray76") (194 194 194 "grey76") (196 196 196 "gray77") (196 196 196 "grey77") (199 199 199 "gray78") (199 199 199 "grey78") (201 201 201 "gray79") (201 201 201 "grey79") (204 204 204 "gray80") (204 204 204 "grey80") (207 207 207 "gray81") (207 207 207 "grey81") (209 209 209 "gray82") (209 209 209 "grey82") (212 212 212 "gray83") (212 212 212 "grey83") (214 214 214 "gray84") (214 214 214 "grey84") (217 217 217 "gray85") (217 217 217 "grey85") (219 219 219 "gray86") (219 219 219 "grey86") (222 222 222 "gray87") (222 222 222 "grey87") (224 224 224 "gray88") (224 224 224 "grey88") (227 227 227 "gray89") (227 227 227 "grey89") (229 229 229 "gray90") (229 229 229 "grey90") (232 232 232 "gray91") (232 232 232 "grey91") (235 235 235 "gray92") (235 235 235 "grey92") (237 237 237 "gray93") (237 237 237 "grey93") (240 240 240 "gray94") (240 240 240 "grey94") (242 242 242 "gray95") (242 242 242 "grey95") (245 245 245 "gray96") (245 245 245 "grey96") (247 247 247 "gray97") (247 247 247 "grey97") (250 250 250 "gray98") (250 250 250 "grey98") (252 252 252 "gray99") (252 252 252 "grey99") (255 255 255 "gray100") (255 255 255 "grey100") (169 169 169 "dark grey") (169 169 169 "DarkGrey") (169 169 169 "dark gray") (169 169 169 "DarkGray") (0 0 139 "dark blue") (0 0 139 "DarkBlue") (0 139 139 "dark cyan") (0 139 139 "DarkCyan") (139 0 139 "dark magenta") (139 0 139 "DarkMagenta") (139 0 0 "dark red") (139 0 0 "DarkRed") (144 238 144 "light green") (144 238 144 "LightGreen"))) (defun xpm-find-named-color (name) (if (string-equal name "None") clim:+transparent-ink+ (let ((q (find name *xpm-x11-colors* :key #'fourth :test #'string-equal))) (and q (clim:make-rgb-color (/ (first q) 255) (/ (second q) 255) (/ (third q) 255))))))