From ahefner at common-lisp.net Tue Jan 1 00:27:34 2008 From: ahefner at common-lisp.net (ahefner) Date: Mon, 31 Dec 2007 19:27:34 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080101002734.BC3586512A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv32572 Modified Files: frames.lisp Log Message: After disabling a frame, call port-force-output. --- /project/mcclim/cvsroot/mcclim/frames.lisp 2007/03/04 22:30:19 1.127 +++ /project/mcclim/cvsroot/mcclim/frames.lisp 2008/01/01 00:27:34 1.128 @@ -364,7 +364,7 @@ (defmethod frame-exit ((frame standard-application-frame)) (if (eq *application-frame* frame) (signal 'frame-exit :frame frame) - (disown-frame (frame-manager frame) frame))) + (disown-frame (frame-manager frame) frame))) (defmethod frame-exit-frame ((c frame-exit)) (%frame-exit-frame c)) @@ -447,11 +447,11 @@ (call-next-method))) (frame-layout-changed () nil))) (let ((fm (frame-manager frame))) - (case original-state - (:disabled - (disable-frame frame)) - (:disowned - (disown-frame fm frame))))))) + (case original-state + (:disabled + (disable-frame frame)) + (:disowned + (disown-frame fm frame))))))) (defparameter +default-prompt-style+ (make-text-style :fix :italic :normal)) @@ -643,7 +643,10 @@ (note-frame-enabled (frame-manager frame) frame)) (defmethod disable-frame ((frame application-frame)) - (setf (sheet-enabled-p (frame-top-level-sheet frame)) nil) + (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)) From thenriksen at common-lisp.net Tue Jan 1 18:43:36 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 1 Jan 2008 13:43:36 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080101184336.5F5D812065@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv13721/Drei Modified Files: buffer.lisp drei-clim.lisp drei-redisplay.lisp packages.lisp views.lisp Log Message: Added new redisplay engine for Drei. Used by default. Does not yet talk to the syntax, so there is no syntax highlighting, but other syntax facilities work just fine. It is significantly faster than the old engine, but not yet Emacs-style fast. It supports variable-width fonts, lines of varying height (though lines are topline-adjusted at the moment) and even arbitrary buffer objects with reasonable performance. --- /project/mcclim/cvsroot/mcclim/Drei/buffer.lisp 2007/12/08 08:53:50 1.5 +++ /project/mcclim/cvsroot/mcclim/Drei/buffer.lisp 2008/01/01 18:43:36 1.6 @@ -37,7 +37,8 @@ of the buffer is not necessarily a newline character.")) (defclass standard-buffer (buffer) - ((contents :initform (make-instance 'standard-cursorchain))) + ((contents :initform (make-instance 'standard-cursorchain) + :reader contents)) (:documentation "The standard instantiable class for buffers.")) (defgeneric buffer (mark) @@ -231,7 +232,7 @@ (:documentation "Return the number of objects in the buffer.")) (defmethod size ((buffer standard-buffer)) - (nb-elements (slot-value buffer 'contents))) + (nb-elements (contents buffer))) (defgeneric number-of-lines (buffer) (:documentation "Return the number of lines of the buffer, or really the number of @@ -473,7 +474,7 @@ (make-condition 'offset-before-beginning :offset offset)) (assert (<= offset (size buffer)) () (make-condition 'offset-after-end :offset offset)) - (insert* (slot-value buffer 'contents) offset object)) + (insert* (contents buffer) offset object)) (defgeneric insert-buffer-sequence (buffer offset sequence) (:documentation "Like calling insert-buffer-object on each of @@ -484,7 +485,7 @@ (make-condition 'offset-before-beginning :offset offset)) (assert (<= offset (size buffer)) () (make-condition 'offset-after-end :offset offset)) - (insert-vector* (slot-value buffer 'contents) offset sequence)) + (insert-vector* (contents buffer) offset sequence)) (defgeneric insert-object (mark object) (:documentation "Insert the object at the mark. This function @@ -516,7 +517,7 @@ (assert (<= (+ offset n) (size buffer)) () (make-condition 'offset-after-end :offset (+ offset n))) (loop repeat n - do (delete* (slot-value buffer 'contents) offset))) + do (delete* (contents buffer) offset))) (defgeneric delete-range (mark &optional n) (:documentation "Delete `n' objects after `(if n > 0)' or @@ -566,7 +567,7 @@ (make-condition 'offset-before-beginning :offset offset)) (assert (<= offset (1- (size buffer))) () (make-condition 'offset-after-end :offset offset)) - (element* (slot-value buffer 'contents) offset)) + (element* (contents buffer) offset)) (defgeneric (setf buffer-object) (object buffer offset) (:documentation "Set the object at the offset in the @@ -579,7 +580,7 @@ (make-condition 'offset-before-beginning :offset offset)) (assert (<= offset (1- (size buffer))) () (make-condition 'offset-after-end :offset offset)) - (setf (element* (slot-value buffer 'contents) offset) object)) + (setf (element* (contents buffer) offset) object)) (defgeneric buffer-sequence (buffer offset1 offset2) (:documentation "Return the contents of the buffer starting at --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2007/12/23 00:40:36 1.25 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/01 18:43:36 1.26 @@ -76,8 +76,8 @@ enabled, it will simply be ignored during redisplay.") (%active-ink :accessor active-ink :initarg :active-ink - :initform +red+ - :type color + :initform +flipping-ink+ + :type design :documentation "The ink used to draw the cursor when it is active.") (%inactive-ink :accessor inactive-ink @@ -180,6 +180,9 @@ (offset (mark cursor)) (offset (bot view)))) +(defmethod (setf view) :after (new-val (drei drei-pane)) + (window-clear drei)) + (defmethod note-sheet-grafted :after ((pane drei-pane)) (setf (stream-default-view pane) (view pane))) --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2007/12/10 21:25:12 1.12 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/01 18:43:36 1.13 @@ -33,16 +33,6 @@ ;;; ;;; Display of Drei instances. ;;; -;;; Syntaxes can customize their redisplay (for things such as syntax -;;; highlighting, presentation types, etc), through specializing on -;;; the generic function `display-syntax-view'. Methods defined on -;;; this function can assume that they are writing to a normal CLIM -;;; stream pane, but cannot expect that they are the only Drei -;;; instance on the stream, and cannot assume that they completely -;;; control the stream. The redisplay scaffolding code will take care -;;; of packaging the output records generated by methods into -;;; something useful to the concrete Drei implementation. -;;; ;;; The basic Drei redisplay functions: (defgeneric display-drei-view-contents (stream view) @@ -69,13 +59,7 @@ (letf (((stream-default-view stream) view)) (call-next-method))) (:method ((stream extended-output-stream) (view drei-syntax-view)) - (display-syntax-view stream view (syntax view)))) - -(defgeneric display-syntax-view (stream view syntax) - (:documentation "Display `view', which contains a view of a -buffer considered to be in syntax `syntax', on `stream'. This -function is called by `display-drei-view-contents' whenever it is -asked to display a syntax view.")) + (call-next-method))) (defgeneric display-drei-view-cursor (stream view cursor) (:documentation "The purpose of this function is to display a @@ -96,23 +80,681 @@ 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.") +is *guaranteed* to not return NIL or T. This function will return +either the output record of the cursor, or NIL.") (:method :around ((stream extended-output-stream) (view drei-view) (cursor drei-cursor)) (when (visible cursor view) (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-dispatcer+ + #'(lambda (stream view stroke cursor-x cursor-y default-drawing-fn) + (funcall default-drawing-fn stream view stroke cursor-x cursor-y)) + "A simple function of six arguments that simply calls the first +argument as a function with the remaining five 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-dispatcer+)) + +(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-dispatcer+)) + (eq (drawing-options-function o2) + +default-stroke-drawer-dispatcer+)) + (or (not (eq (drawing-options-function o2) + +default-stroke-drawer-dispatcer+)) + (eq (drawing-options-function o1) + +default-stroke-drawer-dispatcer+))))) + +(defconstant +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." + (x1 0) + (y1 0) + (x2 0) + (y2 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." + (start-offset) + (end-offset) + (drawing-options +default-drawing-options+) + (dirty t) + (modified t) + (dimensions (make-dimensions))) + +(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) + (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'.")) + +(defgeneric stroke-pump (view stroke pump-state) + (:documentation "Put stroke information in `stroke'. Returns +new pump-state.")) + +(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 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-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 (setf (stroke-dirty stroke) t + (stroke-modified stroke) + (or (stroke-modified stroke) + modified + cleared)) + when cleared + do (let ((dimensions (stroke-dimensions stroke))) + (setf (x1 dimensions) 0 + (y1 dimensions) 0 + (x2 dimensions) 0 + (y2 dimensions) 0)))) + +(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))) + , at 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)))) + , at 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))) + , at 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)))) + , at body))))) + +(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 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) + "Use `stroke-pump' with `pump-state' to get a new stroke for +`view', and add it to the sequence of displayed strokes in +`line'." + (let* ((stroke (line-stroke-information line (line-stroke-count line)))) + (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 x1 y1 x2 y2) + "Record the fact that `stroke' has been drawn, and that it +covers the specified area on screen. Updates the dirty- and +modified-bits of `stroke' as well as the dimensions." + (let ((dimensions (stroke-dimensions stroke))) + (setf (stroke-dirty stroke) nil + (stroke-modified stroke) nil + (x1 dimensions) x1 + (y1 dimensions) y1 + (x2 dimensions) x2 + (y2 dimensions) y2))) + +(defun stroke-drawing-fn (stream view stroke cursor-x cursor-y) + "Draw `stroke' to `stream' at the position (`cursor-x', +`cursor-y'). `View' is the view object that `stroke' belongs +to. 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)) stroke + (let* ((stroke-string (in-place-buffer-substring + (buffer view) (cache-string view) + start-offset end-offset))) + (with-accessors ((x1 x1) (y1 y1) (x2 x2) (y2 y2)) dimensions + (multiple-value-bind (width height) (if (stroke-modified stroke) + (text-size stream stroke-string + :text-style (merge-text-styles + (face-style (drawing-options-face drawing-options)) + (medium-default-text-style stream))) + (values (- x2 x1) (- y2 y1))) + (clear-rectangle* stream cursor-x cursor-y + (+ cursor-x width) (+ cursor-y height + (stream-vertical-spacing stream))) + (draw-text* stream stroke-string cursor-x cursor-y + :text-style (face-style (drawing-options-face drawing-options)) + :ink (face-ink (drawing-options-face drawing-options)) + :align-y :top) + (record-stroke stroke cursor-x cursor-y (+ width cursor-x) + (+ (if (zerop height) + (text-style-height (medium-text-style stream) stream) + height) + cursor-y))))))) + +(defun draw-stroke (stream view stroke cursor-x cursor-y line-height) + "Draw `stroke' on `stream' at (`cursor-x', `cursor-y'). Nothing +will be done unless `stroke' is dirty. Will use the function +specified in the drawing-options of `stroke' to carry out the +actual drawing." + (let* ((drawing-options (stroke-drawing-options stroke))) + (when (stroke-dirty stroke) + (let ((old-dimensions (stroke-dimensions stroke))) + (with-accessors ((x1 x1) (y1 y1) (x2 x2) (y2 y2)) old-dimensions + (unless (or (= x1 y1 x2 y2 0)) + ;; Take care not to clear any previously drawn strokes. + (clear-rectangle* stream (max cursor-x x1) (max cursor-y y1) + (max x2 cursor-x) (+ (max (+ (max cursor-y y1) line-height) y2) + (stream-vertical-spacing stream)))) + (funcall (drawing-options-function drawing-options) stream view stroke + cursor-x cursor-y #'stroke-drawing-fn)))))) + +(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)))) + [622 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/12/28 10:08:33 1.27 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/01 18:43:36 1.28 @@ -139,7 +139,7 @@ (defpackage :drei-syntax (:use :clim-lisp :clim :drei-buffer :drei-base :flexichain :esa-utils) (:export #:syntax #:syntax-command-tables #:update-parse #:syntaxp - #:define-syntax #:*default-syntax* #:cursor-positions + #:define-syntax #:*default-syntax* #:syntax-command-table #:additional-command-tables #:define-syntax-command-table #:eval-option #:define-option-for-syntax @@ -187,7 +187,7 @@ #: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-buffer + #:isearch-state #:search-string #:search-mark #:search-forward-p #:search-success-p #:query-replace-state #:string1 #:string2 #:targets #:occurrences --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2007/12/28 10:08:35 1.8 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/01 18:43:36 1.9 @@ -455,7 +455,9 @@ (: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.")) +subclass.") + (:method ((view drei-view) &key) + nil)) (defgeneric view-command-tables (view) (:documentation "Return a list of command tables containing @@ -506,8 +508,28 @@ (%bot :accessor bot :documentation "The bottom of the displayed buffer, that is, the mark indicating the last visible object in the buffer.") - (%cursor-positions :accessor cursor-positions - :initform nil)) + (%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.")) (:documentation "A view that contains a `drei-buffer' object.")) @@ -517,6 +539,33 @@ (setf top (make-buffer-mark buffer 0 :left) bot (make-buffer-mark buffer (size buffer) :right)))) +(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 (new-value (view drei-buffer-view)) + (invalidate-all-strokes view)) + +(defmethod cache-string :around ((view drei-buffer-view)) + (let ((string (call-next-method))) + (setf (fill-pointer string) 0) + string)) + +(defmethod observer-notified ((view drei-buffer-view) (buffer drei-buffer) + changed-region) + (with-accessors ((prefix-size prefix-size) + (suffix-size suffix-size)) view + (setf prefix-size (min (car changed-region) prefix-size) + suffix-size (min (- (size buffer) (cdr changed-region)) + suffix-size) + (modified-p view) t) + (dotimes (i (displayed-lines-count view)) + (let ((line (line-information view i))) + (when (<= (car changed-region) (line-end-offset line)) + (invalidate-line-strokes line :modified t)))))) + (defclass drei-syntax-view (drei-buffer-view) ((%syntax :accessor syntax) (%prefix-size :accessor prefix-size @@ -602,15 +651,6 @@ (disable-mode (syntax modual) mode-name) (call-next-method))) -(defmethod observer-notified ((view drei-syntax-view) (buffer drei-buffer) - changed-region) - (with-accessors ((prefix-size prefix-size) - (suffix-size suffix-size)) view - (setf prefix-size (min (car changed-region) prefix-size) - suffix-size (min (- (size buffer) (cdr changed-region)) - suffix-size) - (modified-p view) t))) - (defmethod synchronize-view :around ((view drei-syntax-view) &key force-p) ;; If nothing changed, then don't call the other methods. @@ -633,7 +673,8 @@ (suffix-size view) (size (buffer view)) (buffer-size view) (size (buffer view))) (update-syntax (syntax view) prefix-size suffix-size - begin end))) + begin end) + (call-next-method))) (defun make-syntax-for-view (view syntax-symbol &rest args) (apply #'make-instance syntax-symbol From thenriksen at common-lisp.net Tue Jan 1 18:43:36 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 1 Jan 2008 13:43:36 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20080101184336.9F41612060@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv13721/ESA Modified Files: packages.lisp utils.lisp Log Message: Added new redisplay engine for Drei. Used by default. Does not yet talk to the syntax, so there is no syntax highlighting, but other syntax facilities work just fine. It is significantly faster than the old engine, but not yet Emacs-style fast. It supports variable-width fonts, lines of varying height (though lines are topline-adjusted at the moment) and even arbitrary buffer objects with reasonable performance. --- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2007/12/28 10:08:52 1.8 +++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/01/01 18:43:36 1.9 @@ -43,6 +43,7 @@ #:maptree #:subtype-compatible-p #:capitalize + #:ensure-array-size #:observable-mixin #:add-observer #:remove-observer #:observer-notified #:notify-observers --- /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2007/12/28 10:08:52 1.5 +++ /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2008/01/01 18:43:36 1.6 @@ -219,6 +219,20 @@ (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) + (defclass observable-mixin () ((%observers :accessor observers :initform '())) From thenriksen at common-lisp.net Tue Jan 1 18:44:39 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 1 Jan 2008 13:44:39 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Experimental/freetype Message-ID: <20080101184439.A7C6312065@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv13896/Experimental/freetype Modified Files: mcclim-freetype.asd Log Message: Removed stale font-finding code from Freetype, now everyone uses the non-SBCL code. --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/mcclim-freetype.asd 2007/12/21 15:27:47 1.7 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/mcclim-freetype.asd 2008/01/01 18:44:39 1.8 @@ -64,28 +64,12 @@ location of the Bitstream Vera family of fonts on disk. If you don't have them, get them from http://www.gnome.org/fonts/~%~%~%")) -#+sbcl -(defmethod perform :after ((o load-op) (s (eql (asdf:find-system :mcclim-freetype)))) - (let ((fc-match (sb-ext:find-executable-in-search-path "fc-match"))) - (if (null fc-match) - (warn-about-unset-font-path) - (let* ((process (sb-ext:run-program fc-match `("-v" "Bitstream Vera") - :output :stream - :input nil)) - (font-path (parse-fontconfig-output (sb-ext:process-output process)))) - (if (null font-path) - (warn-about-unset-font-path) - (setf (symbol-value (intern "*FREETYPE-FONT-PATH*" :mcclim-freetype)) - font-path)))))) - -#-sbcl (defmethod perform :after ((o load-op) (s (eql (asdf:find-system :mcclim-freetype)))) (unless (setf (symbol-value (intern "*FREETYPE-FONT-PATH*" :mcclim-freetype)) (find-bitstream-fonts)) (warn-about-unset-font-path))) -#-sbcl (defun find-bitstream-fonts () (with-input-from-string (s (with-output-to-string (asdf::*verbose-out*) From thenriksen at common-lisp.net Tue Jan 1 19:55:32 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 1 Jan 2008 14:55:32 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080101195532.708016209F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv30125/Drei Modified Files: drei-redisplay.lisp Log Message: Tried to reduce the insanity and brokenness still residing in the remains of the first Drei redisplay engine. In particular, the bot mark should now be set automatically. The page-up/page-down functions should now be quite a bit more sane (though still totally unpredictable). Fix-pane-viewport now handles the case where point is partially obscured by the bottom of the pane. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/01 18:43:36 1.13 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/01 19:55:32 1.14 @@ -646,7 +646,9 @@ (incf cursor-y line-height)) when (or (>= (y2 (line-dimensions line)) pane-height) (= (line-end-offset line) (size (buffer view)))) - return (clear-stale-lines pane view))))) + return (progn + (setf (offset (bot view)) (line-end-offset line)) + (clear-stale-lines pane view)))))) (defun offset-in-stroke-position (stream view stroke offset) "Calculate the position in device units of `offset' in @@ -855,36 +857,15 @@ ;;; ;;; Drei pane redisplay. -(defun nb-lines-in-pane (pane) - (let* ((medium (sheet-medium pane)) - (style (medium-text-style medium)) - (height (text-style-height style medium))) - (multiple-value-bind (x y w h) (bounding-rectangle* pane) - (declare (ignore x y w)) - (max 1 (floor h (+ height (stream-vertical-spacing pane))))))) - -(defun adjust-pane-bot (drei-pane) - "Make the region on display fit the size of the pane as closely -as possible by adjusting bot leaving top intact." - (let* ((nb-lines-in-pane (nb-lines-in-pane drei-pane)) - (view (view drei-pane))) - (with-accessors ((top top) (bot bot)) view - (setf (offset bot) (offset top)) - (end-of-line bot) - (loop until (end-of-buffer-p bot) - repeat (1- nb-lines-in-pane) - do (forward-object bot) - (end-of-line bot))))) - (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 ((nb-lines-in-pane (nb-lines-in-pane drei-pane)) - (view (view drei-pane))) + (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) - #+nil(loop do (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)) @@ -896,14 +877,10 @@ reposition the pane if point is outside the visible area." (with-accessors ((buffer buffer) (top top) (bot bot) (point point)) (view drei-pane) - (let ((nb-lines-in-pane (nb-lines-in-pane drei-pane))) - (beginning-of-line top) - (end-of-line bot) - (when (or (mark< point top) - (>= (number-of-lines-in-region top point) - nb-lines-in-pane)) - (reposition-pane drei-pane)))) - (adjust-pane-bot drei-pane)) + (beginning-of-line top) + (when (or (mark< point top) + (mark> point bot)) + (reposition-pane drei-pane)))) (defun page-down (view) (with-accessors ((top top) (bot bot)) view @@ -916,16 +893,9 @@ (defun page-up (view) (with-accessors ((top top) (bot bot)) view (when (> (offset top) 0) - (let ((nb-lines-in-region (number-of-lines-in-region top bot))) - (setf (offset bot) (offset top)) - (end-of-line bot) - (loop repeat nb-lines-in-region - while (> (offset top) 0) - do (decf (offset top)) - (beginning-of-line top)) - (setf (offset (point view)) (offset bot)) - (beginning-of-line (point view)) - (invalidate-all-strokes view))))) + (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 @@ -946,18 +916,24 @@ (change-space-requirements pane :width output-width)))) (defmethod fix-pane-viewport :after ((pane drei-pane) (view point-mark-view)) + (declare (optimize (debug 3))) (when (and (pane-viewport pane) (active pane)) - (multiple-value-bind (cursor-x cursor-y) (offset-to-screen-position pane view (offset (point view))) - (declare (ignore cursor-y)) - (let ((x-position (abs (transform-position (sheet-transformation pane) 0 0))) - (viewport-width (bounding-rectangle-width (or (pane-viewport pane) pane)))) - (cond ((> cursor-x (+ x-position viewport-width)) - (move-sheet pane (round (- (- cursor-x viewport-width))) 0)) - ((> x-position cursor-x) - (move-sheet pane (if (> viewport-width cursor-x) - 0 - (round (- cursor-x))) - 0))))))) + (multiple-value-bind (cursor-x cursor-y line-height object-width) + (offset-to-screen-position pane view (offset (point view))) + (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 ((> (+ cursor-x object-width) (+ x-position viewport-width)) + (move-sheet pane (round (- (- cursor-x viewport-width))) 0)) + ((> x-position (+ cursor-x object-width)) + (move-sheet pane (if (> viewport-width cursor-x) + 0 + (round (- cursor-x))) + 0))) + (when (> (+ cursor-y line-height) (+ y-position viewport-height)) + (next-line (top view)) + ;; We start all over! + (display-drei-pane (pane-frame pane) pane))))))) (defmethod handle-repaint ((pane drei-pane) region) (declare (ignore region)) From thenriksen at common-lisp.net Tue Jan 1 21:17:57 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 1 Jan 2008 16:17:57 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080101211757.1379915008@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv16649/Drei Modified Files: drei-redisplay.lisp Log Message: Remove bogus call to now-dead function adjust-pane-bot. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/01 19:55:32 1.14 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/01 21:17:56 1.15 @@ -952,7 +952,6 @@ (defmethod fully-redisplay-pane ((drei-pane drei-pane) (view point-mark-view)) (reposition-pane drei-pane) - (adjust-pane-bot drei-pane) (setf (full-redisplay-p view) nil)) (defmethod fully-redisplay-pane :after ((drei-pane drei-pane) From thenriksen at common-lisp.net Tue Jan 1 22:51:03 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 1 Jan 2008 17:51:03 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Inspector Message-ID: <20080101225103.5C76F46183@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory clnet:/tmp/cvs-serv9218/Apps/Inspector Modified Files: inspector.lisp Log Message: Make Clouseau remember the scrolling position during redisplay, to ease navigating large object trees. Warning: somewhat of a hack. --- /project/mcclim/cvsroot/mcclim/Apps/Inspector/inspector.lisp 2007/12/20 10:46:54 1.38 +++ /project/mcclim/cvsroot/mcclim/Apps/Inspector/inspector.lisp 2008/01/01 22:51:03 1.39 @@ -53,6 +53,24 @@ (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 (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))))))) + (defmethod redisplay-frame-pane :after ((frame inspector) (pane application-pane) &key force-p) From thenriksen at common-lisp.net Tue Jan 1 23:23:07 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 1 Jan 2008 18:23:07 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Inspector Message-ID: <20080101232307.DFDD31130@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory clnet:/tmp/cvs-serv19441/Apps/Inspector Modified Files: inspector.lisp Log Message: Removed ancient and seemingly now-unnecessary gilberthack. --- /project/mcclim/cvsroot/mcclim/Apps/Inspector/inspector.lisp 2008/01/01 22:51:03 1.39 +++ /project/mcclim/cvsroot/mcclim/Apps/Inspector/inspector.lisp 2008/01/01 23:23:07 1.40 @@ -58,7 +58,7 @@ (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 (sheet-parent (find-pane-named frame 'app)))) + (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) From thenriksen at common-lisp.net Tue Jan 1 23:23:08 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 1 Jan 2008 18:23:08 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080101232308.2A2471125@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv19441 Modified Files: panes.lisp Log Message: Removed ancient and seemingly now-unnecessary gilberthack. --- /project/mcclim/cvsroot/mcclim/panes.lisp 2007/12/16 14:27:22 1.185 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2008/01/01 23:23:07 1.186 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.185 2007/12/16 14:27:22 thenriksen Exp $ +;;; $Id: panes.lisp,v 1.186 2008/01/01 23:23:07 thenriksen Exp $ (in-package :clim-internals) @@ -2784,13 +2784,10 @@ (unless borderp user-sr)))) (when borderp - (setq pane (make-pane 'border-pane - :border-width border-width - :contents (list pane))) - ;; bright, I begin to hate the border-pane - (setf pane (apply #'make-pane 'vrack-pane - :contents (list pane) - user-sr))) + (setq pane (apply #'make-pane 'border-pane + :border-width border-width + :contents (list pane) + user-sr))) pane)))) (defun make-clim-interactor-pane (&rest options) From thenriksen at common-lisp.net Wed Jan 2 09:20:27 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 2 Jan 2008 04:20:27 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080102092027.4BBE14619F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv11012/Drei Modified Files: drei-clim.lisp Log Message: Oops, Drei panes should not use incremental redisplay for now. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/01 18:43:36 1.26 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/02 09:20:26 1.27 @@ -151,13 +151,13 @@ (defclass drei-pane (drei application-pane) () (:default-initargs - :incremental-redisplay t - :end-of-line-action :scroll - :background *background-color* - :foreground *foreground-color* - :display-function 'display-drei-pane - :width 900 - :active nil) + :incremental-redisplay nil + :end-of-line-action :scroll + :background *background-color* + :foreground *foreground-color* + :display-function 'display-drei-pane + :width 900 + :active nil) (:documentation "An actual, instantiable Drei pane that permits (and requires) the host application to control the command loop completely.")) From thenriksen at common-lisp.net Wed Jan 2 10:03:02 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 2 Jan 2008 05:03:02 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080102100302.8599232036@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv20240/Drei Modified Files: drei-redisplay.lisp Log Message: Fixed some bugs in Drei's cursor-positioning and stroke-size-calculation code. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/01 21:17:56 1.15 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/02 10:03:02 1.16 @@ -400,7 +400,7 @@ (text-size stream stroke-string :text-style (merge-text-styles (face-style (drawing-options-face drawing-options)) - (medium-default-text-style stream))) + (medium-merged-text-style (sheet-medium stream)))) (values (- x2 x1) (- y2 y1))) (clear-rectangle* stream cursor-x cursor-y (+ cursor-x width) (+ cursor-y height @@ -488,9 +488,9 @@ buffer offset `start-offset', and will be drawn starting at (`cursor-x', `cursor-y')" (let* ((line (line-information view (displayed-lines-count view))) - (orig-x-offset cursor-x) (old-line-height (dimensions-height (line-dimensions line))) - (old-line-width (dimensions-width (line-dimensions line)))) + (old-line-width (dimensions-width (line-dimensions line))) + (orig-x-offset cursor-x)) (setf (line-start-offset line) start-offset (line-stroke-count line) 0) (loop for index from 0 @@ -662,7 +662,7 @@ (face-style (drawing-options-face (stroke-drawing-options stroke))) - (medium-default-text-style stream)))) + (medium-merged-text-style (sheet-medium stream))))) (defgeneric offset-to-screen-position (pane view offset) (:documentation "Returns the position of offset as a screen @@ -687,10 +687,9 @@ (return-from worker (values (x1 stroke-dimensions) (y1 stroke-dimensions) (dimensions-height line-dimensions) - (- (if (= end-offset (1+ start-offset)) - (x2 stroke-dimensions) - (offset-in-stroke-position pane view stroke (1+ offset))) - (x1 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 @@ -706,7 +705,9 @@ worker (values (x2 line-dimensions) (y1 line-dimensions) (dimensions-height line-dimensions)))))))) (with-accessors ((buffer buffer) (top top) (bot bot)) view - (let ((default-object-width (text-style-width (medium-default-text-style pane) pane))) + (let ((default-object-width + (text-style-width + (medium-merged-text-style (sheet-medium pane)) pane))) (cond ((< offset (offset top)) nil) ((< (offset bot) offset) t) From thenriksen at common-lisp.net Wed Jan 2 14:19:40 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 2 Jan 2008 09:19:40 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080102141940.57F32408D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv15790/Drei Modified Files: lisp-syntax.lisp Log Message: Changed erroneous and performance-killing call to update-syntax to a call to update-parse. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/12/27 15:22:54 1.42 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/02 14:19:36 1.43 @@ -2110,7 +2110,7 @@ (funcall fn list-child))))) (defmethod backward-one-expression (mark (syntax lisp-syntax)) - (update-syntax syntax 0 0) + (update-parse syntax 0 0) (let ((potential-form (or (form-before syntax (offset mark)) (form-around syntax (offset mark))))) (when (and (not (null potential-form)) From thenriksen at common-lisp.net Wed Jan 2 14:21:06 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 2 Jan 2008 09:21:06 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080102142106.9BE9270EF@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv17882/Drei Modified Files: lisp-syntax.lisp Log Message: Apparently, git is really stupid about files that change while you're writing the commit message. CVS is much better! Fixed last commit. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/02 14:19:36 1.43 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/02 14:21:06 1.44 @@ -2110,7 +2110,7 @@ (funcall fn list-child))))) (defmethod backward-one-expression (mark (syntax lisp-syntax)) - (update-parse syntax 0 0) + (update-parse syntax 0 (offset mark)) (let ((potential-form (or (form-before syntax (offset mark)) (form-around syntax (offset mark))))) (when (and (not (null potential-form)) From thenriksen at common-lisp.net Wed Jan 2 14:43:40 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 2 Jan 2008 09:43:40 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080102144340.B402C620C4@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv22872/Drei Modified Files: base.lisp drei-redisplay.lisp fundamental-syntax.lisp lr-syntax.lisp packages.lisp views.lisp Log Message: Connect redisplay to syntax information. Currently, the necessary methods are only implemented for Fundamental syntax, so there is still no syntax highlighting. There is, however, a 30-40% performance increase in redisplay, as Fundamental syntax is much better at keeping track of buffer contents than the hack I wrote for drei-buffer-view. --- /project/mcclim/cvsroot/mcclim/Drei/base.lisp 2007/12/27 13:39:25 1.8 +++ /project/mcclim/cvsroot/mcclim/Drei/base.lisp 2008/01/02 14:43:40 1.9 @@ -381,6 +381,56 @@ *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))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Character case --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/02 10:03:02 1.16 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/02 14:43:40 1.17 @@ -80,8 +80,7 @@ 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. This function will return -either the output record of the cursor, or NIL.") +is *guaranteed* to not return NIL or T.") (:method :around ((stream extended-output-stream) (view drei-view) (cursor drei-cursor)) (when (visible cursor view) @@ -198,40 +197,59 @@ (: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 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.")) - -(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))) + (: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 :around ((view drei-buffer-view) stroke pump-state) + ;; `call-next-method' for the next pump state, and compare + ;; the new stroke data with the old one. If it has changed, + ;; mark the stroke as dirty and modified. + (let ((old-start-offset (stroke-start-offset stroke)) + (old-end-offset (stroke-end-offset stroke)) + (old-drawing-options (stroke-drawing-options stroke)) + (new-pump-state (call-next-method))) + (unless (and old-start-offset + (= old-start-offset (stroke-start-offset stroke)) + (= old-end-offset (stroke-end-offset stroke)) + (drawing-options-equal old-drawing-options + (stroke-drawing-options stroke))) + (invalidate-stroke stroke :modified t)) + new-pump-state)) + (: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 @@ -240,17 +258,8 @@ and that they do not need to clear it themselves during their next redisplay." (loop for stroke across (line-strokes line) - do (setf (stroke-dirty stroke) t - (stroke-modified stroke) - (or (stroke-modified stroke) - modified - cleared)) - when cleared - do (let ((dimensions (stroke-dimensions stroke))) - (setf (x1 dimensions) 0 - (y1 dimensions) 0 - (x2 dimensions) 0 - (y2 dimensions) 0)))) + 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 @@ -560,33 +569,6 @@ the buffer determining where the next stroke should start." offset) -(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 fetch-chunk (buffer chunk-start-offset) "Retrieve a chunk from `buffer', with the chunk starting at `chunk-start-offset'. The chunk is a cons, with the car being the @@ -617,16 +599,9 @@ (actual-end-offset (if (functionp (cdr chunk)) (1+ (car chunk)) (cdr chunk)))) - (unless (and (stroke-start-offset stroke) - (= (stroke-start-offset stroke) (car chunk)) - (= (stroke-end-offset stroke) actual-end-offset) - (drawing-options-equal (stroke-drawing-options stroke) - drawing-options)) - (setf (stroke-start-offset stroke) (car chunk) - (stroke-end-offset stroke) actual-end-offset - (stroke-modified stroke) t - (stroke-dirty stroke) t - (stroke-drawing-options stroke) drawing-options)) + (setf (stroke-start-offset stroke) (car chunk) + (stroke-end-offset stroke) actual-end-offset + (stroke-drawing-options stroke) drawing-options) (if (offset-end-of-line-p (buffer view) actual-end-offset) (1+ actual-end-offset) actual-end-offset))) @@ -673,7 +648,6 @@ the end of the buffer.")) (defmethod offset-to-screen-position ((pane clim-stream-pane) (view drei-view) (offset number)) - (declare (optimize (debug 3))) (flet ((worker () (do-displayed-lines (line view) (when (<= (line-start-offset line) offset (line-end-offset line)) @@ -728,33 +702,29 @@ (view drei-buffer-view) (cursor drei-cursor)) (when (<= (offset (top view)) (offset (mark cursor)) (offset (bot view))) - (let ((cursor-output-record (call-next-method))) - (when cursor-output-record - (with-bounding-rectangle* (x1 y1 x2 y2) cursor-output-record - (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))))))))))))) + (clear-output-record 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)))))))))))) (defmethod display-drei-view-cursor ((stream extended-output-stream) (view drei-buffer-view) (cursor drei-cursor)) (multiple-value-bind (cursor-x cursor-y line-height object-width) (offset-to-screen-position stream view (offset (mark cursor))) - (updating-output (stream :unique-id (list* stream view cursor) - :id-test #'equal - :cache-value (list* cursor-x cursor-y line-height object-width) - :cache-test #'equal - :all-new t) + (letf (((stream-current-output-record stream) cursor)) (draw-rectangle* stream cursor-x cursor-y (+ cursor-x object-width) (+ cursor-y line-height) @@ -917,7 +887,6 @@ (change-space-requirements pane :width output-width)))) (defmethod fix-pane-viewport :after ((pane drei-pane) (view point-mark-view)) - (declare (optimize (debug 3))) (when (and (pane-viewport pane) (active pane)) (multiple-value-bind (cursor-x cursor-y line-height object-width) (offset-to-screen-position pane view (offset (point view))) --- /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2007/12/08 08:53:50 1.7 +++ /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2008/01/02 14:43:40 1.8 @@ -34,7 +34,8 @@ ;;; The syntax object and misc stuff. (define-syntax fundamental-syntax (syntax) - ((lines :initform (make-instance 'standard-flexichain)) + ((lines :initform (make-instance 'standard-flexichain) + :reader lines) (scan :accessor scan)) (:command-table fundamental-table) (:name "Fundamental")) @@ -51,24 +52,54 @@ ;;; update syntax (defclass line-object () - ((start-mark :initarg :start-mark :reader start-mark))) - -(defmethod update-syntax-for-display (buffer (syntax fundamental-syntax) top bot) - nil) + ((%start-mark :reader start-mark + :initarg :start-mark) + (%chunks :accessor chunks + :initform (make-array 5 + :adjustable t + :fill-pointer 0)))) + +(defun get-chunk (buffer chunk-start-offset 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 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 nil)) + ((not (characterp (buffer-object buffer chunk-end-offset))) + (cons (1+ chunk-end-offset) t))))) + +(defmethod initialize-instance :after ((line line-object) + &rest initargs) + (declare (ignore initargs)) + (loop with buffer = (buffer (start-mark line)) + with chunk-start-offset = (offset (start-mark line)) + with line-end-offset = (end-of-line-offset buffer (offset (start-mark line))) + for chunk-info = (get-chunk (buffer (start-mark line)) + chunk-start-offset line-end-offset) + do (vector-push-extend chunk-info (chunks line)) + (setf chunk-start-offset (car chunk-info)) + when (= chunk-start-offset line-end-offset) + do (loop-finish))) (defmethod update-syntax ((syntax fundamental-syntax) prefix-size suffix-size &optional begin end) (declare (ignore begin end)) - (let ((low-mark (clone-mark (scan syntax) :left)) - (high-mark (clone-mark (scan syntax) :left))) - (setf (offset low-mark) prefix-size - (offset high-mark) (- (size (buffer syntax)) suffix-size)) + (let ((low-mark (make-buffer-mark (buffer syntax) prefix-size :left)) + (high-mark (make-buffer-mark + (buffer syntax) (- (size (buffer syntax)) suffix-size) :left))) (when (mark<= low-mark high-mark) (beginning-of-line low-mark) (end-of-line high-mark) (with-slots (lines scan) syntax (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)))) @@ -76,139 +107,91 @@ (setf low-index (1+ middle))) (t (setf high-index middle))))) - ;; discard lines that have to be re-analyzed + ;; 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 + ;; Analyze new lines. (setf (offset scan) (offset low-mark)) - (loop while (and (mark<= scan high-mark) - (not (end-of-buffer-p scan))) + (loop while (mark<= scan high-mark) for i from low-index do (progn (insert* lines i (make-instance 'line-object :start-mark (clone-mark scan))) (end-of-line scan) - (unless (end-of-buffer-p scan) - ;; skip newline - (forward-object scan))))))))) + (if (end-of-buffer-p scan) + (loop-finish) + ;; skip newline + (forward-object scan))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; display -(defvar *white-space-start* nil) - -(defvar *current-line* 0) - -(defun handle-whitespace (pane view buffer start end) - (let ((space-width (space-width pane view)) - (tab-width (tab-width pane view))) - (with-sheet-medium (medium pane) - (with-accessors ((cursor-positions cursor-positions)) view - (loop while (< start end) - do (case (buffer-object buffer start) - (#\Newline (record-line-vertical-offset pane view (incf *current-line*)) - (terpri pane) - (stream-increment-cursor-position - pane (first (aref cursor-positions 0)) 0)) - ((#\Page #\Return #\Space) (stream-increment-cursor-position - pane space-width 0)) - (#\Tab (when (plusp tab-width) - (let ((x (stream-cursor-position pane))) - (stream-increment-cursor-position - pane (- tab-width (mod x tab-width)) 0))))) - (incf start)))))) - -(defmethod display-line ((stream clim-stream-pane) (view textual-drei-syntax-view) mark) - (let ((mark (clone-mark mark))) - (let ((saved-offset nil) - (id 0) - (space-width (space-width stream view)) - (tab-width (tab-width stream view))) - (flet ((output-word () - (unless (null saved-offset) - (let ((contents (coerce (region-to-sequence - saved-offset - mark) - 'string))) - (updating-output (stream :unique-id (cons view (incf id)) - :id-test #'equal - :cache-value contents - :cache-test #'equal) - (unless (null contents) - (present contents 'string :stream stream)))) - (setf saved-offset nil)))) - (loop - until (end-of-line-p mark) - do (let ((obj (object-after mark))) - (cond ((eql obj #\Space) - (output-word) - (stream-increment-cursor-position stream space-width 0)) - ((eql obj #\Tab) - (output-word) - (let ((x (stream-cursor-position stream))) - (stream-increment-cursor-position - stream (- tab-width (mod x tab-width)) 0))) - ((constituentp obj) - (when (null saved-offset) - (setf saved-offset (offset mark)))) - ((characterp obj) - (output-word) - (updating-output (stream :unique-id (cons stream (incf id)) - :id-test #'equal - :cache-value obj) - (present obj 'character :stream stream))) - (t - (output-word) - (updating-output (stream :unique-id (cons stream (incf id)) - :id-test #'equal - :cache-value obj - :cache-test #'eq) - (present obj (presentation-type-of obj) - :stream stream))))) - do (forward-object mark) - finally - (output-word) - (unless (end-of-buffer-p mark) - (terpri stream))))))) - -(defmethod display-syntax-view ((stream clim-stream-pane) (view textual-drei-syntax-view) - (syntax fundamental-syntax)) - (update-parse syntax) - (with-accessors ((top top) (bot bot)) view - (with-accessors ((cursor-positions cursor-positions)) view - (setf cursor-positions (make-array (1+ (number-of-lines-in-region top bot)) - :initial-element nil - :fill-pointer 1 - :adjustable t) - *current-line* 0 - (aref cursor-positions 0) (multiple-value-list (stream-cursor-position stream)))) - (setf *white-space-start* (offset top)) - (with-slots (lines scan) syntax - (let ((low-index 0) - (high-index (nb-elements 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> top line-start) - (setf low-index (1+ middle))) - ((mark< top line-start) - (setf high-index middle)) - (t - (setf low-index middle - high-index middle))))) - (loop for i from low-index - while (and (< i (nb-elements lines)) - (mark< (start-mark (element* lines i)) - bot)) - do (let ((line (element* lines i))) - (updating-output (stream :unique-id (cons view i) - :id-test #'equal - :cache-value line - :cache-test #'equal) - (display-line stream view (start-mark (element* lines i)))))))))) +(defstruct (pump-state + (:constructor make-pump-state + (line-index offset chunk-index))) + "A pump state object used in the fundamental syntax. `Line' is +the line object `offset' is in, and `line-index' is the index of +`line' in the list of lines maintained by the syntax that created +this pump state." + line-index + offset + chunk-index) + +(defmethod pump-state-for-offset-with-syntax ((view textual-drei-syntax-view) + (syntax fundamental-syntax) (offset integer)) + (update-parse syntax 0 offset) + ;; Perform binary search looking for line starting with `offset'. + (with-accessors ((lines lines)) syntax + (loop with low-index = 0 + with high-index = (nb-elements lines) + for middle = (floor (+ low-index high-index) 2) + for line-start = (start-mark (element* lines middle)) + do (cond ((mark> offset line-start) + (setf low-index (1+ middle))) + ((mark< offset line-start) + (setf high-index middle)) + ((mark= offset line-start) + (loop-finish))) + finally (return (make-pump-state middle offset 0))))) + +(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, or a function, in which case it is +the drawing function for a single-object non-character chunk." + (destructuring-bind (chunk-end-offset . objectp) + (aref (chunks line) chunk-index) + (if objectp (object-drawer) chunk-end-offset))) + +(defmethod stroke-pump-with-syntax ((view textual-drei-syntax-view) + (syntax fundamental-syntax) stroke + (pump-state pump-state)) + ;; `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 + (update-parse syntax 0 offset) + (let* ((chunk (fetch-chunk + (element* (lines syntax) 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)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2007/12/19 17:17:37 1.5 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/02 14:43:40 1.6 @@ -294,6 +294,7 @@ (defmethod update-syntax ((syntax lr-syntax-mixin) prefix-size suffix-size &optional begin end) (declare (ignore begin end)) + (call-next-method) (let* ((low-mark-offset prefix-size) (high-mark-offset (- (size (buffer syntax)) suffix-size))) (when (<= low-mark-offset high-mark-offset) --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/01 18:43:36 1.28 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/02 14:43:40 1.29 @@ -105,6 +105,12 @@ #: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 #:buffer-whitespacep #:buffer-region-case #:buffer-looking-at #:looking-at @@ -211,6 +217,8 @@ #:drei-view #:modified-p #:no-cursors #:drei-buffer-view #:buffer #:top #:bot #:drei-syntax-view #:syntax + #:pump-state-for-offset-with-syntax + #:stroke-pump-with-syntax #:point-mark-view #:textual-drei-syntax-view #:tab-space-count #:space-width #:tab-width #:use-tabs @@ -243,8 +251,17 @@ #:drei #:drei-pane #:drei-gadget-pane #:drei-area #:handling-drei-conditions #:handle-drei-condition #:execute-drei-command - #:display-drei-view-contents #:display-syntax-view - #:display-drei-view-cursor + #:display-drei-view-contents #:display-drei-view-cursor + + #: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* #:with-drei-options #:performing-drei-operations #:invoke-performing-drei-operations #:with-bound-drei-special-variables --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/01 18:43:36 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/02 14:43:40 1.10 @@ -683,6 +683,25 @@ (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)) From thenriksen at common-lisp.net Thu Jan 3 12:32:08 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 3 Jan 2008 07:32:08 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080103123208.E2C5D64110@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv3433/Drei Modified Files: fundamental-syntax.lisp lisp-syntax.lisp lr-syntax.lisp packages.lisp Log Message: Added syntax highlighting of Lisp syntax. Yay! Doesn't highlight fully as much as it used to, as it's slightly more complicated to get fast enough. Also, not terribly heavily optimized. --- /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2008/01/02 14:43:40 1.8 +++ /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2008/01/03 12:32:08 1.9 @@ -54,11 +54,17 @@ (defclass line-object () ((%start-mark :reader start-mark :initarg :start-mark) + (%line-length :reader line-length + :initarg :line-length) (%chunks :accessor chunks :initform (make-array 5 :adjustable t :fill-pointer 0)))) +(defun line-end-offset (line) + "Return the end buffer offset of `line'." + (+ (offset (start-mark line)) (line-length line))) + (defun get-chunk (buffer chunk-start-offset line-end-offset) (let* ((chunk-end-offset (buffer-find-nonchar buffer chunk-start-offset @@ -116,14 +122,16 @@ (setf (offset scan) (offset low-mark)) (loop while (mark<= scan high-mark) for i from low-index - do (progn (insert* lines i (make-instance - 'line-object - :start-mark (clone-mark scan))) - (end-of-line scan) - (if (end-of-buffer-p scan) - (loop-finish) - ;; skip newline - (forward-object scan))))))))) + do (progn (let ((line-start-mark (clone-mark scan))) + (insert* lines i (make-instance + 'line-object + :start-mark line-start-mark + :line-length (- (offset (end-of-line scan)) + (offset line-start-mark)))) + (if (end-of-buffer-p scan) + (loop-finish) + ;; skip newline + (forward-object scan)))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -195,7 +203,32 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; exploit the parse +;;; exploit the parse + +(defun offset-in-line-p (line offset) + "Return true if `offset' is in the buffer region delimited by +`line'." + (<= (offset (start-mark line)) offset + (line-end-offset line))) + +(defun line-containing-offset (syntax mark-or-offset) + "Return the line `mark-or-offset' is in for `syntax'. `Syntax' +must be a `fundamental-syntax' object." + ;; Perform binary search looking for line containing `offset1'. + (as-offsets ((offset mark-or-offset)) + (with-accessors ((lines lines)) syntax + (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 this-line))))) ;; do this better (defmethod syntax-line-indentation ((syntax fundamental-syntax) mark tab-width) --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/02 14:21:06 1.44 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/03 12:32:08 1.45 @@ -147,6 +147,9 @@ (or (image syntax) (default-image)))) +(defconstant +keyword-package+ (find-package :keyword) + "The KEYWORD package.") + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Swank interface functions. @@ -1479,6 +1482,39 @@ (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 @@ -1731,242 +1767,22 @@ ;;; ;;; display -(defparameter *reader-conditional-faces* - (list (make-face :error +red+) - (make-face :string +gray50+ (make-text-style nil :italic nil)) - (make-face :keyword +gray50+) - (make-face :macro +gray50+) - (make-face :special-form +gray50+) - (make-face :lambda-list-keyword +gray50+) - (make-face :comment +gray50+) - (make-face :reader-conditional +gray50+))) - -(define-standard-faces lisp-syntax - (make-face :error +red+) - (make-face :string +rosy-brown+ (make-text-style nil :italic nil)) - (make-face :keyword +orchid+) - (make-face :macro +purple+) - (make-face :special-form +purple+) - (make-face :lambda-list-keyword +dark-green+) - (make-face :comment +maroon+) - (make-face :reader-conditional +gray50+)) - -(defmethod display-parse-tree ((parse-symbol (eql nil)) stream (view textual-drei-syntax-view) - (syntax lisp-syntax)) - nil) - -(defmethod display-parse-tree ((parse-symbol error-symbol) stream - (view textual-drei-syntax-view) (syntax lisp-syntax)) - (let ((children (children parse-symbol))) - (loop until (or (null (cdr children)) - (typep (parser-state (cadr children)) 'error-state)) - do (display-parse-tree (pop children) stream view syntax)) - (if (and (null (cdr children)) - (not (typep (parser-state parse-symbol) 'error-state))) - (display-parse-tree (car children) stream view syntax) - (with-face (:error) - (loop for child in children - do (display-parse-tree child stream view syntax)))))) - -(defmethod display-parse-tree ((parse-symbol error-lexeme) stream - (view textual-drei-syntax-view) (syntax lisp-syntax)) - (with-face (:error) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol unmatched-right-parenthesis-lexeme) - stream (view textual-drei-syntax-view) (syntax lisp-syntax)) - (with-face (:error) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol token-mixin) stream - (view textual-drei-syntax-view) (syntax lisp-syntax)) - (if (> (the fixnum (end-offset parse-symbol)) (the fixnum (start-offset parse-symbol))) - (let ((symbol (form-to-object syntax parse-symbol :no-error t))) - (with-output-as-presentation (stream symbol 'symbol :single-box :highlighting) - (cond ((eql (buffer-object (buffer syntax) (start-offset parse-symbol)) #\:) - (with-face (:keyword) - (call-next-method))) - ((eql (buffer-object (buffer syntax) (start-offset parse-symbol)) #\&) - (with-face (:lambda-list-keyword) - (call-next-method))) - ((and (symbolp symbol) - (macro-function symbol) - (form-operator-p syntax parse-symbol)) - (with-face (:macro) - (call-next-method))) - ((and (symbolp symbol) - (special-operator-p symbol) - (form-operator-p syntax parse-symbol)) - (with-face (:special-form) - (call-next-method))) - (t (call-next-method))))) - (call-next-method))) - -(defmethod display-parse-tree ((parser-symbol literal-object-form) stream (view textual-drei-syntax-view) - (syntax lisp-syntax)) - (updating-output - (stream :unique-id (list view parser-symbol) - :id-test #'equal - :cache-value parser-symbol - :cache-test #'eql) - (let ((object (form-to-object syntax parser-symbol))) - (present object (presentation-type-of object) :stream stream)))) - -(defmethod display-parse-tree ((parser-symbol lisp-lexeme) stream (view textual-drei-syntax-view) - (syntax lisp-syntax)) - (flet ((cache-test (t1 t2) - (and (eq t1 t2) - (eq (slot-value t1 'ink) - (medium-ink (sheet-medium stream))) - (eq (slot-value t1 'face) - (text-style-face (medium-text-style (sheet-medium stream))))))) - (updating-output - (stream :unique-id (list view parser-symbol) - :id-test #'equal - :cache-value parser-symbol - :cache-test #'cache-test) - (with-slots (ink face) parser-symbol - (setf ink (medium-ink (sheet-medium stream)) - face (text-style-face (medium-text-style (sheet-medium stream)))) - (write-string (form-string syntax parser-symbol) stream))))) - -(define-presentation-type lisp-string () - :description "lisp string") - -(defmethod display-parse-tree ((parse-symbol complete-string-form) stream - (view textual-drei-syntax-view) (syntax lisp-syntax)) - (let ((children (children parse-symbol))) - (if (third children) - (let ((string (buffer-substring (buffer syntax) - (start-offset (second children)) - (end-offset (car (last children 2)))))) - (with-output-as-presentation (stream string 'lisp-string - :single-box :highlighting) - (with-face (:string) - (display-parse-tree (pop children) stream view syntax) - (loop until (null (cdr children)) - do (display-parse-tree (pop children) stream view syntax)) - (display-parse-tree (pop children) stream view syntax)))) - (with-face (:string) - (progn (display-parse-tree (pop children) stream view syntax) - (display-parse-tree (pop children) stream view syntax)))))) - -(defmethod display-parse-tree ((parse-symbol incomplete-string-form) stream - (view textual-drei-syntax-view) (syntax lisp-syntax)) - (let ((children (children parse-symbol))) - (if (second children) - (let ((string (buffer-substring (buffer syntax) - (start-offset (second children)) - (end-offset (car (last children)))))) - (with-output-as-presentation (stream string 'lisp-string - :single-box :highlighting) - (with-face (:string) - (display-parse-tree (pop children) stream view syntax) - (loop until (null children) - do (display-parse-tree (pop children) stream view syntax))))) - (with-face (:string) - (display-parse-tree (pop children) stream view syntax))))) - -(defmethod display-parse-tree ((parse-symbol line-comment-form) stream - (view textual-drei-syntax-view) (syntax lisp-syntax)) - (with-face (:comment) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol long-comment-form) stream - (view textual-drei-syntax-view) (syntax lisp-syntax)) - (with-face (:comment) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol reader-conditional-positive-form) - stream (view textual-drei-syntax-view) (syntax lisp-syntax)) - (let ((conditional (second-noncomment (children parse-symbol)))) - (if (eval-feature-conditional conditional syntax) - (call-next-method) - (let ((*current-faces* *reader-conditional-faces*)) - (with-face (:reader-conditional) - (call-next-method)))))) - -(defmethod display-parse-tree ((parse-symbol reader-conditional-negative-form) - stream (view textual-drei-syntax-view) (syntax lisp-syntax)) - (let ((conditional (second-noncomment (children parse-symbol)))) - (if (eval-feature-conditional conditional syntax) - (let ((*current-faces* *reader-conditional-faces*)) - (with-face (:reader-conditional) - (call-next-method))) - (call-next-method)))) - -(defgeneric eval-feature-conditional (conditional-form syntax)) - -(defmethod eval-feature-conditional (conditional-form (syntax lisp-syntax)) - nil) - -;; Adapted from slime.el - -(defconstant +keyword-package+ (find-package :keyword) - "The KEYWORD package.") - -(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))))))))) +;; Note that we do not colour keyword symbols or special forms yet, +;; that is because the only efficient way to do so is to mark them as +;; interesting in the parser itself, it is too slow to check for it in +;; highlighting rules. +(make-syntax-highlighting-rules emacs-style-highlighting + (error-symbol (:face :ink +red+)) + (string-form (:face :ink +rosy-brown+ + :style (make-text-style nil :italic nil))) + (comment (:face :ink +maroon+ :style (make-text-style :serif :bold :large)))) + +(defparameter *syntax-highlighting-rules* 'emacs-style-highlighting + "The syntax highlighting rules used for highlighting Lisp +syntax.") -(defmethod display-parse-tree ((parse-symbol complete-list-form) stream - (view textual-drei-syntax-view) (syntax lisp-syntax)) - (let* ((children (children parse-symbol)) - (point-offset (the fixnum (offset (point view)))) - ;; The following is true if the location if the point - ;; warrants highlighting of a set of matching parentheses. - (should-highlight (and (active view) - (or (= (the fixnum (end-offset parse-symbol)) point-offset) - (= (the fixnum (start-offset parse-symbol)) point-offset))))) - (if should-highlight - (with-text-face (stream :bold) - (display-parse-tree (car children) stream view syntax)) - (display-parse-tree (car children) stream view syntax)) - (loop for child-list on (cdr children) - if (and should-highlight (null (cdr child-list))) do - (with-text-face (stream :bold) - (display-parse-tree (car child-list) stream view syntax)) - else do - (display-parse-tree (car child-list) stream view syntax)))) - -(defmethod display-parse-tree ((parse-symbol incomplete-list-form) stream - (view textual-drei-syntax-view) (syntax lisp-syntax)) - (update-parse syntax) - (let* ((children (children parse-symbol)) - (point-offset (the fixnum (offset (point view)))) - ;; The following is set to true if the location if the point - ;; warrants highlighting of the beginning parenthesis - (should-highlight (and (active view) - (= (the fixnum (start-offset parse-symbol)) point-offset)))) - (with-face (:error) - (if should-highlight - (with-text-face (stream :bold) - (display-parse-tree (car children) stream view syntax)) - (display-parse-tree (car children) stream view syntax))) - (loop for child in (cdr children) do - (display-parse-tree child stream view syntax)))) +(defmethod syntax-highlighting-rules ((syntax lisp-syntax)) + *syntax-highlighting-rules*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/02 14:43:40 1.6 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/03 12:32:08 1.7 @@ -28,7 +28,8 @@ (in-package :drei-lr-syntax) (defclass lr-syntax-mixin () - ((stack-top :initform nil) + ((stack-top :initform nil + :accessor stack-top) (potentially-valid-trees) (lookahead-lexeme :initform nil :accessor lookahead-lexeme) (current-state) @@ -289,6 +290,66 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; 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) + , at 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 ((syntax lr-syntax-mixin) prefix-size suffix-size @@ -317,85 +378,182 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; Redisplay. This is just some minor conveniences, not an actual -;;; generic redisplay implementation for LR syntaxes. - -(defvar *current-faces* nil - "The current faces used by the syntax for redisplay. Will be -bound during redisplay.") - -(defstruct (face (:type list) - (:constructor make-face (name colour &optional style))) - name colour (style nil)) - -(defgeneric get-faces (syntax) - (:documentation "Return a list of all the defined standard -faces of `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 make-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 +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 + 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." + (check-type name symbol) + `(progn + (fmakunbound ',name) + (defgeneric ,name (syntax parser-symbol) + (:method (syntax (parser-symbol parser-symbol)) + nil)) + ,@(flet ((make-rule-exp (type args) + (ecase type + (:face `#'(lambda (syntax parser-symbol) + (declare (ignore syntax parser-symbol)) + (make-drawing-options :face (make-face , at args)))) + (:options `#'(lambda (syntax parser-symbol) + (declare (ignore syntax parser-symbol)) + (make-drawing-options , at args))) + (:function (first args))))) + (loop for (parser-symbol (type . args)) in rules + collect `(let ((rule ,(make-rule-exp type args))) + (defmethod ,name (syntax (parser-symbol ,parser-symbol)) + (funcall rule syntax parser-symbol))))))) + +(make-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-face (name) - "Retrieve face named `name' from `*current-faces*'." - (find name *current-faces* :key #'face-name)) - -(defmacro define-standard-faces (syntax &body faces) - "Define the list of standard faces used by `syntax' to be -`faces', which must be a sequence of forms evaluating to -face-values ((name, colour, style)-triples)." - `(let ((faces-list (list , at faces))) - (defmethod get-faces ((syntax ,syntax)) - faces-list))) - -(defmacro with-face ((face &optional (stream-symbol 'stream)) &body body) - `(with-drawing-options (,stream-symbol :ink (face-colour (get-face ,face)) - :text-style (face-style (get-face ,face))) - , at body)) - -(defgeneric display-parse-tree (parse-symbol stream view syntax) - (:documentation "Display the given parse-symbol on `stream', -assuming `view' to be the relevant Drei vire and `syntax' being -the syntax object responsible for the parse symbol.")) - -(defmethod display-parse-tree :before ((parse-symbol lexeme) - stream (view textual-drei-syntax-view) - (syntax lr-syntax-mixin)) - (handle-whitespace stream view (buffer view) - *white-space-start* (start-offset parse-symbol)) - (setf *white-space-start* (end-offset parse-symbol))) - -(defmethod display-parse-tree :around ((parse-symbol parser-symbol) - stream (view textual-drei-syntax-view) - (syntax lr-syntax-mixin)) - (with-accessors ((top top) (bot bot)) view - (when (and (start-offset parse-symbol) - (mark< (start-offset parse-symbol) bot) - (mark> (end-offset parse-symbol) top)) - (call-next-method)))) - -(defmethod display-parse-tree ((parse-symbol parser-symbol) - stream (view textual-drei-syntax-view) - (syntax lr-syntax-mixin)) - (with-accessors ((top top) (bot bot)) view - (loop for child in (children parse-symbol) - when (and (start-offset child) - (mark> (end-offset child) top)) - do (if (mark< (start-offset child) bot) - (display-parse-tree child stream view syntax) - (return))))) - -(defmethod display-syntax-view ((stream clim-stream-pane) (view textual-drei-syntax-view) - (syntax lr-syntax-mixin)) - (update-parse syntax) - (with-accessors ((top top) (bot bot)) view - (with-accessors ((cursor-positions cursor-positions)) view - ;; There must always be room for at least one element of line - ;; information. - (setf cursor-positions (make-array (1+ (number-of-lines-in-region top bot)) - :initial-element nil) - *current-line* 0 - (aref cursor-positions 0) (multiple-value-list - (stream-cursor-position stream)))) - (setf *white-space-start* (offset top))) - (let ((*current-faces* (get-faces syntax))) - (with-slots (stack-top) syntax - (display-parse-tree stack-top stream view syntax)))) +(defun get-drawing-options (highlighting-rules syntax parse-symbol) + "Get the drawing options with which `parse-symbol' should be +drawn. If `parse-symbol' is NIL, return NIL." + (when parse-symbol + (funcall highlighting-rules syntax 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) + +(defmethod pump-state-for-offset-with-syntax ((view textual-drei-syntax-view) + (syntax lr-syntax-mixin) (offset integer)) + (update-parse syntax 0 offset) + (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) + (cons (size (buffer view)) +default-drawing-options+) + (let ((drawing-options + (get-drawing-options highlighting-rules syntax parser-symbol))) + (if (null drawing-options) + (initial-drawing-options (parent parser-symbol)) + (cons (end-offset parser-symbol) drawing-options)))))) + (make-pump-state parser-symbol offset + (list (initial-drawing-options parser-symbol) + (cons (1+ (size (buffer view))) +default-drawing-options+)) + highlighting-rules)))) + +(defun find-next-stroke-end (syntax 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 syntax offset))) + (flet ((finish (offset symbol &optional stroke-drawing-options) + (setf start-symbol symbol) + (loop until (> (car (first drawing-options)) offset) + do (pop drawing-options)) + (unless (null stroke-drawing-options) + (push (cons (end-offset symbol) stroke-drawing-options) + drawing-options)) + (return-from find-next-stroke-end + offset))) + (if (null start-symbol) + ;; This means that all remaining lines are blank. + (finish (line-end-offset line) nil) + (or (do-parse-symbols-forward (symbol offset start-symbol) + (let ((symbol-drawing-options + (get-drawing-options highlighting-rules syntax symbol))) + (cond ((> (start-offset symbol) (line-end-offset line)) + (finish (line-end-offset line) start-symbol)) + ((and (> (start-offset symbol) offset) + (not (drawing-options-equal (or symbol-drawing-options + +default-drawing-options+) + (cdr (first drawing-options))))) + (finish (start-offset symbol) symbol symbol-drawing-options)) + ((and (= (start-offset symbol) offset) + (offset-beginning-of-line-p (buffer syntax) offset) + (and symbol-drawing-options + (not (drawing-options-equal symbol-drawing-options + (cdr (first drawing-options)))))) + (finish (start-offset symbol) symbol symbol-drawing-options))))) + ;; 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 line) 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 (cdr (first current-drawing-options))) + (end-offset (find-next-stroke-end syntax pump-state))) + (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)))))) --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/02 14:43:40 1.29 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/03 12:32:08 1.30 @@ -169,8 +169,6 @@ #:display-syntax-name #:syntax-line-indentation #:eval-defun - #:record-line-vertical-offset - #:line-vertical-offset #:syntax-line-comment-string #:line-comment-region #:comment-region #:line-uncomment-region #:uncomment-region @@ -487,13 +485,15 @@ (:use :clim-lisp :clim :drei-buffer :drei-base :drei-syntax :flexichain :drei :drei-core) (:export #:fundamental-syntax #:scan - #:*current-line* #:*white-space-start* #:handle-whitespace) + #:start-mark #:line-length #:line-end-offset + #:line-containing-offset #:offset-in-line-p) (: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) + :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 @@ -505,10 +505,8 @@ #:action #:new-state #:done #:reduce-fixed-number #:reduce-until-type #:reduce-all #:error-state #:error-reduce-state - #:*current-faces* - #:make-face #:face-name #:face-colour #:face-style - #:get-faces #:define-standard-faces #:with-face - #:display-parse-tree) + #:make-syntax-highlighting-rules + #:syntax-highlighting-rules) (:documentation "Underlying LR parsing functionality.")) (defpackage :drei-lisp-syntax @@ -564,8 +562,6 @@ #:at-end-of-string-p #:at-beginning-of-children-p #:at-end-of-children-p - #:structurally-at-beginning-of-children-p - #:structurally-at-end-of-children-p #:comment-at-mark ;; Lambda list classes. From thenriksen at common-lisp.net Thu Jan 3 16:19:42 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 3 Jan 2008 11:19:42 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080103161942.D3B132D1A6@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv8313/Drei Modified Files: buffer.lisp Log Message: Added print-object method for buffers. --- /project/mcclim/cvsroot/mcclim/Drei/buffer.lisp 2008/01/01 18:43:36 1.6 +++ /project/mcclim/cvsroot/mcclim/Drei/buffer.lisp 2008/01/03 16:19:42 1.7 @@ -690,3 +690,11 @@ (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)))) From thenriksen at common-lisp.net Thu Jan 3 16:21:23 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 3 Jan 2008 11:21:23 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080103162123.4EAF543238@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv10630/Drei Modified Files: views.lisp Log Message: Buffer-views no longer responsible for updating syntax-view data. --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/02 14:43:40 1.10 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/03 16:21:20 1.11 @@ -555,16 +555,10 @@ (defmethod observer-notified ((view drei-buffer-view) (buffer drei-buffer) changed-region) - (with-accessors ((prefix-size prefix-size) - (suffix-size suffix-size)) view - (setf prefix-size (min (car changed-region) prefix-size) - suffix-size (min (- (size buffer) (cdr changed-region)) - suffix-size) - (modified-p view) t) - (dotimes (i (displayed-lines-count view)) - (let ((line (line-information view i))) - (when (<= (car changed-region) (line-end-offset line)) - (invalidate-line-strokes line :modified t)))))) + (dotimes (i (displayed-lines-count view)) + (let ((line (line-information view i))) + (when (<= (car changed-region) (line-end-offset line)) + (invalidate-line-strokes line :modified t))))) (defclass drei-syntax-view (drei-buffer-view) ((%syntax :accessor syntax) @@ -651,6 +645,16 @@ (disable-mode (syntax modual) mode-name) (call-next-method))) +(defmethod observer-notified ((view drei-syntax-view) (buffer drei-buffer) + changed-region) + (with-accessors ((prefix-size prefix-size) + (suffix-size suffix-size)) view + (setf prefix-size (min (car changed-region) prefix-size) + suffix-size (min (- (size buffer) (cdr changed-region)) + suffix-size) + (modified-p view) t)) + (call-next-method)) + (defmethod synchronize-view :around ((view drei-syntax-view) &key force-p) ;; If nothing changed, then don't call the other methods. @@ -672,8 +676,7 @@ (setf (prefix-size view) (size (buffer view)) (suffix-size view) (size (buffer view)) (buffer-size view) (size (buffer view))) - (update-syntax (syntax view) prefix-size suffix-size - begin end) + (update-syntax (syntax view) prefix-size suffix-size begin end) (call-next-method))) (defun make-syntax-for-view (view syntax-symbol &rest args) From thenriksen at common-lisp.net Thu Jan 3 16:25:16 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 3 Jan 2008 11:25:16 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080103162516.994DC481A3@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv11398/Drei Modified Files: fundamental-syntax.lisp Log Message: Fixed reparsing bug in Fundamental syntax. Because chunk offsets were absolute, and not relative to the line start mark, line information became out of date when changes were made to previous lines. --- /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2008/01/03 12:32:08 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2008/01/03 16:25:16 1.10 @@ -59,37 +59,50 @@ (%chunks :accessor chunks :initform (make-array 5 :adjustable t - :fill-pointer 0)))) + :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."))) (defun line-end-offset (line) "Return the end buffer offset of `line'." (+ (offset (start-mark line)) (line-length line))) -(defun get-chunk (buffer chunk-start-offset line-end-offset) +(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 nil)) + (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 nil)) + (cons (- chunk-end-offset + line-start-offset) nil)) ((not (characterp (buffer-object buffer chunk-end-offset))) - (cons (1+ chunk-end-offset) t))))) + (cons (- (1+ chunk-end-offset) + line-start-offset) t))))) (defmethod initialize-instance :after ((line line-object) &rest initargs) (declare (ignore initargs)) (loop with buffer = (buffer (start-mark line)) - with chunk-start-offset = (offset (start-mark line)) - with line-end-offset = (end-of-line-offset buffer (offset (start-mark line))) - for chunk-info = (get-chunk (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)) + (setf chunk-start-offset (+ (car chunk-info) + line-start-offset)) when (= chunk-start-offset line-end-offset) do (loop-finish))) @@ -168,11 +181,13 @@ (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, or a function, in which case it is -the drawing function for a single-object non-character chunk." - (destructuring-bind (chunk-end-offset . objectp) +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) chunk-end-offset))) + (if objectp (object-drawer) (+ relative-chunk-end-offset + (offset (start-mark line)))))) (defmethod stroke-pump-with-syntax ((view textual-drei-syntax-view) (syntax fundamental-syntax) stroke From thenriksen at common-lisp.net Thu Jan 3 17:52:34 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 3 Jan 2008 12:52:34 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080103175234.0AB455B0A1@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv1996/Drei Modified Files: drei-redisplay.lisp Log Message: Fixed Drei's usage of non-Freetype fonts. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/02 14:43:40 1.17 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/03 17:52:31 1.18 @@ -139,11 +139,15 @@ (defstruct (dimensions :conc-name) "A simple mutable rectangle structure. The coordinates should -be absolute coordinates in the coordinate system of a sheet." +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." (x1 0) (y1 0) (x2 0) - (y2 0)) + (y2 0) + (center 0)) (defun dimensions-height (dimensions) "Return the width of the provided `dimensions' object." @@ -377,7 +381,8 @@ (incf (line-stroke-count line)) (setf (line-end-offset line) (stroke-end-offset stroke))))) -(defun record-stroke (stroke x1 y1 x2 y2) +(defun record-stroke (stroke x1 y1 x2 y2 + &optional (center (/ (- y2 y1) 2))) "Record the fact that `stroke' has been drawn, and that it covers the specified area on screen. Updates the dirty- and modified-bits of `stroke' as well as the dimensions." @@ -387,7 +392,8 @@ (x1 dimensions) x1 (y1 dimensions) y1 (x2 dimensions) x2 - (y2 dimensions) y2))) + (y2 dimensions) y2 + (center dimensions) center))) (defun stroke-drawing-fn (stream view stroke cursor-x cursor-y) "Draw `stroke' to `stream' at the position (`cursor-x', @@ -403,26 +409,31 @@ (drawing-options stroke-drawing-options)) stroke (let* ((stroke-string (in-place-buffer-substring (buffer view) (cache-string view) - start-offset end-offset))) - (with-accessors ((x1 x1) (y1 y1) (x2 x2) (y2 y2)) dimensions - (multiple-value-bind (width height) (if (stroke-modified stroke) - (text-size stream stroke-string - :text-style (merge-text-styles - (face-style (drawing-options-face drawing-options)) - (medium-merged-text-style (sheet-medium stream)))) - (values (- x2 x1) (- y2 y1))) + start-offset end-offset)) + (merged-text-style (merge-text-styles + (face-style (drawing-options-face drawing-options)) + (medium-merged-text-style (sheet-medium stream)))) + (text-style-ascent (text-style-ascent merged-text-style (sheet-medium stream))) + (text-style-descent (text-style-descent merged-text-style (sheet-medium stream))) + (text-style-height (+ text-style-ascent text-style-descent))) + (with-accessors ((x1 x1) (y1 y1) (x2 x2) (y2 y2) (center center)) dimensions + (multiple-value-bind (width ignore1 ignore2 ignore3 baseline) + (if (stroke-modified stroke) + (text-size stream stroke-string + :text-style merged-text-style) + (values (- x2 x1) (- y2 y1) nil nil center)) + (declare (ignore ignore1 ignore2 ignore3)) (clear-rectangle* stream cursor-x cursor-y - (+ cursor-x width) (+ cursor-y height - (stream-vertical-spacing stream))) - (draw-text* stream stroke-string cursor-x cursor-y - :text-style (face-style (drawing-options-face drawing-options)) + (+ cursor-x width) (+ cursor-y text-style-height)) + (draw-text* stream stroke-string cursor-x (+ cursor-y + (- text-style-ascent + baseline)) + :text-style merged-text-style :ink (face-ink (drawing-options-face drawing-options)) :align-y :top) - (record-stroke stroke cursor-x cursor-y (+ width cursor-x) - (+ (if (zerop height) - (text-style-height (medium-text-style stream) stream) - height) - cursor-y))))))) + (record-stroke stroke cursor-x cursor-y + (+ width cursor-x) (+ text-style-height cursor-y) + baseline)))))) (defun draw-stroke (stream view stroke cursor-x cursor-y line-height) "Draw `stroke' on `stream' at (`cursor-x', `cursor-y'). Nothing @@ -618,7 +629,7 @@ (draw-line-strokes pane view pump-state start-offset cursor-x cursor-y) (setf pump-state new-pump-state start-offset (1+ (line-end-offset line))) - (incf cursor-y line-height)) + (incf cursor-y (+ line-height (stream-vertical-spacing pane)))) when (or (>= (y2 (line-dimensions line)) pane-height) (= (line-end-offset line) (size (buffer view)))) return (progn From thenriksen at common-lisp.net Thu Jan 3 18:09:27 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 3 Jan 2008 13:09:27 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080103180927.3548D6A174@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv7326/Drei Modified Files: drei-redisplay.lisp views.lisp Log Message: Invalidate strokes when changing syntax, clear up to line-vertical-spacing. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/03 17:52:31 1.18 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/03 18:09:27 1.19 @@ -424,7 +424,8 @@ (values (- x2 x1) (- y2 y1) nil nil center)) (declare (ignore ignore1 ignore2 ignore3)) (clear-rectangle* stream cursor-x cursor-y - (+ cursor-x width) (+ cursor-y text-style-height)) + (+ cursor-x width) (+ cursor-y text-style-height + (stream-vertical-spacing stream))) (draw-text* stream stroke-string cursor-x (+ cursor-y (- text-style-ascent baseline)) @@ -482,7 +483,8 @@ (when (> line-height (dimensions-height stroke-dimensions)) (clear-rectangle* stream stroke-x1 stroke-y2 stroke-x2 (+ stroke-y2 (- line-height - (dimensions-height stroke-dimensions)))))))) + (dimensions-height stroke-dimensions)) + (stream-vertical-spacing stream))))))) ;; Reset the dimensions of undisplayed lines. (do-undisplayed-line-strokes (stroke line) (let ((stroke-dimensions (stroke-dimensions stroke))) --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/03 16:21:20 1.11 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/03 18:09:27 1.12 @@ -548,6 +548,9 @@ (defmethod (setf buffer) :after (new-value (view drei-buffer-view)) (invalidate-all-strokes view)) +(defmethod (setf syntax) :after (new-value (view drei-buffer-view)) + (invalidate-all-strokes view :modified t)) + (defmethod cache-string :around ((view drei-buffer-view)) (let ((string (call-next-method))) (setf (fill-pointer string) 0) From thenriksen at common-lisp.net Thu Jan 3 21:11:41 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 3 Jan 2008 16:11:41 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080103211141.460D84084@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv29822/Drei Modified Files: lisp-syntax.lisp lr-syntax.lisp Log Message: Improved support for non-character buffer objects. Now treated properly by Lisp syntax, and hopefully properly displayed by LR syntax code. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/03 12:32:08 1.45 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/03 21:11:40 1.46 @@ -275,6 +275,7 @@ (face))) (defclass error-lexeme (lisp-lexeme) ()) +(defclass literal-object-lexeme (lisp-lexeme literal-object-mixin) ()) (defclass left-parenthesis-lexeme (lisp-lexeme) ()) (defclass simple-vector-start-lexeme (lisp-lexeme) ()) (defclass right-parenthesis-lexeme (lisp-lexeme) ()) @@ -295,6 +296,7 @@ (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) ()) @@ -309,7 +311,7 @@ (defclass bit-vector-form (form-lexeme complete-form-mixin) ()) (defclass number-lexeme (complete-token-lexeme) ()) (defclass token-mixin () ()) -(defclass literal-object-form (form-lexeme complete-form-mixin) ()) +(defclass literal-object-form (form-lexeme complete-form-mixin literal-object-mixin) ()) (defclass complete-token-lexeme (token-mixin form-lexeme complete-form-mixin) ()) (defclass multiple-escape-start-lexeme (lisp-lexeme) ()) (defclass multiple-escape-end-lexeme (lisp-lexeme) ()) @@ -473,7 +475,10 @@ (not (constituentp (object-after scan)))) do (fo)) (make-instance 'word-lexeme)) - (t (fo) (make-instance 'delimiter-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))) @@ -495,7 +500,10 @@ (not (constituentp (object-after scan)))) do (fo)) (make-instance 'word-lexeme)) - (t (fo) (make-instance 'delimiter-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))) @@ -513,7 +521,10 @@ (not (constituentp (object-after scan)))) do (fo)) (make-instance 'word-lexeme)) - (t (fo) (make-instance 'delimiter-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 @@ -1775,7 +1786,8 @@ (error-symbol (:face :ink +red+)) (string-form (:face :ink +rosy-brown+ :style (make-text-style nil :italic nil))) - (comment (:face :ink +maroon+ :style (make-text-style :serif :bold :large)))) + (comment (:face :ink +maroon+ :style (make-text-style :serif :bold :large))) + (literal-object-form (:options :function (object-drawer)))) (defparameter *syntax-highlighting-rules* 'emacs-style-highlighting "The syntax highlighting rules used for highlighting Lisp --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/03 12:32:08 1.7 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/03 21:11:40 1.8 @@ -91,6 +91,10 @@ (preceding-parse-tree :initform nil :reader preceding-parse-tree) (parser-state :initform nil :initarg :parser-state :reader parser-state))) +(defclass literal-object-mixin () () + (:documentation "Mixin for parser symbols representing +literal (non-character) objects in the buffer.")) + (defmethod start-offset ((state parser-symbol)) (let ((mark (start-mark state))) (when mark @@ -517,29 +521,39 @@ drawing-options)) (return-from find-next-stroke-end offset))) - (if (null start-symbol) - ;; This means that all remaining lines are blank. - (finish (line-end-offset line) nil) - (or (do-parse-symbols-forward (symbol offset start-symbol) - (let ((symbol-drawing-options - (get-drawing-options highlighting-rules syntax symbol))) - (cond ((> (start-offset symbol) (line-end-offset line)) - (finish (line-end-offset line) start-symbol)) - ((and (> (start-offset symbol) offset) - (not (drawing-options-equal (or symbol-drawing-options - +default-drawing-options+) - (cdr (first drawing-options))))) - (finish (start-offset symbol) symbol symbol-drawing-options)) - ((and (= (start-offset symbol) offset) - (offset-beginning-of-line-p (buffer syntax) offset) - (and symbol-drawing-options - (not (drawing-options-equal symbol-drawing-options - (cdr (first drawing-options)))))) - (finish (start-offset symbol) symbol symbol-drawing-options))))) - ;; 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 line) nil))))))) + (cond ((null start-symbol) + ;; This means that all remaining lines are blank. + (finish (line-end-offset line) nil)) + ((and (typep start-symbol 'literal-object-mixin) + (= offset (start-offset start-symbol))) + (finish (end-offset start-symbol) start-symbol nil)) + (t + (or (do-parse-symbols-forward (symbol offset start-symbol) + (let ((symbol-drawing-options + (get-drawing-options highlighting-rules syntax symbol))) + (cond ((> (start-offset symbol) (line-end-offset line)) + (finish (line-end-offset line) start-symbol)) + ((and (typep symbol 'literal-object-mixin)) + (finish (start-offset symbol) symbol + (or (get-drawing-options highlighting-rules syntax symbol) + (make-drawing-options :function (object-drawer))))) + ((and (> (start-offset symbol) offset) + (not (drawing-options-equal (or symbol-drawing-options + +default-drawing-options+) + (cdr (first drawing-options)))) + (if (null symbol-drawing-options) + (>= (start-offset symbol) (car (first drawing-options))) + t)) + (finish (start-offset symbol) symbol symbol-drawing-options)) + ((and (= (start-offset symbol) offset) + symbol-drawing-options + (not (drawing-options-equal symbol-drawing-options + (cdr (first drawing-options))))) + (finish (start-offset symbol) symbol symbol-drawing-options))))) + ;; 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 line) nil)))))))) (defmethod stroke-pump-with-syntax ((view textual-drei-syntax-view) (syntax lr-syntax-mixin) stroke From thenriksen at common-lisp.net Fri Jan 4 14:12:48 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 4 Jan 2008 09:12:48 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080104141248.F036B431BF@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv23422/Drei Modified Files: lr-syntax.lisp Log Message: Don't use the drawing options of the stack-top in Drei. This solves a problem where pretty much the entire buffer would be drawn a beautiful shade of bright red when a syntax error occured. I think the Right Thing is to make Lisp syntax a little more intelligent with respect to syntax errors. --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/03 21:11:40 1.8 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/04 14:12:48 1.9 @@ -91,6 +91,10 @@ (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.")) @@ -118,10 +122,6 @@ (defclass lexeme (parser-symbol) ()) -(defmethod print-object ((lexeme lexeme) stream) - (print-unreadable-object (lexeme stream :type t :identity t) - (format stream "~s ~s" (start-offset lexeme) (end-offset lexeme)))) - (defclass nonterminal (parser-symbol) ()) (defmethod initialize-instance :after ((parser-symbol nonterminal) &rest args) @@ -467,8 +467,8 @@ (defun get-drawing-options (highlighting-rules syntax parse-symbol) "Get the drawing options with which `parse-symbol' should be -drawn. If `parse-symbol' is NIL, return NIL." - (when parse-symbol +drawn. If `parse-symbol' or the stack-top of syntax, return NIL." + (when (and parse-symbol (not (eq (stack-top syntax) parse-symbol))) (funcall highlighting-rules syntax parse-symbol))) (defstruct (pump-state @@ -535,7 +535,7 @@ (finish (line-end-offset line) start-symbol)) ((and (typep symbol 'literal-object-mixin)) (finish (start-offset symbol) symbol - (or (get-drawing-options highlighting-rules syntax symbol) + (or symbol-drawing-options (make-drawing-options :function (object-drawer))))) ((and (> (start-offset symbol) offset) (not (drawing-options-equal (or symbol-drawing-options From thenriksen at common-lisp.net Fri Jan 4 21:11:41 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 4 Jan 2008 16:11:41 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080104211141.089BC431BE@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv20648/Drei Modified Files: lisp-syntax.lisp packages.lisp Log Message: Modified Lisp syntax to always convert complete-token-lexemes to complete-token-forms. Used this to implement nifty new highlighting rules for Lisp syntax. Also implemented alternative syntax highlighting rules, (setf drei-lisp-syntax:*syntax-highlighting-rules* 'drei-lisp-syntax:retro-highlighting) to enable it. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/03 21:11:40 1.46 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/04 21:11:36 1.47 @@ -309,10 +309,10 @@ (defclass pathname-start-lexeme (lisp-lexeme) ()) (defclass undefined-reader-macro-lexeme (lisp-lexeme) ()) (defclass bit-vector-form (form-lexeme complete-form-mixin) ()) -(defclass number-lexeme (complete-token-lexeme) ()) (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 form-lexeme complete-form-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) ()) @@ -845,16 +845,25 @@ ;;; parse trees (defclass token-form (form token-mixin) ()) -(defclass complete-token-form (token-form complete-form-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)) @@ -1778,16 +1787,71 @@ ;;; ;;; display -;; Note that we do not colour keyword symbols or special forms yet, -;; that is because the only efficient way to do so is to mark them as -;; interesting in the parser itself, it is too slow to check for it in -;; highlighting rules. -(make-syntax-highlighting-rules emacs-style-highlighting - (error-symbol (:face :ink +red+)) - (string-form (:face :ink +rosy-brown+ - :style (make-text-style nil :italic nil))) - (comment (:face :ink +maroon+ :style (make-text-style :serif :bold :large))) - (literal-object-form (:options :function (object-drawer)))) +(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*) + (setf (keyword-symbol-p symbol-form) (eq package +keyword-package+) + (macroboundp 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)))) + +(let ((keyword-drawing-options (make-drawing-options :face (make-face :ink +orchid+))) + (macro-drawing-options (make-drawing-options :face (make-face :ink +purple+))) + (bound-drawing-options (make-drawing-options :face (make-face :ink +darkgoldenrod+)))) + (make-syntax-highlighting-rules emacs-style-highlighting + (error-symbol (:face :ink +red+)) + (string-form (:face :ink +rosy-brown+ + :style (make-text-style nil :italic nil))) + (comment (:face :ink +maroon+ :style (make-text-style :serif :bold :large))) + (literal-object-form (:options :function (object-drawer))) + (complete-token-form (:function #'(lambda (syntax form) + (cond ((symbol-form-is-keyword-p syntax form) + keyword-drawing-options) + ((symbol-form-is-macrobound-p syntax form) + macro-drawing-options) + ((symbol-form-is-boundp syntax form) + bound-drawing-options) + (t +default-drawing-options+))))))) + +(let ((macro-drawing-options (make-drawing-options :face (make-face :style (make-text-style nil :bold nil))))) + (make-syntax-highlighting-rules retro-highlighting + (error-symbol (:face :ink +red+)) + (string-form (:face :style (make-text-style nil :italic nil))) + (comment (:face :style (make-text-style nil nil nil) + :ink +dimgray+)) + (literal-object-form (:options :function (object-drawer))) + (complete-token-form (:function #'(lambda (syntax form) + (cond ((symbol-form-is-macrobound-p syntax form) + macro-drawing-options) + (t +default-drawing-options+))))))) (defparameter *syntax-highlighting-rules* 'emacs-style-highlighting "The syntax highlighting rules used for highlighting Lisp @@ -2798,16 +2862,6 @@ ;;; The atom(-ish) forms. -(defmethod form-to-object ((syntax lisp-syntax) (form complete-token-lexeme) - &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)) - (intern (symbol-name symbol) package)) - (t symbol))))) - (defmethod form-to-object ((syntax lisp-syntax) (form complete-token-form) &key read (case (readtable-case *readtable*)) &allow-other-keys) --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/03 12:32:08 1.30 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/04 21:11:39 1.31 @@ -608,7 +608,12 @@ ;; Conditions. #:form-conversion-error - #:invalid-lambda-list) + #: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.")) From thenriksen at common-lisp.net Fri Jan 4 21:55:46 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 4 Jan 2008 16:55:46 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080104215546.394125B074@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv31757/Drei Modified Files: lisp-syntax.lisp Log Message: Restored the Red Menace to syntax errors. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/04 21:11:36 1.47 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/04 21:55:45 1.48 @@ -1827,7 +1827,7 @@ (macro-drawing-options (make-drawing-options :face (make-face :ink +purple+))) (bound-drawing-options (make-drawing-options :face (make-face :ink +darkgoldenrod+)))) (make-syntax-highlighting-rules emacs-style-highlighting - (error-symbol (:face :ink +red+)) + (error-lexeme (:face :ink +red+)) (string-form (:face :ink +rosy-brown+ :style (make-text-style nil :italic nil))) (comment (:face :ink +maroon+ :style (make-text-style :serif :bold :large))) From thenriksen at common-lisp.net Fri Jan 4 21:56:29 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 4 Jan 2008 16:56:29 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20080104215629.A036243218@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv32029/ESA Modified Files: esa-command-parser.lisp Log Message: Restored evaluating of arguments to ESA commands. --- /project/mcclim/cvsroot/mcclim/ESA/esa-command-parser.lisp 2007/12/27 20:31:56 1.3 +++ /project/mcclim/cvsroot/mcclim/ESA/esa-command-parser.lisp 2008/01/04 21:56:29 1.4 @@ -123,6 +123,6 @@ (esa-parse-one-arg stream name ptype args)) ((eq command-arg *numeric-argument-marker*) (or numeric-argument (getf args :default))) - (t command-arg)) + (t (eval command-arg))) result) (maybe-clear-input))))))))))) From thenriksen at common-lisp.net Sat Jan 5 09:13:56 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 5 Jan 2008 04:13:56 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080105091356.6DC544B083@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv14671/Drei Modified Files: lisp-syntax.lisp Log Message: No longer store ink and face settings for Lisp lexemes. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/04 21:55:45 1.48 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/05 09:13:56 1.49 @@ -270,9 +270,7 @@ (defclass comment (lisp-nonterminal) ()) -(defclass lisp-lexeme (lexeme) - ((ink) - (face))) +(defclass lisp-lexeme (lexeme) ()) (defclass error-lexeme (lisp-lexeme) ()) (defclass literal-object-lexeme (lisp-lexeme literal-object-mixin) ()) From thenriksen at common-lisp.net Sat Jan 5 09:17:37 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 5 Jan 2008 04:17:37 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080105091737.738CD4B083@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv15426/Drei Modified Files: packages.lisp Log Message: I must have broken support for literal objects in buffers along the way, unbroke it now. --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/04 21:11:39 1.31 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/05 09:17:37 1.32 @@ -500,6 +500,7 @@ #: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 From thenriksen at common-lisp.net Sat Jan 5 11:55:18 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 5 Jan 2008 06:55:18 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080105115518.641AB3C08C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv22760/Drei Modified Files: lisp-syntax.lisp Log Message: Handle non-character objects in the buffer even when the syntax is erroneous. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/05 09:13:56 1.49 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/05 11:55:18 1.50 @@ -274,6 +274,7 @@ (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 left-parenthesis-lexeme (lisp-lexeme) ()) (defclass simple-vector-start-lexeme (lisp-lexeme) ()) (defclass right-parenthesis-lexeme (lisp-lexeme) ()) @@ -619,9 +620,13 @@ (defmethod lex ((syntax lisp-syntax) (state lexer-error-state) scan) (macrolet ((fo () `(forward-object scan))) - (loop until (end-of-line-p scan) - do (fo)) - (make-instance 'error-lexeme))) + (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))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From thenriksen at common-lisp.net Sat Jan 5 12:20:34 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 5 Jan 2008 07:20:34 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Inspector Message-ID: <20080105122034.49FE27C04E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory clnet:/tmp/cvs-serv31123/Apps/Inspector Modified Files: inspector.lisp Log Message: Use :single-box t to highlight presentations in Clouseau. Much prettier. --- /project/mcclim/cvsroot/mcclim/Apps/Inspector/inspector.lisp 2008/01/01 23:23:07 1.40 +++ /project/mcclim/cvsroot/mcclim/Apps/Inspector/inspector.lisp 2008/01/05 12:20:34 1.41 @@ -166,7 +166,8 @@ (,evaluated-object ,object)) (with-output-as-presentation (pane ,evaluated-object - (presentation-type-of ,evaluated-object)) + (presentation-type-of ,evaluated-object) + :single-box t) (formatting-table (,evaluated-pane) (formatting-column (,evaluated-pane) (formatting-cell (,evaluated-pane) From thenriksen at common-lisp.net Sat Jan 5 14:23:16 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 5 Jan 2008 09:23:16 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080105142316.A81F64B05F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv8577/Drei Modified Files: lisp-syntax.lisp Log Message: Handle more noncharacters in the Lisp lexer. Fix dumb bug in `find-list-parent'. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/05 11:55:18 1.50 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/05 14:23:16 1.51 @@ -354,99 +354,103 @@ (t (let ((prefix 0)) (loop until (end-of-buffer-p scan) - while (digit-char-p (object-after 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 (end-of-buffer-p scan) - (make-instance 'incomplete-lexeme) - (case (object-after scan) - ((#\Backspace #\Tab #\Newline #\Linefeed - #\Page #\Return #\Space #\)) - (fo) - (make-instance 'error-lexeme)) - (#\\ (fo) - (cond ((end-of-buffer-p 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) + (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 (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 (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)))))))) + (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 #\\)) @@ -1975,7 +1979,7 @@ (typecase parent (list-form parent) ((or form* null) nil) - (t (find-list-parent-offset parent))))) + (t (find-list-parent parent))))) (defun find-list-parent-offset (form fn) "Find a list parent of `form' and return `fn' applied to this From thenriksen at common-lisp.net Sat Jan 5 20:08:32 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 5 Jan 2008 15:08:32 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/Tests Message-ID: <20080105200832.D39C9111E2@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv6678/Drei/Tests Modified Files: editing-tests.lisp Log Message: Fixed some word-motion and word-transposition bugs. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/editing-tests.lisp 2007/12/08 08:53:49 1.4 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/editing-tests.lisp 2008/01/05 20:08:32 1.5 @@ -365,7 +365,8 @@ (transposition-test word ("words Many, great words!") ("") - ((8 "Many great, words words!")) + ((8 "Many great, words words!") + (10 "Many great, words words!")) "Many words, great words!") (transposition-test page From thenriksen at common-lisp.net Sat Jan 5 20:08:33 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 5 Jan 2008 15:08:33 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080105200833.269CE111E2@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv6678/Drei Modified Files: base.lisp editing.lisp motion.lisp packages.lisp Log Message: Fixed some word-motion and word-transposition bugs. --- /project/mcclim/cvsroot/mcclim/Drei/base.lisp 2008/01/02 14:43:40 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/base.lisp 2008/01/05 20:08:32 1.10 @@ -431,6 +431,12 @@ 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 --- /project/mcclim/cvsroot/mcclim/Drei/editing.lisp 2007/12/21 14:22:07 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/editing.lisp 2008/01/05 20:08:32 1.10 @@ -176,42 +176,50 @@ ,(concat "Transpose two " plural " at MARK."))) (defmethod ,transpose ((mark right-sticky-mark) syntax) - (let (start1 end1 start2 end2) - (,backward mark syntax 1 nil) - (setf start1 (clone-mark mark)) - (,forward mark syntax 1 #'error-limit-action) - (setf end1 (clone-mark mark)) - (,forward mark syntax 1 #'error-limit-action) - (setf end2 (clone-mark mark)) - (,backward mark syntax 1 nil) - (setf start2 (clone-mark mark)) - (let ((obj1 (buffer-sequence (buffer mark) (offset start1) (offset end1))) - (obj2 (buffer-sequence (buffer mark) (offset start2) (offset end2)))) - (,forward-delete mark syntax 1 nil) - (insert-sequence mark obj1) - (,backward mark syntax 2 nil) - (,forward-delete mark syntax 1 nil) - (insert-sequence mark obj2) - (,forward mark syntax 1 nil)))) + (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 end1 start2 end2) - (,backward mark syntax 1 nil) - (setf start1 (clone-mark mark)) - (,forward mark syntax 1 #'error-limit-action) - (setf end1 (clone-mark mark)) - (,forward mark syntax 1 #'error-limit-action) - (setf end2 (clone-mark mark)) - (,backward mark syntax 1 nil) - (setf start2 (clone-mark mark)) - (let ((obj1 (buffer-sequence (buffer mark) (offset start1) (offset end1))) - (obj2 (buffer-sequence (buffer mark) (offset start2) (offset end2)))) - (,forward-delete mark syntax 1 nil) - (insert-sequence mark obj1) - (,forward mark syntax 1 nil) - (,backward mark syntax 2 nil) - (,forward-delete mark syntax 1 nil) - (insert-sequence mark obj2)))))))) + (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))))))))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/motion.lisp 2007/08/20 19:44:44 1.5 +++ /project/mcclim/cvsroot/mcclim/Drei/motion.lisp 2008/01/05 20:08:32 1.6 @@ -267,24 +267,24 @@ Return T if successful, or NIL if the buffer limit was reached.")) (defmethod forward-one-word (mark syntax) - (forward-to-word-boundary mark syntax) - (and (not (end-of-buffer-p mark)) - (loop until (end-of-buffer-p mark) - while (word-constituentp syntax (object-after mark)) - do (forward-object mark) - finally (return t)))) + (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) - (backward-to-word-boundary mark syntax) - (and (not (beginning-of-buffer-p mark)) - (loop until (beginning-of-buffer-p mark) - while (word-constituentp syntax (object-before mark)) - do (backward-object mark) - finally (return t)))) + (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) --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/05 09:17:37 1.32 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/05 20:08:32 1.33 @@ -111,6 +111,7 @@ #: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 From thenriksen at common-lisp.net Sat Jan 5 21:07:16 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 5 Jan 2008 16:07:16 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/Tests Message-ID: <20080105210716.A2EF62D162@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv23302/Drei/Tests Modified Files: lisp-syntax-tests.lisp motion-tests.lisp Log Message: Made Backward Expression behave more like Emacs. Also added a currently-failing test case for Forward Expression, I couldn't figure out a simple way to handle the situation, and I fear special-casing will be necessary. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2007/12/20 10:33:35 1.10 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2008/01/05 21:07:16 1.11 @@ -823,7 +823,11 @@ (motion-fun-one-test (expression lisp-syntax) (51 0 (11 28 7) "(defun list (&rest elements) -(append elements nil))")) +(append elements nil))") + (nil nil (5 18 9) + "#+nil (list 1 2 3)") + (nil nil (0 5 nil) + "#+nil (list 1 2 3)")) (motion-fun-one-test (list lisp-syntax) (64 4 (22 41 11) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/motion-tests.lisp 2007/12/20 10:33:35 1.7 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/motion-tests.lisp 2008/01/05 21:07:16 1.8 @@ -105,8 +105,8 @@ (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 integer) - (check-type goal-backward-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)) @@ -117,7 +117,8 @@ (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 backward-end-offset '(m0r)) + ,@(unless goal-forward-offset '(m0r m1l)))) ,(when forward-begin-offset `(progn (is-true (,forward m0l syntax)) @@ -126,10 +127,14 @@ `(progn (is-true (,forward m0r syntax)) (is (= ,forward-begin-offset (offset m0r))))) - (is-true (,forward m1l syntax)) - (is (= ,goal-forward-offset (offset m1l))) - (is-true (,forward m1r syntax)) - (is (= ,goal-forward-offset (offset m1r))) + ,(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)) @@ -152,15 +157,20 @@ (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)))) + (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))) - (is-true (,backward m1l syntax)) - (is (= ,goal-backward-offset (offset m1l))) - (is-true (,backward m1r syntax)) - (is (= ,goal-backward-offset (offset m1r))) + ,(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)) From thenriksen at common-lisp.net Sat Jan 5 21:07:16 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 5 Jan 2008 16:07:16 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080105210716.E50E532052@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv23302/Drei Modified Files: lisp-syntax.lisp Log Message: Made Backward Expression behave more like Emacs. Also added a currently-failing test case for Forward Expression, I couldn't figure out a simple way to handle the situation, and I fear special-casing will be necessary. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/05 14:23:16 1.51 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/05 21:07:16 1.52 @@ -2012,9 +2012,13 @@ (update-parse syntax 0 (offset mark)) (let ((potential-form (or (form-before syntax (offset mark)) (form-around syntax (offset mark))))) - (when (and (not (null potential-form)) - (not (= (offset mark) (start-offset potential-form)))) - (setf (offset mark) (start-offset potential-form))))) + (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)) @@ -2022,7 +2026,7 @@ (form-around syntax (offset mark))))) (when (and (not (null potential-form)) (not (= (offset mark) (end-offset potential-form)))) - (setf (offset mark) (end-offset potential-form))))) + (setf (offset mark) (end-offset potential-form))))) (defmethod forward-delete-expression (mark (syntax lisp-syntax) &optional (count 1) (limit-action #'error-limit-action)) From ahefner at common-lisp.net Sat Jan 5 22:58:57 2008 From: ahefner at common-lisp.net (ahefner) Date: Sat, 5 Jan 2008 17:58:57 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Experimental/freetype Message-ID: <20080105225857.47EA42D1A1@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv21988 Modified Files: freetype-fonts.lisp Log Message: Make go fast. --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2006/03/10 10:56:01 1.12 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/05 22:58:57 1.13 @@ -24,7 +24,7 @@ (in-package :MCCLIM-FREETYPE) -(declaim (optimize (speed 3) (safety 3) (debug 1) (space 3))) +(declaim (optimize (speed 1) (safety 3) (debug 1) (space 0))) ;;;; Notes @@ -35,6 +35,9 @@ ((lib :initarg :lib) (filename :initarg :filename))) +;;; I can't say I understand this vague vs. concrete font distinction, +;;; but I'll leave it around. -Hefner + (defparameter *vague-font-hash* (make-hash-table :test #'equal)) (defun make-vague-font (filename) @@ -52,6 +55,10 @@ (defparameter *concrete-font-hash* (make-hash-table :test #'equal)) +;;; One "concrete font" is shared for a given face, regardless of text size, +;;; presumably to conserve resources. Therefore, we must configure it for +;;; the correct text size with set-concrete-font-size before using it. + (defun make-concrete-font (vague-font size &key (dpi *dpi*)) (with-slots (lib filename) vague-font (let* ((key (cons lib filename)) @@ -63,12 +70,12 @@ (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)) - (freetype:set-char-size face 0 (round (* size 64)) (round dpi) (round dpi)) - face)))) + val))) -(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 (face char) (declare (optimize (speed 3) (debug 1)) @@ -100,26 +107,19 @@ (/ (slot (slot glyph 'freetype:advance) 'freetype:x) 64) (/ (slot (slot glyph 'freetype:advance) 'freetype:y) 64))))) -(defun glyph-advance (face char) - (freetype:load-glyph face (freetype:get-char-index face (char-code char)) 0) - (let* ((glyph (slot face 'freetype:glyph))) - (values - (/ (slot (slot glyph 'freetype:advance) 'freetype:x) 64) - (/ (slot (slot glyph 'freetype:advance) 'freetype:y) 64)))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun display-glyph-cache (display) - (or (getf (xlib:display-plist display) 'glyph-cache) - (setf (getf (xlib:display-plist display) 'glyph-cache) - (make-hash-table :test #'equalp)))) - -(defun display-the-glyph-set (display) - (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)))))) +(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)) @@ -137,23 +137,36 @@ (or (pop (display-free-glyph-ids display)) (incf (display-free-glyph-id-counter display)))) -(defun display-get-glyph (display font matrix glyph-index) - (or (gethash (list font matrix glyph-index) (display-glyph-cache display)) - (setf (gethash (list font matrix glyph-index) (display-glyph-cache display)) - (display-generate-glyph display font matrix glyph-index)))) - (defvar *font-hash* (make-hash-table :test #'equalp)) -(defun display-generate-glyph (display font matrix glyph-index) - (let* ((glyph-id (display-draw-glyph-id display)) - (font (or (gethash font *font-hash*) - (setf (gethash font *font-hash*) - (make-vague-font font)))) - (face (make-concrete-font font matrix))) +(defstruct (glyph-info (:constructor glyph-info (id width height left right top))) + id ; FIXME: Types? + width height + left right top) + +(defun font-generate-glyph (font glyph-index) + (let* ((display (freetype-face-display font)) + (glyph-id (display-draw-glyph-id display)) + (face (freetype-face-concrete-font font))) + (set-concrete-font-size face (freetype-face-matrix font) *dpi*) (multiple-value-bind (arr left top dx dy) (glyph-pixarray face (code-char glyph-index)) + (with-slots (fixed-width) font + (when (and (numberp fixed-width) + (/= fixed-width dx)) + (setf fixed-width t) + (warn "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)) + (unless (or fixed-width + (zerop (logand (slot face 'freetype:face-flags) + 4))) ; FT_FACE_FLAG_FIXED_WIDTH + (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))) + (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) @@ -161,51 +174,108 @@ :x-advance dx :y-advance dy) (let ((right (+ left (array-dimension arr 1)))) - (list glyph-id dx dy left right top))))) + (glyph-info glyph-id dx dy left right top))))) ;;;;;;; mcclim interface (defclass freetype-face () - ((display :initarg :display) - (font :initarg :font) - (matrix :initarg :matrix) - (ascent :initarg :ascent) - (descent :initarg :descent))) + ((display :initarg :display :reader freetype-face-display) + (font :initarg :font :reader freetype-face-name) + (matrix :initarg :matrix :reader freetype-face-matrix) + (ascent :initarg :ascent :reader freetype-face-ascent) + (descent :initarg :descent :reader freetype-face-descent) + (concrete-font :initarg :concrete-font :reader freetype-face-concrete-font) + (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)))) + +(defmethod print-object ((object freetype-face) stream) + (print-unreadable-object (object stream :type t :identity nil) + (with-slots (font matrix ascent descent) object + (format stream "~A size=~A ~A/~A" font matrix 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 freetype-face)) - (with-slots (ascent) font - ascent)) + (freetype-face-ascent font)) (defmethod clim-clx::font-descent ((font freetype-face)) - (with-slots (descent) font - descent)) + (freetype-face-descent font)) (defmethod clim-clx::font-glyph-width ((font freetype-face) char) - (with-slots (display font matrix) font - (nth 1 (display-get-glyph display font matrix char)))) + (glyph-info-width (font-glyph-info font char))) + (defmethod clim-clx::font-glyph-left ((font freetype-face) char) - (with-slots (display font matrix) font - (nth 3 (display-get-glyph display font matrix char)))) + (glyph-info-left (font-glyph-info font char))) + (defmethod clim-clx::font-glyph-right ((font freetype-face) char) - (with-slots (display font matrix) font - (nth 4 (display-get-glyph display font matrix char)))) + (glyph-info-right (font-glyph-info font char))) + + +(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))) ; best hash function ever. + (and (= key-number (the fixnum (svref cache hash))) ; I <3 fixnums + (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))) ;;; this is a hacky copy of XLIB:TEXT-EXTENTS (defmethod clim-clx::font-text-extents ((font freetype-face) string &key (start 0) (end (length string)) translate) ;; -> (width ascent descent left right ;; font-ascent font-descent direction - ;; first-not-done) - translate - (let ((width (loop for i from start below end - sum (clim-clx::font-glyph-width font (char-code (aref string i)))))) + ;; first-not-done) + (declare (optimize (speed 3))) + translate ; ??? + (let ((width + ;; We could work a little harder and maybe get the generic arithmetic + ;; out of here, but I doubt it would shave more than a few percent + ;; off a draw-text benchmark. + (macrolet ((compute () + `(loop with 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 cache code) + (gcache-set 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) (length string)) + (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-code (char string start))) - (- width (- (clim-clx::font-glyph-width font (char-code (char string (1- end)))) - (clim-clx::font-glyph-right font (char-code (char string (1- end)))))) + (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))) @@ -231,29 +301,45 @@ :repeat :on) pixmap))))) -(defmethod clim-clx::font-draw-glyphs ((font freetype-face) mirror gc x y string &key start end translate) - (let ((display (xlib:drawable-display mirror))) - (with-slots (font matrix) font +(let ((buffer (make-array 1024 :element-type '(unsigned-byte 32) ; TODO: thread safety + :adjustable nil :fill-pointer nil))) + (defmethod clim-clx::font-draw-glyphs ((font freetype-face) mirror gc x y string &key start end translate) + (declare (optimize (speed 3))) + (when (< (length buffer) (- end start)) + (hef:debugf "fuck!") + (setf buffer (make-array (* 256 (ceiling (- end start) 256)) + :element-type '(unsigned-byte 32) + :adjustable nil :fill-pointer nil))) + (let ((display (xlib:drawable-display mirror))) (destructuring-bind (source-picture source-pixmap) (gcontext-picture mirror gc) - (let ((fg (xlib:gcontext-foreground gc))) + (let* ((fg (xlib:gcontext-foreground gc)) + (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*) + (or (gcache-get cache code) + (gcache-set cache code (font-glyph-id font char))))) + (xlib::render-fill-rectangle source-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)) - (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 - (map 'vector (lambda (x) - (first - (display-get-glyph display font matrix (char-code x)))) - (subseq string start end))))))) + 0 0 1 1) + (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))))))) (let ((cache (make-hash-table :test #'equal))) (defun make-free-type-face (display font size) @@ -264,10 +350,12 @@ (make-vague-font font)))) (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 :font font :matrix 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))))))) @@ -297,6 +385,28 @@ ((: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. + +#+NIL +(defparameter *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-Oblique.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"))) + + (defvar *freetype-font-path*) (fmakunbound 'clim-clx::text-style-to-x-font) @@ -317,6 +427,7 @@ ((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) @@ -326,25 +437,31 @@ (defparameter *free-type-face-hash* (make-hash-table :test #'equal)) -(defmethod clim-clx::text-style-to-X-font :around ((port clim-clx::clx-port) (text-style standard-text-style)) - (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 size (or size :normal)) - (cond (size - (setf size (getf *sizes* size size)) - (let ((val (gethash (list display family face size) *free-type-face-hash*))) - (if val val - (setf (gethash (list display family face size) *free-type-face-hash*) - (let* ((font-path-relative (cdr (assoc (list family face) *families/faces* - :test #'equal))) - (font-path (namestring (merge-pathnames font-path-relative *freetype-font-path*)))) - (if (and font-path (probe-file font-path)) [41 lines skipped] From ahefner at common-lisp.net Sat Jan 5 23:04:16 2008 From: ahefner at common-lisp.net (ahefner) Date: Sat, 5 Jan 2008 18:04:16 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Experimental/freetype Message-ID: <20080105230416.B292A5F075@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv25588 Modified Files: freetype-fonts.lisp Log Message: Didn't mean to leave any of those in there. --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/05 22:58:57 1.13 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/05 23:04:15 1.14 @@ -306,7 +306,6 @@ (defmethod clim-clx::font-draw-glyphs ((font freetype-face) mirror gc x y string &key start end translate) (declare (optimize (speed 3))) (when (< (length buffer) (- end start)) - (hef:debugf "fuck!") (setf buffer (make-array (* 256 (ceiling (- end start) 256)) :element-type '(unsigned-byte 32) :adjustable nil :fill-pointer nil))) From ahefner at common-lisp.net Sun Jan 6 01:33:25 2008 From: ahefner at common-lisp.net (ahefner) Date: Sat, 5 Jan 2008 20:33:25 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20080106013325.2E524111D9@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv32761 Modified Files: listener.lisp wholine.lisp Log Message: Aesthetic tweaks for freetype. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2007/12/31 23:34:53 1.37 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2008/01/06 01:33:25 1.38 @@ -153,7 +153,7 @@ (get-frame-pane frame 'interactor)) (defun run-listener (&key (new-process nil) - (width 760) + (width 790) (height 550) port frame-manager --- /project/mcclim/cvsroot/mcclim/Apps/Listener/wholine.lisp 2007/03/04 22:27:51 1.2 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/wholine.lisp 2008/01/06 01:33:25 1.3 @@ -79,13 +79,18 @@ #-(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-freetype) :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 :small)) + (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) From ahefner at common-lisp.net Sun Jan 6 01:37:06 2008 From: ahefner at common-lisp.net (ahefner) Date: Sat, 5 Jan 2008 20:37:06 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20080106013706.91F6B2400A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv601/Backends/CLX Modified Files: medium.lisp Log Message: Eliminate duplicated medium-gcontext method in freetype (it had fallen behind in maintenance, anyway). Reduced or eliminated consing while setting medium clipping region. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2007/07/19 06:55:39 1.82 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2008/01/06 01:37:06 1.83 @@ -37,6 +37,9 @@ (defclass clx-medium (basic-medium) ((gc :initform nil) (picture :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 @@ -100,25 +103,40 @@ ((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))))))) + (defmethod (setf medium-clipping-region) :after (region (medium clx-medium)) (declare (ignore region)) (with-slots (gc) medium - (when gc - (let ((clipping-region (medium-device-region medium))) - (if (region-equal clipping-region +nowhere+) - (setf (xlib:gcontext-clip-mask gc) #()) - (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)))))))) + (when gc (%set-gc-clipping-region medium gc)))) (defgeneric medium-gcontext (medium ink)) @@ -133,6 +151,7 @@ (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))) @@ -151,26 +170,12 @@ (xlib:gcontext-dashes gc) (if (eq dashes t) 3 dashes))))) (setf (xlib:gcontext-function gc) boole-1) - (setf (xlib:gcontext-font gc) (text-style-to-X-font port (medium-text-style medium))) (setf (xlib:gcontext-foreground gc) (X-pixel port ink) (xlib:gcontext-background gc) (X-pixel port (medium-background medium))) - ;; Here is a bug with regard to clipping ... ;-( --GB ) - #-nil ; being fixed at the moment, a bit twitchy though -- BTS - (let ((clipping-region (medium-device-region medium))) - (if (region-equal clipping-region +nowhere+) - (setf (xlib:gcontext-clip-mask gc) #()) - (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))))) + (let ((fn (text-style-to-X-font port (medium-text-style medium)))) + (when (typep fn 'xlib:font) + (setf (xlib:gcontext-font gc) fn))) + (%set-gc-clipping-region medium gc) gc))) (defmethod medium-gcontext ((medium clx-medium) (ink (eql +transparent-ink+))) @@ -569,22 +574,28 @@ (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) - (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)) - nconcing (list clip-x - clip-y - (- (round-coordinate (rectangle-max-x rectangle)) clip-x) - (- (round-coordinate (rectangle-max-y rectangle)) clip-y)))) + (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)) From ahefner at common-lisp.net Sun Jan 6 01:37:06 2008 From: ahefner at common-lisp.net (ahefner) Date: Sat, 5 Jan 2008 20:37:06 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Experimental/freetype Message-ID: <20080106013706.C6FFA25113@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv601/Experimental/freetype Modified Files: freetype-fonts.lisp Log Message: Eliminate duplicated medium-gcontext method in freetype (it had fallen behind in maintenance, anyway). Reduced or eliminated consing while setting medium clipping region. --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/05 23:04:15 1.14 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/06 01:37:06 1.15 @@ -458,9 +458,9 @@ (call-next-method))))))) (t (call-next-method))))))) - (if (eq (car lookaside) text-style) - (cdr lookaside) - (cdr (setf lookaside (cons text-style (f)))))))) + (cdr (if (eq (car lookaside) text-style) + lookaside + (setf lookaside (cons text-style (f)))))))) (defmethod clim-clx::text-style-to-X-font ((port clim-clx::clx-port) text-style) (error "You lost: ~S." text-style)) @@ -569,7 +569,7 @@ (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))) + (let ((fn (text-style-to-X-font port text-style))) (if (typep fn 'xlib:font) (setf (xlib:gcontext-font gc) fn))) (setf @@ -623,48 +623,6 @@ (setf (xlib:gcontext-font gc) fn)))))))) -(defmethod medium-gcontext ((medium clx-medium) (ink color)) - (let* ((port (port medium)) - (mirror (port-lookup-mirror port (medium-sheet medium))) - (line-style (medium-line-style medium))) - (with-slots (gc) 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) (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) - (let ((fn (text-style-to-X-font port (medium-text-style medium)))) - (when (typep fn 'xlib:font) - (setf (xlib:gcontext-font gc) fn))) - (setf (xlib:gcontext-foreground gc) (X-pixel port ink) - (xlib:gcontext-background gc) (X-pixel port (medium-background medium))) - ;; Here is a bug with regard to clipping ... ;-( --GB ) - #-nil ; being fixed at the moment, a bit twitchy though -- BTS - (let ((clipping-region (medium-device-region medium))) - (if (region-equal clipping-region +nowhere+) - (setf (xlib:gcontext-clip-mask gc) #()) - (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))))) - gc))) - ;;; ;;; This fixes the worst offenders making the assumption that drawing ;;; would be idempotent. From thenriksen at common-lisp.net Sun Jan 6 08:36:33 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 6 Jan 2008 03:36:33 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Extensions/Images Message-ID: <20080106083633.5E3571605C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Extensions/Images In directory clnet:/tmp/cvs-serv18154/Extensions/Images Log Message: Directory /project/mcclim/cvsroot/mcclim/Extensions/Images added to the repository From thenriksen at common-lisp.net Sun Jan 6 08:36:57 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 6 Jan 2008 03:36:57 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Extensions/Images Message-ID: <20080106083657.F24851605F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Extensions/Images In directory clnet:/tmp/cvs-serv18285/Extensions/Images Added Files: gif.lisp images.lisp package.lisp xpm.lisp Log Message: Added extension MCCLIM-IMAGES in Extensions/Images. This extension is a simple collection of functions that make it easy to load images and convert them into CLIM designs. Currently, only the GIF and XPM formats are supported. If it turns out that the facilities provided by MCCLIM-IMAGES are useful for non-CLIM applications, it could be generalised into an external library, but due to its simplicity, I doubt the major benefit of this. An example of use: ;; Is there a non-CLIM-INTERNALS way of getting these things drawn? (define-presentation-method present ((pattern climi::pattern) (type climi::pattern) stream (view drei-view) &key acceptably for-context-type) (declare (ignore acceptably for-context-type)) (multiple-value-bind (x y) (stream-cursor-position stream) (draw-pattern* stream pattern x y) (stream-increment-cursor-position stream (+ (pattern-width pattern)) 0))) (asdf:operate 'asdf:load-op :mcclim-images) (asdf:operate 'asdf:load-op :mcclim-images-gif) (asdf:operate 'asdf:load-op :mcclim-images-xpm) (define-command (com-insert-image :name t :command-table climacs-gui::development-table) ((image-pathname 'pathname :default (merge-pathnames (user-homedir-pathname)) :insert-default t)) (if (probe-file image-pathname) (handler-case (insert-object (point) (mcclim-images:load-image image-pathname)) (mcclim-images:unsupported-image-format (c) (display-message "Image format ~A not recognized" (mcclim-images:image-format c)))) (display-message "No such file: ~A" image-pathname))) --- /project/mcclim/cvsroot/mcclim/Extensions/Images/gif.lisp 2008/01/06 08:36:57 NONE +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/gif.lisp 2008/01/06 08:36:57 1.1 ;;; -*- Mode: Lisp; Package: MCCLIM-IMAGES -*- ;;; (c) copyright 2008 by ;;; Troels Henriksen (athas at 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 :mcclim-images) (define-image-reader "gif" (image-pathname &key) (let* ((data-stream (skippy:load-data-stream image-pathname)) (first-image (aref (skippy:images data-stream) 0)) (pattern-array (make-array (list (skippy:height first-image) (skippy:width first-image)))) (designs (coerce (loop with color-table = (skippy:color-table data-stream) for i below 255 collecting (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 (array-dimension pattern-array 0)) (dotimes (x (array-dimension pattern-array 1)) (setf (aref pattern-array y x) (skippy:pixel-ref first-image x y)))) (make-pattern pattern-array designs))) --- /project/mcclim/cvsroot/mcclim/Extensions/Images/images.lisp 2008/01/06 08:36:57 NONE +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/images.lisp 2008/01/06 08:36:57 1.1 ;;; -*- Mode: Lisp; Package: MCCLIM-IMAGES -*- ;;; (c) copyright 2008 by ;;; Troels Henriksen (athas at 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 :mcclim-images) (defvar *image-readers* (make-hash-table :test 'equalp) "A hash table mapping lowercase image format names to a function that can read an image of that format. The functions will be called with at least one argument, the pathname of the file to be read, and any keyword arguments provided by the user.") (defun image-format-supported (format) "Return true if `format' is supported by `load-image'." (not (null (gethash format *image-readers*)))) (define-condition unsupported-image-format (error) ((%format :reader image-format :initarg :image-format :initform (error "The image format must be supplied") :documentation "The image format that cannot be loaded")) (:report (lambda (condition stream) (format stream "Cannot read image of unknown format \"~A\"" (image-format condition)))) (:documentation "This exception is signalled when `load-image-of-type' is called on an image of a type that no reader has been defined for.")) (defun unsupported-image-format (format) "Signal an error of type `unsupprted-image-format' for the image format `format'." (error 'unsupported-image-format :image-format format)) (defun load-image (image-pathname &rest args &key) "Load an image from `image-pathname', with the format of the image being the pathname-type of `image-pathname'. `Args' can be any keyword-arguments, they will be passed on to the image reader function for the relevant image format. If the image format is not recognised, an error of type `unsupprted-image-format' will be signalled." (apply #'load-image-of-format (pathname-type image-pathname) image-pathname args)) (defun load-image-of-format (format image-pathname &rest args &key) "Load an image of format `format' from `image-pathname'. `Args' can be any keyword-arguments, they will be passed on to the image reader function for `format'. If the image format is not recognised, an error of type `unsupprted-image-format' will be signalled." (apply (or (gethash format *image-readers*) (unsupported-image-format format)) image-pathname args)) (defmacro define-image-reader (image-format (&rest args) &body body) `(setf (gethash ,image-format *image-readers*) #'(lambda (, at args) , at body))) --- /project/mcclim/cvsroot/mcclim/Extensions/Images/package.lisp 2008/01/06 08:36:57 NONE +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/package.lisp 2008/01/06 08:36:57 1.1 ;;; -*- Mode: Lisp; Package: CL-USER -*- ;;; (c) copyright 2008 by ;;; Troels Henriksen (athas at 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 :cl-user) (defpackage :mcclim-images (:use :clim-lisp :clim) (:export :export #:image-format-supported #:load-image #:load-image-of-format #:unsupported-image-format #:image-format)) --- /project/mcclim/cvsroot/mcclim/Extensions/Images/xpm.lisp 2008/01/06 08:36:57 NONE +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/xpm.lisp 2008/01/06 08:36:57 1.1 ;;; -*- Mode: Lisp; Package: MCCLIM-IMAGES -*- ;;; (c) copyright 2003 by ;;; Gilbert Baumann (unk6 at rz.uni-karlsruhe.de) ;;; (c) copyright 2006 by ;;; Andy Hefner (ahefner at gmail.com) ;;; (c) copyright 2008 by ;;; Troels Henriksen (athas at 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 :mcclim-images) ;;;; 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 , at 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))) [951 lines skipped] From thenriksen at common-lisp.net Sun Jan 6 08:36:58 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 6 Jan 2008 03:36:58 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080106083658.2EBAF1A0A2@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv18285 Modified Files: mcclim.asd Log Message: Added extension MCCLIM-IMAGES in Extensions/Images. This extension is a simple collection of functions that make it easy to load images and convert them into CLIM designs. Currently, only the GIF and XPM formats are supported. If it turns out that the facilities provided by MCCLIM-IMAGES are useful for non-CLIM applications, it could be generalised into an external library, but due to its simplicity, I doubt the major benefit of this. An example of use: ;; Is there a non-CLIM-INTERNALS way of getting these things drawn? (define-presentation-method present ((pattern climi::pattern) (type climi::pattern) stream (view drei-view) &key acceptably for-context-type) (declare (ignore acceptably for-context-type)) (multiple-value-bind (x y) (stream-cursor-position stream) (draw-pattern* stream pattern x y) (stream-increment-cursor-position stream (+ (pattern-width pattern)) 0))) (asdf:operate 'asdf:load-op :mcclim-images) (asdf:operate 'asdf:load-op :mcclim-images-gif) (asdf:operate 'asdf:load-op :mcclim-images-xpm) (define-command (com-insert-image :name t :command-table climacs-gui::development-table) ((image-pathname 'pathname :default (merge-pathnames (user-homedir-pathname)) :insert-default t)) (if (probe-file image-pathname) (handler-case (insert-object (point) (mcclim-images:load-image image-pathname)) (mcclim-images:unsupported-image-format (c) (display-message "Image format ~A not recognized" (mcclim-images:image-format c)))) (display-message "No such file: ~A" image-pathname))) --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/12/28 10:08:58 1.70 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/01/06 08:36:58 1.71 @@ -548,6 +548,34 @@ (:file "Looks/pixie" :pathname #.(make-pathname :directory '(:relative "Looks") :name "pixie" :type "lisp")))) +(defsystem :mcclim-images + :depends-on (:clim) + :components ((:module "Extensions/Images" + :pathname #.(make-pathname :directory '(:relative "Extensions" "Images")) + :components ((:file "package") + (:file "images"))))) + +(defmacro support-format (format &rest depends-on) + "Generate the ASDF `defsystem' form for a single-file system +consisting of a file with the name `format' in +Extensions/Images. It will depend on the ASDF systems listed in +`depends-on' as well as MCCLIM-IMAGES." + `(defsystem ,(intern (format nil "MCCLIM-IMAGES-~A" (string-upcase format)) + (find-package :keyword)) + :depends-on (:mcclim-images , at depends-on) + :components + ((:file ,format + :pathname ,(make-pathname :directory '(:relative "Extensions" "Images") + :name format))))) + +(defmacro support-formats (&rest formats) + "Generate the ASDF `defsystem' forms for supporting +`formats'." + `(progn ,@(loop for (format . depends-on) in formats + collecting `(support-format ,format , at depends-on)))) + +(support-formats ("gif" :skippy) ("xpm")) + ;;; The actual McCLIM system that people should to use in their ASDF ;;; package dependency lists. (defsystem :mcclim From thenriksen at common-lisp.net Sun Jan 6 11:45:13 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 6 Jan 2008 06:45:13 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080106114513.7DD9E4F031@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv1591/Drei Modified Files: drei-redisplay.lisp Log Message: Committed some heinous hacking to handle more cases where point ends up outside of the visible area. Perhaps it is soon time to rewrite the pane-display scaffolding rather than using old, refurbished Climacs code. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/03 18:09:27 1.19 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/06 11:45:11 1.20 @@ -623,9 +623,9 @@ (setf (displayed-lines-count view) 0) (multiple-value-bind (cursor-x cursor-y) (stream-cursor-position pane) (with-output-recording-options (pane :record nil :draw t) - (loop with start-offset = (offset (top view)) - with pump-state = (pump-state-for-offset view (offset (top view))) - with pane-height = (bounding-rectangle-height pane) + (loop with start-offset = (offset (beginning-of-line (top view))) + with pump-state = (pump-state-for-offset view start-offset) + with pane-height = (bounding-rectangle-height (or (pane-viewport pane) pane)) 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) @@ -857,14 +857,15 @@ (invalidate-all-strokes view :modified t)))) (defun adjust-pane (drei-pane) - "Adjust the bottom and top marks of the pane to be correct, and -reposition the pane if point is outside the visible area." + "Reposition the pane if point is outside the region delimited +by the top/bot marks of its view. Returns true if adjustment was +needed." (with-accessors ((buffer buffer) (top top) (bot bot) (point point)) (view drei-pane) - (beginning-of-line top) (when (or (mark< point top) (mark> point bot)) - (reposition-pane drei-pane)))) + (reposition-pane drei-pane) + t))) (defun page-down (view) (with-accessors ((top top) (bot bot)) view @@ -914,7 +915,7 @@ (round (- cursor-x))) 0))) (when (> (+ cursor-y line-height) (+ y-position viewport-height)) - (next-line (top view)) + (full-redisplay pane) ;; We start all over! (display-drei-pane (pane-frame pane) pane))))))) @@ -934,8 +935,7 @@ (defmethod fully-redisplay-pane ((drei-pane drei-pane) (view point-mark-view)) - (reposition-pane drei-pane) - (setf (full-redisplay-p view) nil)) + (reposition-pane drei-pane)) (defmethod fully-redisplay-pane :after ((drei-pane drei-pane) (view drei-buffer-view)) @@ -944,19 +944,20 @@ (defun display-drei-pane (frame drei-pane) "Display `pane'. If `pane' has focus, `current-p' should be non-NIL." - (declare (ignore frame)) (let ((view (view drei-pane))) (with-accessors ((buffer buffer)) view (when (typep view 'point-mark-view) - (if (full-redisplay-p view) - (fully-redisplay-pane drei-pane view) - (adjust-pane drei-pane))) + (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) - ;; Point must be on top of all other cursors. - (dolist (cursor (cursors drei-pane)) - (display-drei-view-cursor drei-pane view cursor)) - (fix-pane-viewport drei-pane (view drei-pane))))) + (if (adjust-pane drei-pane) + (display-drei-pane frame drei-pane) + ;; Point must be on top of all other cursors. + (progn + (dolist (cursor (cursors drei-pane)) + (display-drei-view-cursor drei-pane view cursor)) + (fix-pane-viewport drei-pane (view drei-pane))))))) (defgeneric full-redisplay (pane) (:documentation "Queue a full redisplay for `pane'.")) From thenriksen at common-lisp.net Sun Jan 6 15:32:12 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 6 Jan 2008 10:32:12 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20080106153212.20B6072128@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv6587/Apps/Listener Modified Files: icons.lisp Log Message: Changed CLIM Listener to use MCCLIM-IMAGES:LOAD-IMAGE instead of CLIM-INTERNALS::XPM-PARSE-FILE. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/icons.lisp 2006/03/29 10:43:37 1.5 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/icons.lisp 2008/01/06 15:32:11 1.6 @@ -34,7 +34,7 @@ (defmacro deficon (var pathname) `(eval-when (:load-toplevel :execute) - (defparameter ,var (climi::xpm-parse-file ,(merge-pathnames pathname *icon-path*))))) + (defparameter ,var (mcclim-images:load-image ,(merge-pathnames pathname *icon-path*))))) (defvar *icon-cache* (make-hash-table :test #'equal)) @@ -42,8 +42,9 @@ "Loads an icon from the *icon-path*, caching it by name in *icon-cache*" (or (gethash filename *icon-cache*) (setf (gethash filename *icon-cache*) - (climi::xpm-parse-file (merge-pathnames (parse-namestring filename) - *icon-path*))))) + (mcclim-images:load-image + (merge-pathnames (parse-namestring filename) + *icon-path*))))) ;; Don't particularly need these any more.. (deficon *folder-icon* #P"folder.xpm") From thenriksen at common-lisp.net Sun Jan 6 15:32:12 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 6 Jan 2008 10:32:12 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080106153212.B2A8C72095@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv6587 Modified Files: clim-listener.asd Log Message: Changed CLIM Listener to use MCCLIM-IMAGES:LOAD-IMAGE instead of CLIM-INTERNALS::XPM-PARSE-FILE. --- /project/mcclim/cvsroot/mcclim/clim-listener.asd 2007/02/05 03:29:45 1.2 +++ /project/mcclim/cvsroot/mcclim/clim-listener.asd 2008/01/06 15:32:12 1.3 @@ -6,7 +6,7 @@ (in-package :clim-listener.system) (defsystem :clim-listener - :depends-on (:mcclim #+sbcl :sb-posix) + :depends-on (:mcclim #+sbcl :sb-posix :mcclim-images :mcclim-images-xpm) :components ((:file "Experimental/xpm" :pathname #.(make-pathname :directory '(:relative "Experimental") :name "xpm" :type "lisp")) From dlichteblau at common-lisp.net Sun Jan 6 16:05:46 2008 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 6 Jan 2008 11:05:46 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080106160546.9D7954F033@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv16520 Modified Files: mcclim.asd Log Message: - added jpeg.lisp by Eric Marsden and Troels Henriksen - changed rgb-image-design to invalidate the medium-specific cache automatically instead of being bound to one medium - added output recording for draw-design of an rgb-image-design --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/01/06 08:36:58 1.71 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/01/06 16:05:46 1.72 @@ -574,7 +574,7 @@ `(progn ,@(loop for (format . depends-on) in formats collecting `(support-format ,format , at depends-on)))) -(support-formats ("gif" :skippy) ("xpm")) +(support-formats ("gif" :skippy) ("xpm") ("jpeg" :cl-jpeg)) ;;; The actual McCLIM system that people should to use in their ASDF ;;; package dependency lists. From dlichteblau at common-lisp.net Sun Jan 6 16:05:46 2008 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 6 Jan 2008 11:05:46 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Extensions Message-ID: <20080106160546.D5C154F034@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Extensions In directory clnet:/tmp/cvs-serv16520/Extensions Modified Files: rgb-image.lisp Log Message: - added jpeg.lisp by Eric Marsden and Troels Henriksen - changed rgb-image-design to invalidate the medium-specific cache automatically instead of being bound to one medium - added output recording for draw-design of an rgb-image-design --- /project/mcclim/cvsroot/mcclim/Extensions/rgb-image.lisp 2007/04/01 17:24:04 1.2 +++ /project/mcclim/cvsroot/mcclim/Extensions/rgb-image.lisp 2008/01/06 16:05:46 1.3 @@ -43,14 +43,12 @@ ;;; medium, so that mediums can put their own data into them. (defclass rgb-image-design (design) - ((medium :initarg :medium) + ((medium :initform nil :initarg :medium) (image :initarg :image) (medium-data :initform nil))) -(defun make-rgb-image-design (medium image) - (make-instance 'rgb-image-design - :medium medium - :image image)) +(defun make-rgb-image-design (image) + (make-instance 'rgb-image-design :image image)) ;;; Protocol to free cached data @@ -65,8 +63,13 @@ (defgeneric medium-draw-image-design* (medium design x y)) -(defmethod medium-draw-image-design* :before (medium design x y) - (assert (eq medium (slot-value design 'medium)))) +(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)))) ;;; Fetching protocol @@ -88,3 +91,17 @@ :alphap alphap)))) (defgeneric sheet-rgb-data (port sheet &key x y width height)) + + +;;; Output recording + +(defun draw-image-design* + (medium design &rest options &key x y &allow-other-keys) + (unless (and x y) + (setf (values x y) (clim:stream-cursor-position medium))) + (climi::with-medium-options (medium options) + (medium-draw-image-design* (sheet-medium medium) design x y))) + +(defmethod draw-design + (medium (design rgb-image-design) &rest options &key &allow-other-keys) + (apply #'draw-image-design* medium design options)) From dlichteblau at common-lisp.net Sun Jan 6 16:05:47 2008 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 6 Jan 2008 11:05:47 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Extensions/Images Message-ID: <20080106160547.11B214F033@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Extensions/Images In directory clnet:/tmp/cvs-serv16520/Extensions/Images Added Files: jpeg.lisp Log Message: - added jpeg.lisp by Eric Marsden and Troels Henriksen - changed rgb-image-design to invalidate the medium-specific cache automatically instead of being bound to one medium - added output recording for draw-design of an rgb-image-design --- /project/mcclim/cvsroot/mcclim/Extensions/Images/jpeg.lisp 2008/01/06 16:05:47 NONE +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/jpeg.lisp 2008/01/06 16:05:47 1.1 ;;; -*- Mode: Lisp; Package: MCCLIM-IMAGES -*- ;;; (c) copyright 2008 ;;; Eric Marsden ;;; (c) copyright 2008 by ;;; Troels Henriksen (athas at 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 :mcclim-images) (define-image-reader "jpeg" (pathname) (with-open-file (stream pathname :direction :input) (multiple-value-bind (rgb height width) (jpeg:decode-image stream) (let* ((rgb-image-data (make-array (list height width) :element-type '(unsigned-byte 32))) (rgb-image (make-instance 'clim-internals::rgb-image :width width :height height :alphap nil :data rgb-image-data))) (loop for y from (1- height) downto 0 do (loop for x from (1- width) downto 0 do (let ((grey (svref rgb (+ x (* y width))))) (setf (aref rgb-image-data y x) (dpb grey (byte 8 0) (dpb grey (byte 8 8) (dpb grey (byte 8 16) (dpb (- 255 0) (byte 8 24) 0)))))))) (clim-internals::make-rgb-image-design rgb-image))))) From thenriksen at common-lisp.net Mon Jan 7 12:00:43 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 7 Jan 2008 07:00:43 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080107120043.C80AF481D4@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv16397/Drei Modified Files: lisp-syntax.lisp Log Message: Added parenthesis highlighting for Lisp syntax. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/05 21:07:16 1.52 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/07 12:00:43 1.53 @@ -275,9 +275,10 @@ (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 left-parenthesis-lexeme (lisp-lexeme) ()) +(defclass parenthesis-lexeme (lisp-lexeme) ()) +(defclass left-parenthesis-lexeme (parenthesis-lexeme) ()) (defclass simple-vector-start-lexeme (lisp-lexeme) ()) -(defclass right-parenthesis-lexeme (lisp-lexeme) ()) +(defclass right-parenthesis-lexeme (parenthesis-lexeme) ()) (defclass quote-lexeme (lisp-lexeme) ()) (defclass backquote-lexeme (lisp-lexeme) ()) (defclass comma-lexeme (lisp-lexeme) ()) @@ -1832,7 +1833,8 @@ (let ((keyword-drawing-options (make-drawing-options :face (make-face :ink +orchid+))) (macro-drawing-options (make-drawing-options :face (make-face :ink +purple+))) - (bound-drawing-options (make-drawing-options :face (make-face :ink +darkgoldenrod+)))) + (bound-drawing-options (make-drawing-options :face (make-face :ink +darkgoldenrod+))) + (highlighted-parenthesis-options (make-drawing-options :face (make-face :style (make-text-style nil :bold nil))))) (make-syntax-highlighting-rules emacs-style-highlighting (error-lexeme (:face :ink +red+)) (string-form (:face :ink +rosy-brown+ @@ -1846,7 +1848,15 @@ macro-drawing-options) ((symbol-form-is-boundp syntax form) bound-drawing-options) - (t +default-drawing-options+))))))) + (t +default-drawing-options+))))) + (parenthesis-lexeme (:function #'(lambda (syntax form) + (declare (ignore syntax)) + ;; XXX: Using (point) here may be hacky. + (if (and (or (mark= (point) (start-offset (parent form))) + (mark= (point) (end-offset (parent form)))) + (form-complete-p (parent form))) + highlighted-parenthesis-options + +default-drawing-options+)))))) (let ((macro-drawing-options (make-drawing-options :face (make-face :style (make-text-style nil :bold nil))))) (make-syntax-highlighting-rules retro-highlighting From thenriksen at common-lisp.net Mon Jan 7 12:54:02 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 7 Jan 2008 07:54:02 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Extensions/Images Message-ID: <20080107125402.363CF63062@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Extensions/Images In directory clnet:/tmp/cvs-serv32595/Extensions/Images Modified Files: jpeg.lisp Log Message: Add "jpg" as synonym for "jpeg" image format. Use internal symbol JPEG::DECODE-IMAGE as CLJL only exports its symbols during compilation (???). --- /project/mcclim/cvsroot/mcclim/Extensions/Images/jpeg.lisp 2008/01/06 16:05:47 1.1 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/jpeg.lisp 2008/01/07 12:54:02 1.2 @@ -25,7 +25,7 @@ (define-image-reader "jpeg" (pathname) (with-open-file (stream pathname :direction :input) (multiple-value-bind (rgb height width) - (jpeg:decode-image stream) + (jpeg::decode-image stream) (let* ((rgb-image-data (make-array (list height width) :element-type '(unsigned-byte 32))) (rgb-image (make-instance 'clim-internals::rgb-image @@ -40,3 +40,6 @@ (dpb grey (byte 8 16) (dpb (- 255 0) (byte 8 24) 0)))))))) (clim-internals::make-rgb-image-design rgb-image))))) + +(define-image-reader "jpg" (pathname) + (load-image-of-format "jpeg" pathname)) From thenriksen at common-lisp.net Mon Jan 7 13:30:55 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 7 Jan 2008 08:30:55 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080107133055.CDF00481AE@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv15544/Drei Modified Files: drei-redisplay.lisp Log Message: Reduce the number of calls to DRAW-RECTANGLE*. Handle redisplay of strokes that have only had their drawing options changed (such as highlighted parentheses). Perhaps there is a need for a redisplay flag saying "I need to be drawn in a new position, but with the exact same output as before, so don't bother recomputing my size". --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/06 11:45:11 1.20 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/07 13:30:55 1.21 @@ -436,22 +436,18 @@ (+ width cursor-x) (+ text-style-height cursor-y) baseline)))))) -(defun draw-stroke (stream view stroke cursor-x cursor-y line-height) +(defun draw-stroke (stream view stroke cursor-x cursor-y) "Draw `stroke' on `stream' at (`cursor-x', `cursor-y'). Nothing will be done unless `stroke' is dirty. Will use the function specified in the drawing-options of `stroke' to carry out the actual drawing." (let* ((drawing-options (stroke-drawing-options stroke))) + (unless (and (= cursor-x (x1 (stroke-dimensions stroke))) + (= cursor-y (y1 (stroke-dimensions stroke)))) + (invalidate-stroke stroke :modified t)) (when (stroke-dirty stroke) - (let ((old-dimensions (stroke-dimensions stroke))) - (with-accessors ((x1 x1) (y1 y1) (x2 x2) (y2 y2)) old-dimensions - (unless (or (= x1 y1 x2 y2 0)) - ;; Take care not to clear any previously drawn strokes. - (clear-rectangle* stream (max cursor-x x1) (max cursor-y y1) - (max x2 cursor-x) (+ (max (+ (max cursor-y y1) line-height) y2) - (stream-vertical-spacing stream)))) - (funcall (drawing-options-function drawing-options) stream view stroke - cursor-x cursor-y #'stroke-drawing-fn)))))) + (funcall (drawing-options-function drawing-options) stream view stroke + cursor-x cursor-y #'stroke-drawing-fn)))) (defun end-line (line x1 y1 line-width line-height) "End the addition of strokes to `line' for now, and update the @@ -520,7 +516,7 @@ for stroke-dimensions = (stroke-dimensions stroke) for pump-state = (put-stroke view line initial-pump-state) then (put-stroke view line pump-state) - do (draw-stroke stream view stroke cursor-x cursor-y line-height) + do (draw-stroke stream view stroke cursor-x cursor-y) (setf cursor-x (x2 stroke-dimensions)) maximizing (dimensions-height stroke-dimensions) into line-height summing (- (x2 stroke-dimensions) From thenriksen at common-lisp.net Mon Jan 7 14:18:15 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 7 Jan 2008 09:18:15 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Extensions/Images Message-ID: <20080107141815.735565B0BB@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Extensions/Images In directory clnet:/tmp/cvs-serv27894/Extensions/Images Modified Files: gif.lisp Log Message: Handle GIF images with transparent parts. --- /project/mcclim/cvsroot/mcclim/Extensions/Images/gif.lisp 2008/01/06 08:36:57 1.1 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/gif.lisp 2008/01/07 14:18:15 1.2 @@ -26,10 +26,13 @@ (pattern-array (make-array (list (skippy:height first-image) (skippy:width first-image)))) (designs (coerce (loop with color-table = (skippy:color-table data-stream) - for i below 255 - collecting (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)))) + for i below (skippy:color-table-size color-table) + when (= i (skippy:transparency-index first-image)) + 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 (array-dimension pattern-array 0)) (dotimes (x (array-dimension pattern-array 1)) From thenriksen at common-lisp.net Mon Jan 7 15:32:15 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 7 Jan 2008 10:32:15 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080107153215.4027748152@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv17553/Drei Modified Files: lisp-syntax.lisp lr-syntax.lisp Log Message: Made parenmatching more elegant by sprinling the magic dust of refactoring. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/07 12:00:43 1.53 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/07 15:32:15 1.54 @@ -1841,19 +1841,18 @@ :style (make-text-style nil :italic nil))) (comment (:face :ink +maroon+ :style (make-text-style :serif :bold :large))) (literal-object-form (:options :function (object-drawer))) - (complete-token-form (:function #'(lambda (syntax form) - (cond ((symbol-form-is-keyword-p syntax form) + (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 form) + ((symbol-form-is-macrobound-p (syntax view) form) macro-drawing-options) - ((symbol-form-is-boundp syntax form) + ((symbol-form-is-boundp (syntax view) form) bound-drawing-options) (t +default-drawing-options+))))) - (parenthesis-lexeme (:function #'(lambda (syntax form) - (declare (ignore syntax)) - ;; XXX: Using (point) here may be hacky. - (if (and (or (mark= (point) (start-offset (parent form))) - (mark= (point) (end-offset (parent form)))) + (parenthesis-lexeme (:function #'(lambda (view form) + (if (and (typep view 'point-mark-view) + (or (mark= (point view) (start-offset (parent form))) + (mark= (point view) (end-offset (parent form)))) (form-complete-p (parent form))) highlighted-parenthesis-options +default-drawing-options+)))))) --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/04 14:12:48 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/07 15:32:15 1.10 @@ -431,29 +431,30 @@ draw the parser symbol. `:function', in which case `args' must be a single element, a - function that takes two arguments. These arguments are 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." + 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." (check-type name symbol) `(progn (fmakunbound ',name) - (defgeneric ,name (syntax parser-symbol) - (:method (syntax (parser-symbol parser-symbol)) + (defgeneric ,name (view parser-symbol) + (:method (view (parser-symbol parser-symbol)) nil)) ,@(flet ((make-rule-exp (type args) (ecase type - (:face `#'(lambda (syntax parser-symbol) - (declare (ignore syntax parser-symbol)) - (make-drawing-options :face (make-face , at args)))) - (:options `#'(lambda (syntax parser-symbol) - (declare (ignore syntax parser-symbol)) + (:face `(let ((options (make-drawing-options :face (make-face , at args)))) + #'(lambda (view parser-symbol) + (declare (ignore view parser-symbol)) + options))) + (:options `#'(lambda (view parser-symbol) + (declare (ignore view parser-symbol)) (make-drawing-options , at args))) (:function (first args))))) (loop for (parser-symbol (type . args)) in rules collect `(let ((rule ,(make-rule-exp type args))) - (defmethod ,name (syntax (parser-symbol ,parser-symbol)) - (funcall rule syntax parser-symbol))))))) + (defmethod ,name (view (parser-symbol ,parser-symbol)) + (funcall rule view parser-symbol))))))) (make-syntax-highlighting-rules default-syntax-highlighting) @@ -465,11 +466,13 @@ (:method ((syntax lr-syntax-mixin)) 'default-syntax-highlighting)) -(defun get-drawing-options (highlighting-rules syntax parse-symbol) +(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." - (when (and parse-symbol (not (eq (stack-top syntax) parse-symbol))) - (funcall highlighting-rules syntax parse-symbol))) +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 @@ -493,7 +496,7 @@ (if (null parser-symbol) (cons (size (buffer view)) +default-drawing-options+) (let ((drawing-options - (get-drawing-options highlighting-rules syntax parser-symbol))) + (get-drawing-options highlighting-rules view parser-symbol))) (if (null drawing-options) (initial-drawing-options (parent parser-symbol)) (cons (end-offset parser-symbol) drawing-options)))))) @@ -502,7 +505,7 @@ (cons (1+ (size (buffer view))) +default-drawing-options+)) highlighting-rules)))) -(defun find-next-stroke-end (syntax pump-state) +(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'." @@ -511,7 +514,7 @@ (drawing-options pump-state-drawing-options) (highlighting-rules pump-state-highlighting-rules)) pump-state - (let ((line (line-containing-offset syntax offset))) + (let ((line (line-containing-offset (syntax view) offset))) (flet ((finish (offset symbol &optional stroke-drawing-options) (setf start-symbol symbol) (loop until (> (car (first drawing-options)) offset) @@ -530,7 +533,7 @@ (t (or (do-parse-symbols-forward (symbol offset start-symbol) (let ((symbol-drawing-options - (get-drawing-options highlighting-rules syntax symbol))) + (get-drawing-options highlighting-rules view symbol))) (cond ((> (start-offset symbol) (line-end-offset line)) (finish (line-end-offset line) start-symbol)) ((and (typep symbol 'literal-object-mixin)) @@ -564,7 +567,7 @@ (current-drawing-options pump-state-drawing-options)) pump-state (let ((old-drawing-options (cdr (first current-drawing-options))) - (end-offset (find-next-stroke-end syntax pump-state))) + (end-offset (find-next-stroke-end view pump-state))) (setf (stroke-start-offset stroke) offset (stroke-end-offset stroke) end-offset (stroke-drawing-options stroke) old-drawing-options From thenriksen at common-lisp.net Mon Jan 7 20:23:45 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 7 Jan 2008 15:23:45 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080107202345.79B37490A6@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv23949/Drei Modified Files: drei-redisplay.lisp Log Message: Fixed the bouncy lines problem once and for all! --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/07 13:30:55 1.21 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/07 20:23:45 1.22 @@ -395,6 +395,10 @@ (y2 dimensions) y2 (center dimensions) center))) +(defconstant +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 `stroke' to `stream' at the position (`cursor-x', `cursor-y'). `View' is the view object that `stroke' belongs @@ -413,8 +417,13 @@ (merged-text-style (merge-text-styles (face-style (drawing-options-face drawing-options)) (medium-merged-text-style (sheet-medium stream)))) - (text-style-ascent (text-style-ascent merged-text-style (sheet-medium stream))) - (text-style-descent (text-style-descent 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))) (text-style-height (+ text-style-ascent text-style-descent))) (with-accessors ((x1 x1) (y1 y1) (x2 x2) (y2 y2) (center center)) dimensions (multiple-value-bind (width ignore1 ignore2 ignore3 baseline) From thenriksen at common-lisp.net Mon Jan 7 22:01:59 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 7 Jan 2008 17:01:59 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080107220159.0DFE343227@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv12937/Drei Modified Files: fundamental-syntax.lisp lr-syntax.lisp packages.lisp syntax.lisp views.lisp Log Message: Changed the update-syntax protocol to use a nonstandard method combination for added job security. --- /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2008/01/03 16:25:16 1.10 +++ /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2008/01/07 22:01:53 1.11 @@ -90,24 +90,8 @@ (cons (- (1+ chunk-end-offset) line-start-offset) t))))) -(defmethod initialize-instance :after ((line line-object) - &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 update-syntax ((syntax fundamental-syntax) prefix-size suffix-size - &optional begin end) +(defmethod update-syntax values-max-min ((syntax fundamental-syntax) prefix-size suffix-size + &optional begin end) (declare (ignore begin end)) (let ((low-mark (make-buffer-mark (buffer syntax) prefix-size :left)) (high-mark (make-buffer-mark @@ -144,7 +128,25 @@ (if (end-of-buffer-p scan) (loop-finish) ;; skip newline - (forward-object scan)))))))))) + (forward-object scan)))))))) + ;; Fundamental syntax always parses the entire buffer. + (values 0 (size (buffer syntax))))) + +(defmethod initialize-instance :after ((line line-object) + &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))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/07 15:32:15 1.10 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/07 22:01:58 1.11 @@ -356,10 +356,9 @@ ;;; ;;; update syntax -(defmethod update-syntax ((syntax lr-syntax-mixin) prefix-size suffix-size - &optional begin end) +(defmethod update-syntax values-max-min ((syntax lr-syntax-mixin) prefix-size suffix-size + &optional begin end) (declare (ignore begin end)) - (call-next-method) (let* ((low-mark-offset prefix-size) (high-mark-offset (- (size (buffer syntax)) suffix-size))) (when (<= low-mark-offset high-mark-offset) @@ -378,7 +377,8 @@ (new-state syntax (parser-state stack-top) stack-top))) - (loop do (parse-patch syntax))))))) + (loop do (parse-patch syntax)))))) + (values 0 (size (buffer syntax)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/05 20:08:32 1.33 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/07 22:01:58 1.34 @@ -484,7 +484,7 @@ (defpackage :drei-fundamental-syntax (:use :clim-lisp :clim :drei-buffer :drei-base - :drei-syntax :flexichain :drei :drei-core) + :drei-syntax :flexichain :drei :drei-core :esa-utils) (:export #:fundamental-syntax #:scan #:start-mark #:line-length #:line-end-offset #:line-containing-offset #:offset-in-line-p) --- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2007/12/28 10:08:34 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/01/07 22:01:58 1.10 @@ -78,7 +78,15 @@ 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.")) +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) + (:method values-max-min ((syntax syntax) (unchanged-prefix integer) + (unchanged-suffix integer) &optional (begin 0) + (end (- (size (buffer syntax)) unchanged-suffix))) + (values begin end))) (defgeneric eval-defun (mark syntax)) --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/03 18:09:27 1.12 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/07 22:01:58 1.13 @@ -659,12 +659,14 @@ (call-next-method)) (defmethod synchronize-view :around ((view drei-syntax-view) &key - force-p) + force-p (begin 0) (end (size (buffer view)))) ;; If nothing changed, then don't call the other methods. - (unless (and (= (prefix-size view) (suffix-size view) - (size (buffer view)) (buffer-size view)) - (not force-p)) - (call-next-method))) + (let ((high-offset (- (size (buffer view)) (suffix-size view)))) + (when (or (and (>= begin (prefix-size view)) + (>= high-offset end)) + (/= (size (buffer view)) (buffer-size view)) + force-p) + (call-next-method)))) (defmethod synchronize-view ((view drei-syntax-view) &key (begin 0) (end (size (buffer view)))) @@ -674,12 +676,21 @@ size of the buffer respectively." (let ((prefix-size (prefix-size view)) (suffix-size (suffix-size view))) - ;; Reset here so if `update-syntax' calls `update-parse' itself, - ;; we won't end with infinite recursion. - (setf (prefix-size view) (size (buffer view)) - (suffix-size view) (size (buffer 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) (if (> begin prefix-size) + prefix-size + end) + (suffix-size view) (if (>= end (- (size (buffer view)) suffix-size)) + (- (size (buffer view)) (prefix-size view)) + suffix-size) (buffer-size view) (size (buffer view))) - (update-syntax (syntax view) prefix-size suffix-size begin end) + (multiple-value-bind (parsed-start parsed-end) + (update-syntax (syntax view) prefix-size suffix-size begin end) + ;; Not set the proper new values for prefix-size and + ;; suffix-size. + (setf (prefix-size view) parsed-end + (suffix-size view) (- (size (buffer view)) parsed-start))) (call-next-method))) (defun make-syntax-for-view (view syntax-symbol &rest args) From thenriksen at common-lisp.net Mon Jan 7 22:01:59 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 7 Jan 2008 17:01:59 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20080107220159.4BDC5490A6@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv12937/ESA Modified Files: packages.lisp utils.lisp Log Message: Changed the update-syntax protocol to use a nonstandard method combination for added job security. --- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/01/01 18:43:36 1.9 +++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/01/07 22:01:59 1.10 @@ -44,6 +44,7 @@ #:subtype-compatible-p #:capitalize #:ensure-array-size + #:values-max-min #:observable-mixin #:add-observer #:remove-observer #:observer-notified #:notify-observers --- /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2008/01/01 18:43:36 1.6 +++ /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2008/01/07 22:01:59 1.7 @@ -233,6 +233,34 @@ do (setf (elt array i) (funcall new-elem-fn))))) array) +(define-method-combination values-max-min + (&optional (order ':most-specific-last)) + ((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)))) + (defclass observable-mixin () ((%observers :accessor observers :initform '())) From thenriksen at common-lisp.net Mon Jan 7 22:05:22 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 7 Jan 2008 17:05:22 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080107220522.81E545625A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv13469/Drei Modified Files: lisp-syntax.lisp lr-syntax.lisp packages.lisp Log Message: make-syntax-highlighting-rules -> define-syntax-highlighting-rules, as the former sounds stupid. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/07 15:32:15 1.54 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/07 22:05:22 1.55 @@ -1835,7 +1835,7 @@ (macro-drawing-options (make-drawing-options :face (make-face :ink +purple+))) (bound-drawing-options (make-drawing-options :face (make-face :ink +darkgoldenrod+))) (highlighted-parenthesis-options (make-drawing-options :face (make-face :style (make-text-style nil :bold nil))))) - (make-syntax-highlighting-rules emacs-style-highlighting + (define-syntax-highlighting-rules emacs-style-highlighting (error-lexeme (:face :ink +red+)) (string-form (:face :ink +rosy-brown+ :style (make-text-style nil :italic nil))) @@ -1858,7 +1858,7 @@ +default-drawing-options+)))))) (let ((macro-drawing-options (make-drawing-options :face (make-face :style (make-text-style nil :bold nil))))) - (make-syntax-highlighting-rules retro-highlighting + (define-syntax-highlighting-rules retro-highlighting (error-symbol (:face :ink +red+)) (string-form (:face :style (make-text-style nil :italic nil))) (comment (:face :style (make-text-style nil nil nil) --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/07 22:01:58 1.11 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/07 22:05:22 1.12 @@ -412,7 +412,7 @@ ;;; XXXXX XXXXX ;;; XXX XXX -(defmacro make-syntax-highlighting-rules (name &body rules) +(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 @@ -456,7 +456,7 @@ (defmethod ,name (view (parser-symbol ,parser-symbol)) (funcall rule view parser-symbol))))))) -(make-syntax-highlighting-rules default-syntax-highlighting) +(define-syntax-highlighting-rules default-syntax-highlighting) (defgeneric syntax-highlighting-rules (syntax) (:documentation "Return the drawing options that should be used --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/07 22:01:58 1.34 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/07 22:05:22 1.35 @@ -507,7 +507,7 @@ #:action #:new-state #:done #:reduce-fixed-number #:reduce-until-type #:reduce-all #:error-state #:error-reduce-state - #:make-syntax-highlighting-rules + #:define-syntax-highlighting-rules #:syntax-highlighting-rules) (:documentation "Underlying LR parsing functionality.")) From thenriksen at common-lisp.net Mon Jan 7 22:37:17 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 7 Jan 2008 17:37:17 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080107223717.9B46643251@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv18573/Drei Modified Files: lisp-syntax.lisp packages.lisp Added Files: drawing-options.lisp Log Message: Added some standard drawing options, including syntactical drawing options. This is meant to make it easier to switch colour schemes. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/07 22:05:22 1.55 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/07 22:37:17 1.56 @@ -1831,43 +1831,37 @@ (progn (cache-symbol-info syntax symbol-form) (global-boundp symbol-form)))) -(let ((keyword-drawing-options (make-drawing-options :face (make-face :ink +orchid+))) - (macro-drawing-options (make-drawing-options :face (make-face :ink +purple+))) - (bound-drawing-options (make-drawing-options :face (make-face :ink +darkgoldenrod+))) - (highlighted-parenthesis-options (make-drawing-options :face (make-face :style (make-text-style nil :bold nil))))) - (define-syntax-highlighting-rules emacs-style-highlighting - (error-lexeme (:face :ink +red+)) - (string-form (:face :ink +rosy-brown+ - :style (make-text-style nil :italic nil))) - (comment (:face :ink +maroon+ :style (make-text-style :serif :bold :large))) - (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) - macro-drawing-options) - ((symbol-form-is-boundp (syntax view) form) - bound-drawing-options) - (t +default-drawing-options+))))) - (parenthesis-lexeme (:function #'(lambda (view form) - (if (and (typep view 'point-mark-view) - (or (mark= (point view) (start-offset (parent form))) - (mark= (point view) (end-offset (parent form)))) - (form-complete-p (parent form))) - highlighted-parenthesis-options - +default-drawing-options+)))))) - -(let ((macro-drawing-options (make-drawing-options :face (make-face :style (make-text-style nil :bold nil))))) - (define-syntax-highlighting-rules retro-highlighting - (error-symbol (:face :ink +red+)) - (string-form (:face :style (make-text-style nil :italic nil))) - (comment (:face :style (make-text-style nil nil nil) - :ink +dimgray+)) - (literal-object-form (:options :function (object-drawer))) - (complete-token-form (:function #'(lambda (syntax form) - (cond ((symbol-form-is-macrobound-p syntax form) - macro-drawing-options) - (t +default-drawing-options+))))))) +(define-syntax-highlighting-rules emacs-style-highlighting + (error-lexeme (:face :ink +red+)) + (string-form (:face :ink +rosy-brown+ + :style +italic-face-style+)) + (comment (:face :ink +maroon+ :style (make-text-style :serif :bold :large))) + (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 #'(lambda (view form) + (if (and (typep view 'point-mark-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+))))) + +(define-syntax-highlighting-rules retro-highlighting + (error-symbol (:face :ink +red+)) + (string-form (:face :style +italic-face-style+)) + (comment (:face :ink +dimgray+)) + (literal-object-form (:options :function (object-drawer))) + (complete-token-form (:function #'(lambda (syntax form) + (cond ((symbol-form-is-macrobound-p syntax form) + +bold-face-drawing-options+) + (t +default-drawing-options+)))))) (defparameter *syntax-highlighting-rules* 'emacs-style-highlighting "The syntax highlighting rules used for highlighting Lisp --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/07 22:05:22 1.35 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/07 22:37:17 1.36 @@ -246,12 +246,12 @@ #:minibuffer - ;; DREI interface stuff. #:drei #:drei-pane #:drei-gadget-pane #:drei-area #:handling-drei-conditions #:handle-drei-condition #:execute-drei-command - #:display-drei-view-contents #:display-drei-view-cursor + ;; Redisplay engine. + #:display-drei-view-contents #:display-drei-view-cursor #:face #:make-face #:face-ink #:face-style #:drawing-options #:make-drawing-options #:drawing-options-face #:drawing-options-function @@ -261,6 +261,17 @@ #: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* + + ;; DREI program interface stuff. #:with-drei-options #:performing-drei-operations #:invoke-performing-drei-operations #:with-bound-drei-special-variables --- /project/mcclim/cvsroot/mcclim/Drei/drawing-options.lisp 2008/01/07 22:37:17 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/drawing-options.lisp 2008/01/07 22:37:17 1.1 ;;; -*- Mode: Lisp; Package: DREI -*- ;;; (c) copyright 2008 by ;;; Troels Henriksen (athas at 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. (defconstant +roman-face+ (make-face :style (make-text-style nil :roman nil)) "A face specifying a roman style, but with unspecified family and size.") (defconstant +italic-face+ (make-face :style (make-text-style nil :italic nil)) "A face specifying an italic style, but with unspecified family and size.") (defconstant +bold-face+ (make-face :style (make-text-style nil :bold nil)) "A face specifying a boldface style, but with unspecified family and size.") (defconstant +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. (defconstant +roman-face-drawing-options+ (make-drawing-options :face +roman-face+) "Options used for drawing with a roman face.") (defconstant +italic-face-drawing-options+ (make-drawing-options :face +italic-face+) "Options used for drawing with an italic face.") (defconstant +bold-face-drawing-options+ (make-drawing-options :face +bold-face+) "Options used for drawing with boldface.") (defconstant +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. (defvar *keyword-drawing-options* (make-drawing-options :face (make-face :ink +orchid+)) "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 +purple+)) "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 +darkgoldenrod+)) "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.") From thenriksen at common-lisp.net Mon Jan 7 22:55:11 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 7 Jan 2008 17:55:11 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080107225511.5FCD54F041@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv22310/Drei Modified Files: drawing-options.lisp lisp-syntax.lisp lr-syntax.lisp packages.lisp Log Message: My last commit was a broken monster, here's the rest. --- /project/mcclim/cvsroot/mcclim/Drei/drawing-options.lisp 2008/01/07 22:37:17 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/drawing-options.lisp 2008/01/07 22:55:11 1.2 @@ -57,7 +57,9 @@ ;;; 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. +;;; 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 +orchid+)) "The drawing options used for drawing the syntactical @@ -75,3 +77,17 @@ 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 +rosy-brown+ + :style +italic-face-style+)) + "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.") --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/07 22:37:17 1.56 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/07 22:55:11 1.57 @@ -1832,10 +1832,9 @@ (global-boundp symbol-form)))) (define-syntax-highlighting-rules emacs-style-highlighting - (error-lexeme (:face :ink +red+)) - (string-form (:face :ink +rosy-brown+ - :style +italic-face-style+)) - (comment (:face :ink +maroon+ :style (make-text-style :serif :bold :large))) + (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) @@ -1854,14 +1853,22 @@ +default-drawing-options+))))) (define-syntax-highlighting-rules retro-highlighting - (error-symbol (:face :ink +red+)) + (error-symbol (*error-drawing-options*)) (string-form (:face :style +italic-face-style+)) (comment (:face :ink +dimgray+)) (literal-object-form (:options :function (object-drawer))) (complete-token-form (:function #'(lambda (syntax form) (cond ((symbol-form-is-macrobound-p syntax form) +bold-face-drawing-options+) - (t +default-drawing-options+)))))) + (t +default-drawing-options+))))) + ;; XXX: Ugh, copied from above. + (parenthesis-lexeme (:function #'(lambda (view form) + (if (and (typep view 'point-mark-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+))))) (defparameter *syntax-highlighting-rules* 'emacs-style-highlighting "The syntax highlighting rules used for highlighting Lisp --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/07 22:05:22 1.12 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/07 22:55:11 1.13 @@ -420,7 +420,7 @@ `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 -symbols. +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 @@ -434,7 +434,11 @@ 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." + 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." (check-type name symbol) `(progn (fmakunbound ',name) @@ -442,7 +446,7 @@ (:method (view (parser-symbol parser-symbol)) nil)) ,@(flet ((make-rule-exp (type args) - (ecase type + (case type (:face `(let ((options (make-drawing-options :face (make-face , at args)))) #'(lambda (view parser-symbol) (declare (ignore view parser-symbol)) @@ -450,7 +454,10 @@ (:options `#'(lambda (view parser-symbol) (declare (ignore view parser-symbol)) (make-drawing-options , at args))) - (:function (first args))))) + (:function (first args)) + (t `#'(lambda (view parser-symbol) + (declare (ignore view parser-symbol)) + ,type))))) (loop for (parser-symbol (type . args)) in rules collect `(let ((rule ,(make-rule-exp type args))) (defmethod ,name (view (parser-symbol ,parser-symbol)) --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/07 22:37:17 1.36 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/07 22:55:11 1.37 @@ -270,6 +270,9 @@ #:*keyword-drawing-options* #:*special-operator-drawing-options* #:*special-variable-drawing-options* + #:*string-drawing-options* + #:*comment-drawing-options* + #:*error-drawing-options* ;; DREI program interface stuff. #:with-drei-options From thenriksen at common-lisp.net Mon Jan 7 22:55:11 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 7 Jan 2008 17:55:11 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080107225511.994285B050@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv22310 Modified Files: mcclim.asd Log Message: My last commit was a broken monster, here's the rest. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/01/06 16:05:46 1.72 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/01/07 22:55:11 1.73 @@ -299,6 +299,7 @@ (: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")) @@ -321,7 +322,7 @@ (:file "misc-commands" :depends-on ("basic-commands")) (:file "unicode-commands" :depends-on ("core" "drei-clim")) (:file "search-commands" :depends-on ("core" "targets" "drei-clim")) - (:file "lr-syntax" :depends-on ("fundamental-syntax" "core")) + (: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")) From thenriksen at common-lisp.net Mon Jan 7 23:00:51 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 7 Jan 2008 18:00:51 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080107230051.B239763089@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv25009/Drei Modified Files: drawing-options.lisp lisp-syntax.lisp Log Message: Removed references to nonexisting +italic-face-style+. --- /project/mcclim/cvsroot/mcclim/Drei/drawing-options.lisp 2008/01/07 22:55:11 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/drawing-options.lisp 2008/01/07 23:00:51 1.3 @@ -80,7 +80,7 @@ (defvar *string-drawing-options* (make-drawing-options :face (make-face :ink +rosy-brown+ - :style +italic-face-style+)) + :style (make-text-style nil :italic nil))) "The drawing options used for syntax-highlighting strings.") (defvar *comment-drawing-options* (make-drawing-options --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/07 22:55:11 1.57 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/07 23:00:51 1.58 @@ -1854,7 +1854,7 @@ (define-syntax-highlighting-rules retro-highlighting (error-symbol (*error-drawing-options*)) - (string-form (:face :style +italic-face-style+)) + (string-form (:options :face +italic-face+)) (comment (:face :ink +dimgray+)) (literal-object-form (:options :function (object-drawer))) (complete-token-form (:function #'(lambda (syntax form) From thenriksen at common-lisp.net Tue Jan 8 14:52:19 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 8 Jan 2008 09:52:19 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080108145219.358893201C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv649/Drei Modified Files: drei-redisplay.lisp Log Message: Try harder to only redraw the strokes that have actually changed. I think this should improve redisplay performance by 30-40% (when changing the buffer), but I don't want to affect the result by measuring it. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/07 20:23:45 1.22 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/08 14:52:18 1.23 @@ -191,7 +191,7 @@ `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) + (start-offset 0) (end-offset) (dimensions (make-dimensions)) (strokes (make-array 0 :adjustable t)) @@ -214,21 +214,6 @@ 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 :around ((view drei-buffer-view) stroke pump-state) - ;; `call-next-method' for the next pump state, and compare - ;; the new stroke data with the old one. If it has changed, - ;; mark the stroke as dirty and modified. - (let ((old-start-offset (stroke-start-offset stroke)) - (old-end-offset (stroke-end-offset stroke)) - (old-drawing-options (stroke-drawing-options stroke)) - (new-pump-state (call-next-method))) - (unless (and old-start-offset - (= old-start-offset (stroke-start-offset stroke)) - (= old-end-offset (stroke-end-offset stroke)) - (drawing-options-equal old-drawing-options - (stroke-drawing-options stroke))) - (invalidate-stroke stroke :modified t)) - new-pump-state)) (:method ((view drei-syntax-view) stroke pump-state) (stroke-pump-with-syntax view (syntax view) stroke pump-state))) @@ -372,12 +357,23 @@ some point)." (aref (line-strokes line) (1- (line-stroke-count line)))) -(defun put-stroke (view line pump-state) +(defun put-stroke (view line pump-state line-change) "Use `stroke-pump' with `pump-state' to get a new stroke for `view', and add it to the sequence of displayed strokes in -`line'." - (let* ((stroke (line-stroke-information line (line-stroke-count line)))) +`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." + (let* ((stroke (line-stroke-information line (line-stroke-count line))) + (old-start-offset (stroke-start-offset stroke)) + (old-end-offset (stroke-end-offset stroke)) + (old-drawing-options (stroke-drawing-options stroke))) (prog1 (stroke-pump view stroke pump-state) + (unless (and old-end-offset + (= (+ old-start-offset line-change) (stroke-start-offset stroke)) + (= (+ old-end-offset line-change) (stroke-end-offset stroke)) + (drawing-options-equal old-drawing-options + (stroke-drawing-options stroke))) + (invalidate-stroke stroke :modified t)) (incf (line-stroke-count line)) (setf (line-end-offset line) (stroke-end-offset stroke))))) @@ -517,14 +513,15 @@ (let* ((line (line-information view (displayed-lines-count view))) (old-line-height (dimensions-height (line-dimensions line))) (old-line-width (dimensions-width (line-dimensions line))) - (orig-x-offset cursor-x)) + (orig-x-offset cursor-x) + (offset-change (- start-offset (line-start-offset line)))) (setf (line-start-offset line) start-offset (line-stroke-count line) 0) (loop 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) then - (put-stroke view line pump-state) + for pump-state = (put-stroke view line initial-pump-state offset-change) then + (put-stroke view line pump-state offset-change) do (draw-stroke stream view stroke cursor-x cursor-y) (setf cursor-x (x2 stroke-dimensions)) maximizing (dimensions-height stroke-dimensions) into line-height From thenriksen at common-lisp.net Tue Jan 8 19:53:28 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 8 Jan 2008 14:53:28 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080108195328.843D15C16F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv21319/Drei Modified Files: views.lisp Log Message: Made the view mechanisms more capable of handling incremental/lazy parsing. Still haven't been able to create a lazy LR parser. --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/07 22:01:58 1.13 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/08 19:53:28 1.14 @@ -616,24 +616,15 @@ view-syntax (make-syntax-for-view view (class-of view-syntax)) prefix-size 0 suffix-size 0 - buffer-size (size buffer) + buffer-size -1 ; For reparse even if buffer is empty. ;; Also set the top and bot marks. top (make-buffer-mark buffer 0 :left) - bot (make-buffer-mark buffer (size buffer) :right)) - ;; We resynchronize here, instead of delaying a potentially large - ;; reparse until the next time some hapless command (or redisplay - ;; function) needs a parse tree. Force the resynchronisation so - ;; that even if the buffer is empty, `update-syntax' will still be - ;; called. - (synchronize-view view :force-p t))) + bot (make-buffer-mark buffer (size buffer) :right)))) (defmethod (setf syntax) :after (syntax (view drei-syntax-view)) - ;; We need to reparse the buffer completely. Might as well do it - ;; now. (setf (prefix-size view) 0 (suffix-size view) 0 - (buffer-size view) (size (buffer view))) - (synchronize-view view :force-p t)) + (buffer-size view) -1)) (defmethod mode-enabled-p or ((modual drei-syntax-view) mode-name) (mode-enabled-p (syntax modual) mode-name)) @@ -660,10 +651,14 @@ (defmethod synchronize-view :around ((view drei-syntax-view) &key force-p (begin 0) (end (size (buffer view)))) + (assert (>= end begin)) ;; If nothing changed, then don't call the other methods. (let ((high-offset (- (size (buffer view)) (suffix-size view)))) - (when (or (and (>= begin (prefix-size view)) - (>= high-offset end)) + (when (or (and (> begin (prefix-size view)) + (> high-offset begin)) + (and (> end (prefix-size view)) + (or (> end high-offset) + (>= (prefix-size view) begin))) (/= (size (buffer view)) (buffer-size view)) force-p) (call-next-method)))) @@ -687,10 +682,17 @@ (buffer-size view) (size (buffer view))) (multiple-value-bind (parsed-start parsed-end) (update-syntax (syntax view) prefix-size suffix-size begin end) - ;; Not set the proper new values for prefix-size and + (assert (>= parsed-end parsed-start)) + ;; Now set the proper new values for prefix-size and ;; suffix-size. - (setf (prefix-size view) parsed-end - (suffix-size view) (- (size (buffer view)) parsed-start))) + (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) From thenriksen at common-lisp.net Tue Jan 8 21:05:50 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 8 Jan 2008 16:05:50 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080108210550.E8FFC2D1A4@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv9990/Drei Modified Files: lisp-syntax.lisp lr-syntax.lisp views.lisp Log Message: Pretend to to incremental reparse for Lr syntaxes. This required some fixed in the view mechanism, and doesn't affect much yet. Except that I had to disable intelligent package-handling in Lisp syntax. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/07 23:00:51 1.58 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/08 21:05:50 1.59 @@ -1272,8 +1272,9 @@ (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))) + #+nil(when (need-to-update-package-list-p prefix-size suffix-size syntax) + (update-package-list syntax)) + (setf (package-list syntax) nil)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/07 22:55:11 1.13 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/08 21:05:50 1.14 @@ -267,30 +267,31 @@ (print-unreadable-object (mark stream :type t :identity t) (format stream "~s" (offset mark)))) -(defun parse-patch (syntax) +(defun parse-patch (syntax begin end) + (declare (ignore begin)) (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))))))) + (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))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -357,8 +358,7 @@ ;;; update syntax (defmethod update-syntax values-max-min ((syntax lr-syntax-mixin) prefix-size suffix-size - &optional begin end) - (declare (ignore begin end)) + &optional (begin 0) (end (size (buffer syntax)))) (let* ((low-mark-offset prefix-size) (high-mark-offset (- (size (buffer syntax)) suffix-size))) (when (<= low-mark-offset high-mark-offset) @@ -377,8 +377,8 @@ (new-state syntax (parser-state stack-top) stack-top))) - (loop do (parse-patch syntax)))))) - (values 0 (size (buffer syntax)))) + (loop do (parse-patch syntax begin end))))) + (values 0 end))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -496,7 +496,7 @@ (defmethod pump-state-for-offset-with-syntax ((view textual-drei-syntax-view) (syntax lr-syntax-mixin) (offset integer)) - (update-parse syntax 0 offset) + (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) --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/08 19:53:28 1.14 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/08 21:05:50 1.15 @@ -657,8 +657,7 @@ (when (or (and (> begin (prefix-size view)) (> high-offset begin)) (and (> end (prefix-size view)) - (or (> end high-offset) - (>= (prefix-size view) begin))) + (>= (prefix-size view) begin)) (/= (size (buffer view)) (buffer-size view)) force-p) (call-next-method)))) @@ -673,12 +672,14 @@ (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) (if (> begin prefix-size) - prefix-size - end) - (suffix-size view) (if (>= end (- (size (buffer view)) suffix-size)) - (- (size (buffer view)) (prefix-size view)) - suffix-size) + (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) From thenriksen at common-lisp.net Tue Jan 8 21:16:17 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 8 Jan 2008 16:16:17 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080108211617.04C33A17E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv12250/Drei Modified Files: lisp-syntax.lisp Log Message: So, as long as I'm just pretending to be clever at reparsing, I might as well reactivate package handling in the old, inefficient way. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/08 21:05:50 1.59 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/08 21:16:16 1.60 @@ -1209,31 +1209,32 @@ (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))) + (update-parse syntax) (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))))))) + (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 @@ -1272,9 +1273,8 @@ (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)) - #+nil(when (need-to-update-package-list-p prefix-size suffix-size syntax) - (update-package-list syntax)) - (setf (package-list syntax) nil)) + (when (need-to-update-package-list-p prefix-size suffix-size syntax) + (update-package-list syntax))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From thenriksen at common-lisp.net Wed Jan 9 08:55:24 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 9 Jan 2008 03:55:24 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080109085524.F254A7C04D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv30926/Drei Modified Files: lisp-syntax-swine.lisp lisp-syntax.lisp lr-syntax.lisp Log Message: Do less incrementality-pretending in Lr syntax, but be more aware of the possibility in Lisp syntax. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2007/12/16 14:42:07 1.10 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/01/09 08:55:24 1.11 @@ -566,7 +566,7 @@ 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 0 offset) + (update-parse syntax) (let* ((form ;; Find a form with a valid (fboundp) operator. (let ((immediate-form --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/08 21:16:16 1.60 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/09 08:55:24 1.61 @@ -1209,7 +1209,6 @@ (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))) - (update-parse syntax) (flet ((test (x) (let ((start-offset (start-offset x)) (end-offset (end-offset x))) @@ -1249,17 +1248,18 @@ (defun update-package-list (syntax) (setf (package-list syntax) nil) + (update-parse syntax) (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) + :no-error t) 'cl:in-package))))) (extract (x) (let ((designator (second-form (children x)))) (form-to-object syntax designator - :no-error t)))) + :no-error t)))) (with-slots (stack-top) syntax (loop for child in (children stack-top) when (test child) --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/08 21:05:50 1.14 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/09 08:55:24 1.15 @@ -267,8 +267,7 @@ (print-unreadable-object (mark stream :type t :identity t) (format stream "~s" (offset mark)))) -(defun parse-patch (syntax begin end) - (declare (ignore begin)) +(defun parse-patch (syntax) (with-slots (current-state stack-top scan potentially-valid-trees) syntax (parser-step syntax) (finish-output *trace-output*) @@ -359,12 +358,13 @@ (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 + (with-slots (current-state stack-top scan potentially-valid-trees + initial-state) syntax (setf potentially-valid-trees (if (null stack-top) nil @@ -373,12 +373,12 @@ (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 + initial-state (new-state syntax (parser-state stack-top) stack-top))) - (loop do (parse-patch syntax begin end))))) - (values 0 end))) + (loop do (parse-patch syntax))))) + (values 0 (offset (scan syntax))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From thenriksen at common-lisp.net Wed Jan 9 10:20:24 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 9 Jan 2008 05:20:24 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Extensions/Images Message-ID: <20080109102024.2E78728266@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Extensions/Images In directory clnet:/tmp/cvs-serv14506/Extensions/Images Modified Files: gif.lisp Log Message: Handle GIFs with no transparency. --- /project/mcclim/cvsroot/mcclim/Extensions/Images/gif.lisp 2008/01/07 14:18:15 1.2 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/gif.lisp 2008/01/09 10:20:23 1.3 @@ -26,8 +26,9 @@ (pattern-array (make-array (list (skippy:height first-image) (skippy:width first-image)))) (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 (= i (skippy:transparency-index first-image)) + when (and transparency-index (= i transparency-index)) collect +transparent-ink+ else collect (multiple-value-bind (r g b) From thenriksen at common-lisp.net Wed Jan 9 11:14:08 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 9 Jan 2008 06:14:08 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080109111408.4AF5548151@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv28792/Drei Modified Files: lisp-syntax-swine.lisp lisp-syntax.lisp lr-syntax.lisp packages.lisp Log Message: Improved performance of LR syntax, and Lisp syntax's handling of non-character buffer objects. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/01/09 08:55:24 1.11 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/01/09 11:14:08 1.12 @@ -588,7 +588,7 @@ (operands (when (and form (form-list-p form)) (mapcar #'(lambda (operand) (when operand - (form-to-object syntax operand))) + (form-to-object syntax operand :no-error t))) (form-operands syntax form)))) (current-operand-indices (when form (find-operand-info syntax offset form)))) --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/09 08:55:24 1.61 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/09 11:14:08 1.62 @@ -2571,9 +2571,11 @@ (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* ((start-mark (make-buffer-mark (buffer syntax) (start-offset form))) + (end-mark (make-buffer-mark (buffer syntax) (end-offset form)))) (let* ((stream (make-buffer-stream :buffer (buffer syntax) - :start-mark start-mark)) + :start-mark start-mark + :end-mark end-mark)) (object (read-preserving-whitespace stream))) (signal 'reader-invoked :end-mark (point stream) :object object)))) @@ -2920,7 +2922,10 @@ (defmethod form-to-object ((syntax lisp-syntax) (form complete-string-form) &key &allow-other-keys) - (invoke-reader syntax form)) + (if (notany #'literal-object-p (children form)) + (invoke-reader syntax form) + (form-conversion-error + syntax form "String form contains non-character element"))) (defmethod form-to-object ((syntax lisp-syntax) (form function-form) &rest args) (list 'cl:function (apply #'form-to-object syntax (second (children form)) args))) --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/09 08:55:24 1.15 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/09 11:14:08 1.16 @@ -99,6 +99,11 @@ (: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 @@ -378,7 +383,7 @@ (parser-state stack-top) stack-top))) (loop do (parse-patch syntax))))) - (values 0 (offset (scan syntax))))) + (values 0 (size (buffer syntax))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/07 22:55:11 1.37 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/09 11:14:08 1.38 @@ -515,7 +515,7 @@ #:parser-symbol #:parent #:children #:start-offset #:end-offset #:parser-state #:preceding-parse-tree - #:literal-object-mixin + #:literal-object-mixin #:literal-object-p #:define-parser-state #:lexeme #:nonterminal #:action #:new-state #:done From thenriksen at common-lisp.net Wed Jan 9 12:47:31 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 9 Jan 2008 07:47:31 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080109124731.B36F643222@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv19300/Drei Modified Files: drei-redisplay.lisp Log Message: Fixed typo, dispatcer -> dispatcher. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/08 14:52:18 1.23 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/09 12:47:31 1.24 @@ -99,7 +99,7 @@ (ink +foreground-ink+) (style nil)) -(defconstant +default-stroke-drawer-dispatcer+ +(defconstant +default-stroke-drawer-dispatcher+ #'(lambda (stream view stroke cursor-x cursor-y default-drawing-fn) (funcall default-drawing-fn stream view stroke cursor-x cursor-y)) "A simple function of six arguments that simply calls the first @@ -109,7 +109,7 @@ (defstruct drawing-options "A set of options for how to display a stroke." (face (make-face)) - (function +default-stroke-drawer-dispatcer+)) + (function +default-stroke-drawer-dispatcher+)) (defun drawing-options-equal (o1 o2) "Return true if `o1' and `o2' are equal, that is, they specify @@ -123,13 +123,13 @@ (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-dispatcer+)) + +default-stroke-drawer-dispatcher+)) (eq (drawing-options-function o2) - +default-stroke-drawer-dispatcer+)) + +default-stroke-drawer-dispatcher+)) (or (not (eq (drawing-options-function o2) - +default-stroke-drawer-dispatcer+)) + +default-stroke-drawer-dispatcher+)) (eq (drawing-options-function o1) - +default-stroke-drawer-dispatcer+))))) + +default-stroke-drawer-dispatcher+))))) (defconstant +default-drawing-options+ (make-drawing-options) "The default set of drawing options used for strokes when From thenriksen at common-lisp.net Wed Jan 9 16:57:54 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 9 Jan 2008 11:57:54 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080109165754.E272C4322C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv27817 Modified Files: graphics.lisp Log Message: Added draw-design method for patterns. I'm not completely sure that it is correct, but it worked for my test cases. --- /project/mcclim/cvsroot/mcclim/graphics.lisp 2007/07/19 06:52:51 1.58 +++ /project/mcclim/cvsroot/mcclim/graphics.lisp 2008/01/09 16:57:54 1.59 @@ -992,6 +992,11 @@ ;;;; +(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 From thenriksen at common-lisp.net Wed Jan 9 16:59:04 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 9 Jan 2008 11:59:04 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Extensions Message-ID: <20080109165904.C7F024F033@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Extensions In directory clnet:/tmp/cvs-serv28086/Extensions Modified Files: rgb-image.lisp Log Message: Added fixes for drawing of rgb-images so that they properly add output records. --- /project/mcclim/cvsroot/mcclim/Extensions/rgb-image.lisp 2008/01/06 16:05:46 1.3 +++ /project/mcclim/cvsroot/mcclim/Extensions/rgb-image.lisp 2008/01/09 16:59:04 1.4 @@ -44,7 +44,8 @@ (defclass rgb-image-design (design) ((medium :initform nil :initarg :medium) - (image :initarg :image) + (image :reader image + :initarg :image) (medium-data :initform nil))) (defun make-rgb-image-design (image) @@ -71,6 +72,39 @@ (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 @@ -93,15 +127,10 @@ (defgeneric sheet-rgb-data (port sheet &key x y width height)) -;;; Output recording - -(defun draw-image-design* - (medium design &rest options &key x y &allow-other-keys) - (unless (and x y) - (setf (values x y) (clim:stream-cursor-position medium))) - (climi::with-medium-options (medium options) - (medium-draw-image-design* (sheet-medium medium) design x y))) - (defmethod draw-design - (medium (design rgb-image-design) &rest options &key &allow-other-keys) - (apply #'draw-image-design* medium design options)) + (medium (design rgb-image-design) &rest options + &key x y &allow-other-keys) + (unless (and x y) + (setf (values x y) (stream-cursor-position medium))) + (with-medium-options (medium options) + (medium-draw-image-design* medium design x y))) From thenriksen at common-lisp.net Wed Jan 9 17:19:47 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 9 Jan 2008 12:19:47 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20080109171947.D94BD1B13E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv3396/Apps/Listener Modified Files: dev-commands.lisp Log Message: Added Display Image command to Listener. Note that, by default, it only loads the libraries for XPM reading. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2007/09/04 20:45:54 1.43 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/01/09 17:19:47 1.44 @@ -1417,6 +1417,18 @@ ((object 'pathname :prompt "pathname")) (show-file 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) + (handler-case + (with-room-for-graphics () + (draw-design *standard-output* (mcclim-images:load-image image-pathname))) + (mcclim-images:unsupported-image-format (c) + (format t "Image format ~A not recognized" (mcclim-images:image-format c)))) + (format t "No such file: ~A" image-pathname))) + (define-command (com-edit-definition :name "Edit Definition" :command-table lisp-commands :menu t From crhodes at common-lisp.net Wed Jan 9 18:21:44 2008 From: crhodes at common-lisp.net (crhodes) Date: Wed, 9 Jan 2008 13:21:44 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080109182144.971F8111E2@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv23439/Drei Modified Files: syntax.lisp Log Message: Minor documentation-style update: make the default for values-max-min method combination be :most-specific-first, and explicitly make update-syntax use the :most-specific-last method combination. --- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/01/07 22:01:58 1.10 +++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/01/09 18:21:44 1.11 @@ -82,7 +82,7 @@ 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) + (:method-combination values-max-min :most-specific-last) (:method values-max-min ((syntax syntax) (unchanged-prefix integer) (unchanged-suffix integer) &optional (begin 0) (end (- (size (buffer syntax)) unchanged-suffix))) From crhodes at common-lisp.net Wed Jan 9 18:21:44 2008 From: crhodes at common-lisp.net (crhodes) Date: Wed, 9 Jan 2008 13:21:44 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20080109182144.DD32F1603B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv23439/ESA Modified Files: utils.lisp Log Message: Minor documentation-style update: make the default for values-max-min method combination be :most-specific-first, and explicitly make update-syntax use the :most-specific-last method combination. --- /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2008/01/07 22:01:59 1.7 +++ /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2008/01/09 18:21:44 1.8 @@ -234,7 +234,7 @@ array) (define-method-combination values-max-min - (&optional (order ':most-specific-last)) + (&optional (order ':most-specific-first)) ((around (:around)) (before (:before)) (after (:after)) From thenriksen at common-lisp.net Wed Jan 9 19:26:14 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 9 Jan 2008 14:26:14 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080109192614.CF4724322C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv8234/Drei Modified Files: views.lisp Log Message: Start out with a recoreded buffer size of -1 to force reparsing. --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/08 21:05:50 1.15 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/09 19:26:14 1.16 @@ -574,7 +574,7 @@ :documentation "The number of unchanged objects at the end of the buffer.") (%recorded-buffer-size :accessor buffer-size - :initform 0 + :initform -1 :documentation "The size of the buffer the last time the view was synchronized.")) (:documentation "A buffer-view that maintains a parse tree of From thenriksen at common-lisp.net Wed Jan 9 19:27:04 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 9 Jan 2008 14:27:04 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Extensions Message-ID: <20080109192704.F0F024322E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Extensions In directory clnet:/tmp/cvs-serv8355/Extensions Modified Files: rgb-image.lisp Log Message: Fixed some bugs in freeing rgb-images. --- /project/mcclim/cvsroot/mcclim/Extensions/rgb-image.lisp 2008/01/09 16:59:04 1.4 +++ /project/mcclim/cvsroot/mcclim/Extensions/rgb-image.lisp 2008/01/09 19:27:04 1.5 @@ -56,6 +56,9 @@ (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)) @@ -129,8 +132,6 @@ (defmethod draw-design (medium (design rgb-image-design) &rest options - &key x y &allow-other-keys) - (unless (and x y) - (setf (values x y) (stream-cursor-position medium))) + &key (x 0) (y 0) &allow-other-keys) (with-medium-options (medium options) (medium-draw-image-design* medium design x y))) From thenriksen at common-lisp.net Wed Jan 9 19:27:39 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 9 Jan 2008 14:27:39 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Extensions/Images Message-ID: <20080109192739.B77354322E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Extensions/Images In directory clnet:/tmp/cvs-serv8506/Extensions/Images Modified Files: package.lisp Added Files: image-viewer.lisp Log Message: Added image viewer gadget to MCCLIM-IMAGES. --- /project/mcclim/cvsroot/mcclim/Extensions/Images/package.lisp 2008/01/06 08:36:57 1.1 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/package.lisp 2008/01/09 19:27:39 1.2 @@ -24,4 +24,5 @@ (:use :clim-lisp :clim) (:export :export #:image-format-supported #:load-image #:load-image-of-format - #:unsupported-image-format #:image-format)) + #:unsupported-image-format #:image-format + #:image-viewer #:image-viewer-pane)) --- /project/mcclim/cvsroot/mcclim/Extensions/Images/image-viewer.lisp 2008/01/09 19:27:39 NONE +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/image-viewer.lisp 2008/01/09 19:27:39 1.1 ;;; -*- Mode: Lisp; Package: MCCLIM-IMAGES -*- ;;; (c) copyright 2008 by ;;; Troels Henriksen (athas at 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 image viewer gadget. It would be nice if it could modify ;;; its space requirements to fit the image, but MCCLIM-IMAGES does ;;; not provide this functionality. (in-package :mcclim-images) (defclass image-viewer (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) &key &allow-other-keys) (handle-repaint gadget (or (pane-viewport-region gadget) (sheet-region gadget)))) (defclass image-viewer-pane (image-viewer 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) (draw-design pane (gadget-value pane)))) From thenriksen at common-lisp.net Wed Jan 9 22:12:59 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 9 Jan 2008 17:12:59 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080109221259.B76283C085@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv10967/Drei Modified Files: lisp-syntax-swank.lisp Log Message: "Gracefully" handle older Swanks. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swank.lisp 2007/12/19 01:19:26 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swank.lisp 2008/01/09 22:12:59 1.10 @@ -30,8 +30,11 @@ ;; We need these modules loaded. (eval-when (:compile-toplevel :load-toplevel :execute) - (swank:swank-require :swank-c-p-c) - (swank:swank-require :swank-arglists)) + ;; 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. From thenriksen at common-lisp.net Wed Jan 9 22:15:50 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 9 Jan 2008 17:15:50 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080109221550.166D2111DC@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv11294/Drei Modified Files: lisp-syntax-swank.lisp Log Message: Use internal symbols for swank-require. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swank.lisp 2008/01/09 22:12:59 1.10 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swank.lisp 2008/01/09 22:15:49 1.11 @@ -33,8 +33,8 @@ ;; 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))) + (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. From thenriksen at common-lisp.net Thu Jan 10 09:38:09 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 10 Jan 2008 04:38:09 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080110093809.44CEF81001@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv23328 Modified Files: mcclim.asd Log Message: Fixed ASDF system for MCCLIM-IMAGES. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/01/07 22:55:11 1.73 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/01/10 09:38:07 1.74 @@ -554,7 +554,8 @@ :components ((:module "Extensions/Images" :pathname #.(make-pathname :directory '(:relative "Extensions" "Images")) :components ((:file "package") - (:file "images"))))) + (:file "images" :depends-on ("package")) + (:file "image-viewer" :depends-on ("images")))))) (defmacro support-format (format &rest depends-on) "Generate the ASDF `defsystem' form for a single-file system From thenriksen at common-lisp.net Thu Jan 10 11:03:39 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 10 Jan 2008 06:03:39 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/Tests Message-ID: <20080110110339.CD9A243218@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv14058/Drei/Tests Modified Files: lisp-syntax-tests.lisp Log Message: Made the Lisp syntax test suite explicitly call update-parse before munging around in internal data. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2008/01/05 21:07:16 1.11 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2008/01/10 11:03:39 1.12 @@ -53,6 +53,7 @@ (get-object (&rest args) (apply #'form-to-object (current-syntax) (get-form) args))) + (update-parse (current-syntax)) , at body))))))) (defmacro swine-test (name &body body) From thenriksen at common-lisp.net Thu Jan 10 11:17:00 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 10 Jan 2008 06:17:00 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080110111700.5546F240CF@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv16670/Drei Modified Files: lisp-syntax-swine.lisp lisp-syntax.lisp packages.lisp Log Message: Cleaned up form-operator, form-operands, added form-equal. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/01/09 11:14:08 1.12 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/01/10 11:17:00 1.13 @@ -566,7 +566,7 @@ 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) + (update-parse syntax 0 offset) (let* ((form ;; Find a form with a valid (fboundp) operator. (let ((immediate-form @@ -584,12 +584,12 @@ ;; 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 syntax 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 :no-error t))) - (form-operands syntax form)))) + (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))) --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/09 11:14:08 1.62 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/10 11:17:00 1.63 @@ -1212,28 +1212,28 @@ (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))))))) + (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 @@ -1248,18 +1248,17 @@ (defun update-package-list (syntax) (setf (package-list syntax) nil) - (update-parse syntax) (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) + :no-error t) 'cl:in-package))))) (extract (x) (let ((designator (second-form (children x)))) (form-to-object syntax designator - :no-error t)))) + :no-error t)))) (with-slots (stack-top) syntax (loop for child in (children stack-top) when (test child) @@ -1351,26 +1350,26 @@ "Return the children of `form' that are themselves forms." (remove-if-not #'formp (children form))) -(defgeneric form-operator (syntax form) +(defgeneric form-operator (form) (:documentation "Return the operator of `form' as a - token. Returns nil if none can be found.") - (:method (form syntax) nil)) +token. Returns nil if none can be found.") + (:method (form) nil)) -(defmethod form-operator (syntax (form list-form)) +(defmethod form-operator ((form list-form)) (first-form (rest (children form)))) -(defmethod form-operator (syntax (form complete-quote-form)) +(defmethod form-operator ((form complete-quote-form)) (first-form (rest (children (second (children form)))))) -(defmethod form-operator (syntax (form complete-backquote-form)) +(defmethod form-operator ((form complete-backquote-form)) (first-form (rest (children (second (children form)))))) -(defgeneric form-operands (syntax form) +(defgeneric form-operands (form) (:documentation "Returns the operands of `form' as a list of tokens. Returns nil if none can be found.") - (:method (form syntax) nil)) + (:method (syntax) nil)) -(defmethod form-operands (syntax (form list-form)) +(defmethod form-operands ((form list-form)) (remove-if-not #'formp (rest-forms (children form)))) (defun form-toplevel (syntax form) @@ -2341,15 +2340,16 @@ 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, NIL will be returned in its -place." +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 (find-package package-name)) + (package-name (or (find-package package-name) + package-name)) (t package)))) (multiple-value-bind (symbol status) - (when package + (when (packagep package) (find-symbol symbol-name package)) (if (or symbol status) (values symbol package status) @@ -2571,11 +2571,9 @@ (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))) - (end-mark (make-buffer-mark (buffer syntax) (end-offset form)))) + (let* ((start-mark (make-buffer-mark (buffer syntax) (start-offset form)))) (let* ((stream (make-buffer-stream :buffer (buffer syntax) - :start-mark start-mark - :end-mark end-mark)) + :start-mark start-mark)) (object (read-preserving-whitespace stream))) (signal 'reader-invoked :end-mark (point stream) :object object)))) @@ -2892,7 +2890,7 @@ (multiple-value-bind (symbol package status) (parse-symbol (form-string syntax form) :package *package* :case case) - (values (cond ((and read (null status)) + (values (cond ((and read (null status) (packagep package)) (intern (symbol-name symbol) package)) (t symbol))))) @@ -2922,10 +2920,7 @@ (defmethod form-to-object ((syntax lisp-syntax) (form complete-string-form) &key &allow-other-keys) - (if (notany #'literal-object-p (children form)) - (invoke-reader syntax form) - (form-conversion-error - syntax form "String form contains non-character element"))) + (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))) @@ -3027,6 +3022,51 @@ (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. --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/09 11:14:08 1.38 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/10 11:17:00 1.39 @@ -515,7 +515,7 @@ #:parser-symbol #:parent #:children #:start-offset #:end-offset #:parser-state #:preceding-parse-tree - #:literal-object-mixin #:literal-object-p + #:literal-object-mixin #:define-parser-state #:lexeme #:nonterminal #:action #:new-state #:done @@ -534,7 +534,7 @@ #:lisp-string #:edit-definition #:form - #:form-to-object + #:form-to-object #:form-equal ;; Selecting forms based on mark #:form-around #:form-before #:form-after From thenriksen at common-lisp.net Fri Jan 11 02:44:12 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 10 Jan 2008 21:44:12 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/Tests Message-ID: <20080111024412.00CAD5B069@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv24404/Drei/Tests Modified Files: testing.lisp Log Message: Changed the Drei/ESA modes-idea to work through metaclasses, enabling default modes. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/testing.lisp 2007/12/08 08:53:48 1.7 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/testing.lisp 2008/01/11 02:44:12 1.8 @@ -88,6 +88,7 @@ () (: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 "") From thenriksen at common-lisp.net Fri Jan 11 02:44:13 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 10 Jan 2008 21:44:13 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080111024413.DADFD5C16F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv24404/Drei Modified Files: drei-clim.lisp drei.lisp syntax.lisp views.lisp Log Message: Changed the Drei/ESA modes-idea to work through metaclasses, enabling default modes. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/02 09:20:26 1.27 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/11 02:44:13 1.28 @@ -158,6 +158,7 @@ :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.")) @@ -209,6 +210,7 @@ (%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.")) @@ -336,6 +338,7 @@ 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.")) + (:metaclass modual-class) (:default-initargs :command-executor 'execute-drei-command) (:documentation "A Drei editable area implemented as an output record.")) --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2007/12/28 10:08:28 1.24 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/11 02:44:13 1.25 @@ -219,7 +219,7 @@ ;;; ;;; The basic Drei class. -(defclass drei (modual-mixin) +(defclass drei () ((%view :initform (make-instance 'textual-drei-syntax-view) :initarg :view :accessor view @@ -274,6 +274,7 @@ (%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 --- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/01/09 18:21:44 1.11 +++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/01/11 02:44:13 1.12 @@ -22,7 +22,7 @@ (in-package :drei-syntax) -(defclass syntax (name-mixin modual-mixin) +(defclass syntax (name-mixin) ((%buffer :initarg :buffer :reader buffer) (%command-table :initarg :command-table :initform (error "A command table has not been provided for this syntax") @@ -30,6 +30,7 @@ (%updater-fns :initarg :updater-fns :initform '() :accessor updater-fns)) + (:metaclass modual-class) (:documentation "The base class for all syntaxes.")) (defgeneric syntax-command-tables (syntax) @@ -287,6 +288,7 @@ ;; It must be just a command table. (find-command-table ,command-table)))))) default-initargs) + (:metaclass modual-class) , at defclass-options)))) (defgeneric eval-option (syntax name value) --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/09 19:26:14 1.16 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/11 02:44:13 1.17 @@ -403,7 +403,7 @@ ;;; ;;; View classes. -(defclass drei-view (tabify-mixin subscriptable-name-mixin modual-mixin) +(defclass drei-view (tabify-mixin subscriptable-name-mixin) ((%active :accessor active :initform t :initarg :active @@ -436,6 +436,7 @@ `editor-table' - the command tables containing the editor commands will be added automatically, as long as this value is true.")) + (:metaclass modual-class) (:documentation "The base class for all Drei views. A view observes some other object and provides a visual representation for Drei.") @@ -530,6 +531,7 @@ :documentation "The number of lines in the views `displayed-lines' array that are actually live, that is, used for display right now.")) + (:metaclass modual-class) (:documentation "A view that contains a `drei-buffer' object.")) @@ -577,6 +579,7 @@ :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.")) @@ -725,6 +728,7 @@ (defclass point-mark-view (drei-buffer-view) ((%point :initform nil :initarg :point :accessor point-of) (%mark :initform nil :initarg :mark :accessor mark-of)) + (:metaclass modual-class) (:documentation "A view class containing a point and a mark into its buffer.")) @@ -758,6 +762,7 @@ (%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)) (defmethod create-view-cursors nconc ((output-stream extended-output-stream) From thenriksen at common-lisp.net Fri Jan 11 02:44:14 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 10 Jan 2008 21:44:14 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20080111024414.2695F690E2@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv24404/ESA Modified Files: packages.lisp utils.lisp Log Message: Changed the Drei/ESA modes-idea to work through metaclasses, enabling default modes. --- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/01/07 22:01:59 1.10 +++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/01/11 02:44:14 1.11 @@ -23,7 +23,7 @@ ;;; Package definitions for ESA. (defpackage :esa-utils - (:use :clim-lisp) + (:use :clim-lisp :clim-mop) (:export #:with-gensyms #:once-only #:unlisted @@ -50,7 +50,7 @@ #:observer-notified #:notify-observers #:name-mixin #:name #:subscriptable-name-mixin #:subscripted-name #:subscript #:subscript-generator - #:mode #:modual-mixin + #:mode #:modual-class #:available-modes #:mode-directly-applicable-p #:mode-applicable-p #:mode-enabled-p @@ -58,7 +58,8 @@ #:nonapplicable-mode #:change-class-for-enabled-mode #:change-class-for-disabled-mode - #:enable-mode #:disable-mode)) + #:enable-mode #:disable-mode + #:add-default-modes #:remove-default-modes)) (defpackage :esa (:use :clim-lisp :clim :esa-utils) --- /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2008/01/09 18:21:44 1.8 +++ /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2008/01/11 02:44:14 1.9 @@ -364,23 +364,61 @@ () (:documentation "A superclass for all modes.")) -(defclass modual-mixin () - ((%original-class-name :accessor original-class-name - :documentation "The original name of the -class the `modual-mixin' is part of, the actual name will change -as modes are added and removed.")) - (:documentation "A mixin for objects supporting 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)) -(defmethod initialize-instance :after ((object modual-mixin) &rest initargs) +(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)) - (setf (original-class-name object) (class-name (class-of object)))) + (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 modual-mixin)) + (:method append ((modual t)) '())) (defgeneric mode-directly-applicable-p (modual mode-name) @@ -391,7 +429,7 @@ \"opt-out\" where a mode can forcefully prevent another specific mode from being enabled. ") (:method-combination or) - (:method or ((modual modual-mixin) mode-name) + (:method or ((modual t) mode-name) nil)) (defgeneric mode-applicable-p (modual mode-name) @@ -402,21 +440,21 @@ a sort of \"opt-out\" where a mode can forcefully prevent another specific mode from being enabled. ") (:method-combination or) - (:method or ((modual modual-mixin) mode-name) + (: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-combination append) - (:method append ((modual modual-mixin)) + (:method append ((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 modual-mixin) mode-name) + (:method or ((modual t) mode-name) (member mode-name (enabled-modes modual) :test #'equal))) (define-condition nonapplicable-mode (error) @@ -445,7 +483,7 @@ `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 modual-mixin) mode-name &rest initargs) + (:method :around ((modual t) mode-name &rest initargs) (declare (ignore initargs)) (unless (mode-enabled-p modual mode-name) (call-next-method)))) @@ -454,7 +492,7 @@ (: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 modual-mixin) mode-name) + (:method :around ((modual t) mode-name) (when (mode-enabled-p modual mode-name) (call-next-method)))) @@ -478,7 +516,8 @@ ;; Avert thine eyes, thy of gentle spirit. (if (null modes) (find-class modual) - (eval `(defclass ,(gensym) (,modual , at modes) ())))) + (eval `(defclass ,(gensym) (,modual , at modes) () + (:metaclass modual-class))))) (defun find-class-implementing-modes (modual modes) "Find, possibly create, the class implementing `modual' (a @@ -498,7 +537,7 @@ "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 - (original-class-name modual) + (slot-value modual '%original-class-name) (cons mode-name (enabled-modes modual))) initargs)) @@ -506,15 +545,44 @@ "Change the class of `modual' so that it does not have a mode of name `mode-name'." (change-class modual (find-class-implementing-modes - (original-class-name modual) + (slot-value modual '%original-class-name) (remove mode-name (enabled-modes modual) :test #'equal)))) -(defmethod enable-mode ((modual modual-mixin) mode-name &rest initargs) +(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 modual-mixin) 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)))) From thenriksen at common-lisp.net Fri Jan 11 02:44:14 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 10 Jan 2008 21:44:14 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080111024414.622A96F23F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv24404 Modified Files: text-editor-gadget.lisp Log Message: Changed the Drei/ESA modes-idea to work through metaclasses, enabling default modes. --- /project/mcclim/cvsroot/mcclim/text-editor-gadget.lisp 2007/10/26 17:01:15 1.10 +++ /project/mcclim/cvsroot/mcclim/text-editor-gadget.lisp 2008/01/11 02:44:14 1.11 @@ -90,6 +90,7 @@ (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) @@ -101,6 +102,7 @@ (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) @@ -123,6 +125,7 @@ (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) From thenriksen at common-lisp.net Fri Jan 11 05:55:53 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 11 Jan 2008 00:55:53 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20080111055553.256C6A18D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv871/Backends/CLX Modified Files: medium.lisp Log Message: Draw images from the upper-left corner in the CLX backend. Strange sense of deja-vu. Didn't I fix this already? --- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2008/01/06 01:37:06 1.83 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2008/01/11 05:55:52 1.84 @@ -1200,10 +1200,10 @@ :clip-x x :clip-y (- y height)) (xlib:copy-area pixmap gcontext 0 0 width height - da x (- y height)))) + da x y))) (t (xlib:copy-area pixmap gcontext 0 0 width height - da x (- y height))))))))) + da x y)))))))) (defmethod climi::medium-free-image-design ((medium clx-medium) (design climi::rgb-image-design)) From thenriksen at common-lisp.net Fri Jan 11 06:00:06 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 11 Jan 2008 01:00:06 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20080111060006.16DF4111CF@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv2033/Apps/Listener Modified Files: dev-commands.lisp Log Message: Changed MCCLIM-IMAGES:LOAD-IMAGE to create an instance of an image class containing size information. Fixex JPEG reading. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/01/09 17:19:47 1.44 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/01/11 06:00:04 1.45 @@ -1424,7 +1424,7 @@ (if (probe-file image-pathname) (handler-case (with-room-for-graphics () - (draw-design *standard-output* (mcclim-images:load-image image-pathname))) + (mcclim-images:draw-image *standard-output* (mcclim-images:load-image image-pathname))) (mcclim-images:unsupported-image-format (c) (format t "Image format ~A not recognized" (mcclim-images:image-format c)))) (format t "No such file: ~A" image-pathname))) From thenriksen at common-lisp.net Fri Jan 11 06:00:07 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 11 Jan 2008 01:00:07 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Extensions/Images Message-ID: <20080111060007.C7C172510F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Extensions/Images In directory clnet:/tmp/cvs-serv2033/Extensions/Images Modified Files: gif.lisp image-viewer.lisp images.lisp jpeg.lisp package.lisp xpm.lisp Log Message: Changed MCCLIM-IMAGES:LOAD-IMAGE to create an instance of an image class containing size information. Fixex JPEG reading. --- /project/mcclim/cvsroot/mcclim/Extensions/Images/gif.lisp 2008/01/09 10:20:23 1.3 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/gif.lisp 2008/01/11 06:00:06 1.4 @@ -23,10 +23,11 @@ (define-image-reader "gif" (image-pathname &key) (let* ((data-stream (skippy:load-data-stream image-pathname)) (first-image (aref (skippy:images data-stream) 0)) - (pattern-array (make-array (list (skippy:height first-image) - (skippy:width first-image)))) + (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) + 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+ @@ -35,7 +36,8 @@ (skippy:color-rgb (skippy:color-table-entry color-table i)) (make-rgb-color (/ r 255) (/ g 255) (/ b 255)))) 'vector))) - (dotimes (y (array-dimension pattern-array 0)) - (dotimes (x (array-dimension pattern-array 1)) + (dotimes (y image-height) + (dotimes (x image-width) (setf (aref pattern-array y x) (skippy:pixel-ref first-image x y)))) - (make-pattern pattern-array designs))) + (make-image (make-pattern pattern-array designs) + image-height image-width))) --- /project/mcclim/cvsroot/mcclim/Extensions/Images/image-viewer.lisp 2008/01/09 19:27:39 1.1 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/image-viewer.lisp 2008/01/11 06:00:06 1.2 @@ -45,6 +45,10 @@ ;; 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) - (draw-design pane (gadget-value pane)))) + ;; Try to ensure there is room for the new image. + (change-space-requirements pane + :height (image-height (gadget-value pane)) + :width (image-width (gadget-value pane))) + ;; Draw the new one, if there is one. + (draw-image pane (gadget-value pane)))) --- /project/mcclim/cvsroot/mcclim/Extensions/Images/images.lisp 2008/01/06 08:36:57 1.1 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/images.lisp 2008/01/11 06:00:06 1.2 @@ -27,7 +27,7 @@ file to be read, and any keyword arguments provided by the user.") -(defun image-format-supported (format) +(defun image-format-supported-p (format) "Return true if `format' is supported by `load-image'." (not (null (gethash format *image-readers*)))) @@ -49,18 +49,42 @@ image format `format'." (error 'unsupported-image-format :image-format format)) +(defclass image () + ((%image-design :reader image-design + :initarg :image-design + :initform (error "A design must be provided for the image")) + (%width :reader image-width + :initarg :image-width + :initform (error "A width must be provided for the image")) + (%height :reader image-height + :initarg :image-height + :initform (error "A width must be provided for the image")))) + +(defun make-image (design height width) + "Make and return an instance of `image' with the specified +`design', `width' and `height'." + (make-instance 'image :image-design design + :image-height height + :image-width width)) + +(defun draw-image (stream image) + "Draw `image' to `stream'. `Stream' must be a sufficiently +powerful output stream (probably an `extended-output-stream')." + (draw-design stream (image-design image))) + (defun load-image (image-pathname &rest args &key) "Load an image from `image-pathname', with the format of the -image being the pathname-type of `image-pathname'. `Args' can be -any keyword-arguments, they will be passed on to the image reader -function for the relevant image format. If the image format is -not recognised, an error of type `unsupprted-image-format' will -be signalled." +image being the pathname-type of `image-pathname'. Returns an +instance of class `image'. `Args' can be any keyword-arguments, +they will be passed on to the image reader function for the +relevant image format. If the image format is not recognised, an +error of type `unsupprted-image-format' will be signalled." (apply #'load-image-of-format (pathname-type image-pathname) image-pathname args)) (defun load-image-of-format (format image-pathname &rest args &key) - "Load an image of format `format' from `image-pathname'. `Args' + "Load an image of format `format' from +`image-pathname'. Returns an instance of class `image'. `Args' can be any keyword-arguments, they will be passed on to the image reader function for `format'. If the image format is not recognised, an error of type `unsupprted-image-format' will be --- /project/mcclim/cvsroot/mcclim/Extensions/Images/jpeg.lisp 2008/01/07 12:54:02 1.2 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/jpeg.lisp 2008/01/11 06:00:06 1.3 @@ -31,15 +31,18 @@ (rgb-image (make-instance 'clim-internals::rgb-image :width width :height height :alphap nil :data rgb-image-data))) - (loop for y from (1- height) downto 0 do - (loop for x from (1- width) downto 0 do - (let ((grey (svref rgb (+ x (* y width))))) - (setf (aref rgb-image-data y x) - (dpb grey (byte 8 0) - (dpb grey (byte 8 8) - (dpb grey (byte 8 16) - (dpb (- 255 0) (byte 8 24) 0)))))))) - (clim-internals::make-rgb-image-design rgb-image))))) + (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 rgb-image-data y x) + (dpb red (byte 8 0) + (dpb green (byte 8 8) + (dpb blue (byte 8 16) + (dpb (- 255 0) (byte 8 24) 0)))))))) + (make-image (clim-internals::make-rgb-image-design rgb-image) + height width))))) (define-image-reader "jpg" (pathname) (load-image-of-format "jpeg" pathname)) --- /project/mcclim/cvsroot/mcclim/Extensions/Images/package.lisp 2008/01/09 19:27:39 1.2 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/package.lisp 2008/01/11 06:00:06 1.3 @@ -22,7 +22,9 @@ (defpackage :mcclim-images (:use :clim-lisp :clim) - (:export :export #:image-format-supported + (:export #:image-format-supported-p + #:image #:image-width #:image-height + #:draw-image #:load-image #:load-image-of-format #:unsupported-image-format #:image-format #:image-viewer #:image-viewer-pane)) --- /project/mcclim/cvsroot/mcclim/Extensions/Images/xpm.lisp 2008/01/06 08:36:57 1.1 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/xpm.lisp 2008/01/11 06:00:06 1.2 @@ -442,7 +442,10 @@ (define-image-reader "xpm" (pathname &key) (with-open-file (input pathname :element-type '(unsigned-byte 8)) - (xpm-parse-stream input))) + (let ((pattern (xpm-parse-stream input))) + (make-image pattern + (pattern-height pattern) + (pattern-width pattern))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From thenriksen at common-lisp.net Fri Jan 11 06:01:38 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 11 Jan 2008 01:01:38 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080111060138.782B61603E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv4196 Modified Files: NEWS Log Message: Added mention of MCCLIM-IMAGES to NEWS. --- /project/mcclim/cvsroot/mcclim/NEWS 2007/11/21 22:33:50 1.27 +++ /project/mcclim/cvsroot/mcclim/NEWS 2008/01/11 06:01:38 1.28 @@ -4,6 +4,8 @@ ** Bug fix: Some missing methods and functions have been implemented for the Null backend, allowing headless operation for many applications. +** New extension: MCCLIM-IMAGES. This extension makes it easy to use + McCLIM for loading and displaying images of various formats. * Changes in mcclim-0.9.5 relative to 0.9.4: ** Installation: the systems clim-listener, clim-examples, From thenriksen at common-lisp.net Fri Jan 11 07:52:04 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 11 Jan 2008 02:52:04 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080111075204.1946D25113@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv22161/Drei Modified Files: lisp-syntax-swine.lisp lisp-syntax.lisp Log Message: Never, ever, try to do lazy parsing in Lisp syntax, the potential for disaster is just too great. Changed all calls to update-parse to make sure the entire parse tree is up to date. Later specializations can be considered optimisation. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/01/10 11:17:00 1.13 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/01/11 07:52:03 1.14 @@ -566,7 +566,7 @@ 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 0 offset) + (update-parse syntax) (let* ((form ;; Find a form with a valid (fboundp) operator. (let ((immediate-form --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/10 11:17:00 1.63 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/11 07:52:03 1.64 @@ -1161,7 +1161,7 @@ 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 0 offset) + (update-parse syntax) (let* ((designator (rest (find offset (package-list syntax) :key #'first :test #'>=)))) @@ -1183,7 +1183,7 @@ 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 0 offset) + (update-parse syntax) (flet ((normalise (designator) (typecase designator (symbol @@ -1421,7 +1421,7 @@ "Return the list form that `mark-or-offset' is inside, or NIL if no such form exists." (as-offsets ((offset mark-or-offset)) - (update-parse syntax 0 offset) + (update-parse syntax) (let ((form-around (form-around syntax offset))) (when form-around (if (and (form-list-p form-around) @@ -1559,7 +1559,7 @@ (defun in-type-p (syntax mark-or-offset type) (as-offsets ((offset mark-or-offset)) - (update-parse syntax 0 offset) + (update-parse syntax) (with-slots (stack-top) syntax (if (or (null (start-offset stack-top)) (> offset (end-offset stack-top)) @@ -1626,7 +1626,7 @@ (:method ((syntax lisp-syntax) (form form) (offset integer)) nil) (:method :before ((syntax lisp-syntax) (form form) (offset integer)) - (update-parse syntax 0 offset))) + (update-parse syntax))) (defgeneric at-end-of-form-p (syntax form offset) (:documentation "Return true if `offset' is at the end of the @@ -1634,7 +1634,7 @@ (:method ((syntax lisp-syntax) (form form) (offset integer)) nil) (:method :before ((syntax lisp-syntax) (form form) (offset integer)) - (update-parse syntax 0 offset))) + (update-parse syntax))) (defmethod at-beginning-of-form-p ((syntax lisp-syntax) (form list-form) (offset integer)) @@ -1666,7 +1666,7 @@ 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 0 offset) + (update-parse syntax) (let ((form-around (form-around syntax offset))) (when form-around (labels ((recurse (form) @@ -1681,7 +1681,7 @@ 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 0 offset) + (update-parse syntax) (let ((form-around (form-around syntax offset))) (when form-around (labels ((recurse (form) @@ -1696,7 +1696,7 @@ 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 0 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))))) @@ -1707,7 +1707,7 @@ 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 0 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))))) @@ -1717,7 +1717,7 @@ beginning of a string form, false otherwise. \"Beginning\" is right after the opening double-quote." (as-offsets ((offset mark-or-offset)) - (update-parse syntax 0 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))))) @@ -1727,7 +1727,7 @@ a list-like form, false otherwise. \"End\" is right before the ending double-quote." (as-offsets ((offset mark-or-offset)) - (update-parse syntax 0 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))))) @@ -1882,7 +1882,7 @@ ;;; exploit the parse (defun form-before-in-children (syntax children offset) - (update-parse syntax 0 offset) + (update-parse syntax) (loop for (first . rest) on children if (formp first) do @@ -1910,7 +1910,7 @@ "Offset past buffer end") (assert (>= offset 0) nil "Offset before buffer start") - (update-parse syntax 0 offset) + (update-parse syntax) (or (gethash offset (form-before-cache syntax)) (setf (gethash offset (form-before-cache syntax)) (with-slots (stack-top) syntax @@ -1920,7 +1920,7 @@ (form-before-in-children syntax (children stack-top) offset)))))) (defun form-after-in-children (syntax children offset) - (update-parse syntax 0 offset) + (update-parse syntax) (loop for child in children if (formp child) do (cond ((< (start-offset child) offset (end-offset child)) @@ -1943,7 +1943,7 @@ "Offset past buffer end") (assert (>= offset 0) nil "Offset before buffer start") - (update-parse syntax 0 offset) + (update-parse syntax) (or (gethash offset (form-after-cache syntax)) (setf (gethash offset (form-after-cache syntax)) (with-slots (stack-top) syntax @@ -1953,7 +1953,7 @@ (form-after-in-children syntax (children stack-top) offset)))))) (defun form-around-in-children (syntax children offset) - (update-parse syntax 0 offset) + (update-parse syntax) (loop for child in children if (formp child) do (cond ((or (<= (start-offset child) offset (end-offset child)) @@ -1972,7 +1972,7 @@ "Offset past buffer end") (assert (>= offset 0) nil "Offset before buffer start") - (update-parse syntax 0 offset) + (update-parse syntax) (or (gethash offset (form-around-cache syntax)) (setf (gethash offset (form-around-cache syntax)) (with-slots (stack-top) syntax From thenriksen at common-lisp.net Sat Jan 12 10:52:24 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 12 Jan 2008 05:52:24 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080112105224.6FC8B6914A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv29151/Drei Modified Files: lisp-syntax.lisp Log Message: Make Drei forward-expression handle #+foo whatever properly through the magic of special cases. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/11 07:52:03 1.64 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/12 10:52:24 1.65 @@ -2036,7 +2036,12 @@ (form-around syntax (offset mark))))) (when (and (not (null potential-form)) (not (= (offset mark) (end-offset potential-form)))) - (setf (offset mark) (end-offset potential-form))))) + (typecase potential-form + (reader-conditional-form + (setf (offset mark) (end-offset + (or (first-form (children potential-form)) + 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)) From thenriksen at common-lisp.net Sat Jan 12 11:04:08 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 12 Jan 2008 06:04:08 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080112110408.76F077323B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv334 Modified Files: package.lisp views.lisp Log Message: Added stub classes and constants for gadget views. Programs using these will at least compile now, though they may not work. Hopefully, this batch of stub views will be like a sad puppy in the corner, sooner or later guilting someone into finishing the implementation. --- /project/mcclim/cvsroot/mcclim/package.lisp 2007/11/19 20:28:44 1.63 +++ /project/mcclim/cvsroot/mcclim/package.lisp 2008/01/12 11:04:05 1.64 @@ -873,6 +873,8 @@ #:line-style-unit ;generic function #:linep ;predicate #:list-pane ;class + #:list-pane-view ;class + #:+list-pane-view+ ;constant #:lookup-keystroke-command-item ;function #:lookup-keystroke-item ;function #:make-3-point-transformation ;function @@ -1039,6 +1041,8 @@ #:open-stream-p ;generic function #:open-window-stream ;function #:option-pane ;class + #:option-pane-view ;class + #:+option-pane-view+ ;constant #:or ;presentation type #:oriented-gadget-mixin ;class #:outlined-pane ;pane @@ -1167,6 +1171,8 @@ #:propagate-output-record-changes-p ;generic function #:push-button ;class #:push-button-pane ;class + #:push-button-view ;class + #:+push-button-view+ ;constant #:push-button-show-as-default ;generic function #:queue-event ;generic function #:queue-repaint ;generic function @@ -1175,6 +1181,8 @@ #:radio-box-current-selection ;generic function #:radio-box-pane ;class #:radio-box-selections ;generic function + #:radio-box-view ;class + #:+radio-box-view+ ;class #:raise-frame ;generic function #:raise-mirror ;generic function #:raise-sheet ;generic function @@ -1313,6 +1321,8 @@ #:slider ;class #:slider-drag-callback ;generic function #:slider-pane ;class + #:slider-view ;slider-view + #:+slider-view+ ;constant #:space-requirement ;class #:space-requirement+ ;function #:space-requirement+* ;function @@ -1464,6 +1474,8 @@ #:text-displayed-output-record-string ;generic function #:text-editor ;class #:text-editor-pane ;class + #:text-editor-view ;class + #:+text-editor-view+ ;constant #:text-field ;class #:text-field-pane ;class #:text-field-view ;class (Franz User's Guide) @@ -1489,6 +1501,8 @@ #:toggle-button ;class #:toggle-button-indicator-type ;generic function #:toggle-button-pane ;class + #:toggle-button-view ;class + #:+toggle-button-view+ ;constant #:token-or-type ;presentation type abbrev #:tracking-pointer ;macro #:transform-distance ;generic function --- /project/mcclim/cvsroot/mcclim/views.lisp 2006/03/10 21:58:13 1.7 +++ /project/mcclim/cvsroot/mcclim/views.lisp 2008/01/12 11:04:05 1.8 @@ -42,11 +42,35 @@ (defclass pointer-documentation-view (textual-view) ()) -;;; Views described in the Franz User manual... +;;; 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)) @@ -59,11 +83,24 @@ (defparameter +gadget-dialog-view+ (make-instance 'gadget-dialog-view)) -(defparameter +pointer-documentation-view+ - (make-instance 'pointer-documentation-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+) From thenriksen at common-lisp.net Sat Jan 12 11:37:20 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 12 Jan 2008 06:37:20 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/Tests Message-ID: <20080112113720.0531832016@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv6351/Drei/Tests Modified Files: lisp-syntax-tests.lisp Log Message: Changed the semantics for expression movement (now not identical to Emacs). --- /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2008/01/10 11:03:39 1.12 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2008/01/12 11:37:20 1.13 @@ -825,9 +825,9 @@ (51 0 (11 28 7) "(defun list (&rest elements) (append elements nil))") - (nil nil (5 18 9) + (nil nil (5 18 2) "#+nil (list 1 2 3)") - (nil nil (0 5 nil) + (nil nil (0 2 nil) "#+nil (list 1 2 3)")) (motion-fun-one-test (list lisp-syntax) From thenriksen at common-lisp.net Sat Jan 12 11:37:21 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 12 Jan 2008 06:37:21 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080112113721.D655C3F011@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv6351/Drei Modified Files: lisp-syntax.lisp Log Message: Changed the semantics for expression movement (now not identical to Emacs). --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/12 10:52:24 1.65 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/12 11:37:21 1.66 @@ -2038,9 +2038,8 @@ (not (= (offset mark) (end-offset potential-form)))) (typecase potential-form (reader-conditional-form - (setf (offset mark) (end-offset - (or (first-form (children potential-form)) - potential-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) From thenriksen at common-lisp.net Sat Jan 12 11:44:56 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 12 Jan 2008 06:44:56 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080112114456.AADCE5611D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv8770/Drei Modified Files: drawing-options.lisp Log Message: Change to some prettier (IMO) syntax highlighting colours than default Emacs. --- /project/mcclim/cvsroot/mcclim/Drei/drawing-options.lisp 2008/01/07 23:00:51 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/drawing-options.lisp 2008/01/12 11:44:56 1.4 @@ -61,33 +61,37 @@ ;;; 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 +orchid+)) +(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 +purple+)) +(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 +darkgoldenrod+)) +(defparameter *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 +rosy-brown+ - :style (make-text-style nil :italic nil))) +(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))) +(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+)) +(defvar *error-drawing-options* + (make-drawing-options :face (make-face :ink +red+)) "The drawing options used for drawing syntax errors.") From thenriksen at common-lisp.net Sun Jan 13 10:32:11 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 13 Jan 2008 05:32:11 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080113103211.8EBD369175@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv31443/Drei Modified Files: syntax.lisp Log Message: Made drei-syntax:update-parse work even without updater-functions. --- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/01/11 02:44:13 1.12 +++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/01/13 10:32:11 1.13 @@ -50,9 +50,13 @@ "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." - (map nil #'(lambda (updater) - (funcall updater begin end)) - (updater-fns syntax))) + (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) () From thenriksen at common-lisp.net Sun Jan 13 10:33:09 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 13 Jan 2008 05:33:09 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Doc Message-ID: <20080113103309.A95A4691A2@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc In directory clnet:/tmp/cvs-serv31563/Doc Modified Files: drei.texi Log Message: Updated Drei documentation. Should now build, at least. --- /project/mcclim/cvsroot/mcclim/Doc/drei.texi 2007/12/08 08:53:58 1.10 +++ /project/mcclim/cvsroot/mcclim/Doc/drei.texi 2008/01/13 10:33:09 1.11 @@ -65,7 +65,8 @@ Every Drei instance is associated with an editor pane - this must be a CLIM stream pane that is used for redisplay (@pxref{Redisplay Protocol}). This is not necessarily the same object as the Drei instance -itself, but it can be. +itself, but it can be. (With a little work, the editor pane can be + at cl{NIL}, which is useful for resting.) For each Drei instance, Drei attempts to simulate an application top-level loop with something called a @i{pseudo command loop}, and @@ -163,6 +164,7 @@ * Buffer Modification Protocol:: * DREI-BASE Package:: * Syntax Protocol:: +* View Protocol:: * Unit Protocol:: * Redisplay Protocol:: * Undo Protocol:: @@ -478,9 +480,9 @@ @node Syntax Protocol @subsection Syntax Protocol -A buffer always has a syntax module associated with it. The syntax -module usually consists of an incremental parser that analyzes the -contents of the buffer and creates some kind of parse tree or other +A syntax module is an object that can be associated with a buffer. The +syntax module usually consists of an incremental parser that analyzes +the contents of the buffer and creates some kind of parse tree or other representation of the contents in order that it can be exploited by the redisplay module and by user commands. @@ -518,43 +520,46 @@ @item etc. @end itemize -The view that the syntax module has of the buffer is updated only when -needed, and then only for the parts of the buffer that are needed. -Most syntax modules (such as for programming languages) need to -compute their representations from the beginning of the buffer up to a -particular point beyond which the structure of the buffer does not -need to be known. +The ideal is that the view that the syntax module has of the buffer is +updated only when needed, and then only for the parts of the buffer that +are needed, though implementing this in practise is decidedly +nontrivial. Most syntax modules (such as for programming languages) +need to compute their representations from the beginning of the buffer +up to a particular point beyond which the structure of the buffer does +not need to be known. -There are three situations where updating might be needed: +There are two primary situations where updating might be needed: @itemize @bullet - at item once, before any panes are displayed to inform the syntax module -that some part of the buffer has been altered, - at item once for each pane on display, before redisplay is about to show -the contents of part of the buffer in a pane to inform the syntax + at item Before redisplay is about to show +the contents of part of the buffer in a pane, to inform the syntax module that its syntax must be valid in the particular region on display, @item as a result of a command that exploits the syntactic entities of the buffer contents. @end itemize -The first case is handled by the redisplay invoking the following -generic function: +These two cases do boil down to ``whenever there is need for the syntax +information to be correct'', however. - at include fun-drei-syntax-update-syntax.texi - -The second case is handled by the following generic function: +The first case is handled by the invocation of a single generic function: - at include fun-drei-syntax-update-syntax-for-display.texi - -The third case is handled by the syntax module itself when needed in -order to correctly compute the effects of a command. + at include fun-drei-syntax-update-syntax.texi It is important to realize that the syntax module is not directly involved in displaying buffer contents in a pane. In fact, the syntax -module should work even if there is no graphic user interface -present, and it should be exploitable by several, potentially totally -different, display units. +module should work even if there is no graphic user interface present, +and it should be exploitable by several, potentially totally different, +display units. + +The second case is slightly trickier, as any views of the syntax should +be informed that it has reparsed some part of the buffer. Since + at cl{update-syntax} is only called by views, the view can easily record +the fact that some part of the buffer has an up-to-date parse. Thus, +functions accessing syntax information must go to some length to make +sure that the view of the syntax is notified of any reparses. + + at include fun-drei-syntax-update-parse.texi @node Incremental Parsing Framework @subsubsection Incremental Parsing Framework @@ -684,6 +689,40 @@ a symbol. These forms typically contain initargs, and will be passed as additional arguments to @code{(make-instance '@var{symbol})}. + at node View Protocol + at subsection View Protocol + at cindex view protocol + at cindex views + +Drei extends CLIMs concept of ``views'' to be more than just a manner +for determining the user interface for accepting values from the +user. Instead, the view is what controls the user interface of the Drei +instance the user is interacting with. To simplify the discussion, this +section assumes that the view is always associated with a single +buffer. A buffer does not have to be associated with a view, and may be +associated with many views, though each view may only have a single +buffer. The view controls how the buffer is displayed to the user, and +which commands are available to the user for modifying the buffer. A +view may use a syntax module to maintain syntactical information about +the buffer contents, and use the resulting information to highlight +parts of the buffer based on its syntactical value (``syntax +highlighting''). + + at include class-drei-drei-view.texi + + at include class-drei-drei-buffer-view.texi + + at include method-drei-buffer-buffer-nil-drei-buffer-view.texi + + at include class-drei-drei-syntax-view.texi + + at include class-drei-point-mark-view.texi + +The @cl{synchronize-view} generic function is the heart of all view +functionality. + + at include fun-drei-synchronize-view.texi + @node Unit Protocol @subsection Unit Protocol @cindex Drei unit protocol @@ -821,31 +860,23 @@ A buffer can be on display in several panes, possibly by being located in several Drei instances. Thus, the buffer does not concern itself with -redisplay, but assumes that its host Drei instance will redisplay when +redisplay, but assumes that whatever is using it will redisplay when appropriate. There is no predictable definitive rule for when a Drei -will be redisplayed, but when it is, it will be done by calling the -following generic function. +instance will be redisplayed, but when it is, it will be done by calling +the following generic function. - at deffn {Generic Function} {display-drei} frame drei - at findex display-drei + at include fun-drei-display-drei.texi - at var{Drei} must be an object of type @class{drei} and @var{frame} must -be a CLIM frame containing the editor pane of @var{drei}. If you define -a new subclass of @var{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. - at end deffn - -The redisplay engine supports syntax-specific customization of the -display in order to facilitate such functionality as syntax -highlighting. This is done through the following two generic functions, -both of which have sensible default methods defined by the Fundamental -syntax, so if your syntax is a subclass of @class{fundamental-syntax}, -you do not need to define them. +The redisplay engine supports view-specific customization of the display +in order to facilitate such functionality as syntax highlighting. This +is done through the following two generic functions, both of which have +sensible default methods defined by @class{drei-buffer-view} and + at class{drei-syntax-view}, so if your view is a subclass of either of +these, you do not need to define them yourself. - at include fun-drei-display-drei-contents.texi + at include fun-drei-display-drei-view-contents.texi - at include fun-drei-display-drei-cursor.texi + at include fun-drei-display-drei-view-cursor.texi @node Undo Protocol @subsection Undo Protocol @@ -1230,8 +1261,6 @@ @include class-drei-syntax-syntax-command-table.texi - at include fun-drei-syntax-use-editor-commands-p.texi - @include fun-drei-syntax-additional-command-tables.texi @include macro-drei-syntax-define-syntax-command-table.texi From thenriksen at common-lisp.net Sun Jan 13 10:33:10 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 13 Jan 2008 05:33:10 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080113103310.4A23B7323C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv31563/Drei Modified Files: drei.lisp packages.lisp syntax.lisp views.lisp Log Message: Updated Drei documentation. Should now build, at least. --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/11 02:44:13 1.25 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/13 10:33:09 1.26 @@ -345,7 +345,12 @@ ;; Main redisplay entry point. (defgeneric display-drei (drei) - (:documentation "Display the given Drei instance.")) + (: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.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/10 11:17:00 1.39 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/13 10:33:09 1.40 @@ -145,7 +145,7 @@ (defpackage :drei-syntax (:use :clim-lisp :clim :drei-buffer :drei-base :flexichain :esa-utils) - (:export #:syntax #:syntax-command-tables #:update-parse #:syntaxp + (: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 --- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/01/13 10:32:11 1.13 +++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/01/13 10:33:10 1.14 @@ -29,7 +29,14 @@ :reader command-table) (%updater-fns :initarg :updater-fns :initform '() - :accessor updater-fns)) + :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.")) --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/11 02:44:13 1.17 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/13 10:33:10 1.18 @@ -502,7 +502,9 @@ :initform (make-instance 'drei-buffer) :initarg :buffer :type drei-buffer - :accessor 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.") @@ -533,7 +535,9 @@ is, used for display right now.")) (:metaclass modual-class) (:documentation "A view that contains a `drei-buffer' -object.")) +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) (declare (ignore initargs)) @@ -566,7 +570,9 @@ (invalidate-line-strokes line :modified t))))) (defclass drei-syntax-view (drei-buffer-view) - ((%syntax :accessor syntax) + ((%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 @@ -763,7 +769,11 @@ (%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)) + (: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.")) (defmethod create-view-cursors nconc ((output-stream extended-output-stream) (view textual-drei-syntax-view)) From thenriksen at common-lisp.net Sun Jan 13 17:10:24 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 13 Jan 2008 12:10:24 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/Tests Message-ID: <20080113171024.9012368282@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv27483/Drei/Tests Modified Files: lisp-syntax-tests.lisp Log Message: Fixed the list-down movement commands for Lisp syntax. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2008/01/12 11:37:20 1.13 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2008/01/13 17:10:24 1.14 @@ -838,6 +838,12 @@ (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) From thenriksen at common-lisp.net Sun Jan 13 17:10:25 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 13 Jan 2008 12:10:25 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080113171025.2758C6A004@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv27483/Drei Modified Files: lisp-syntax.lisp Log Message: Fixed the list-down movement commands for Lisp syntax. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/12 11:37:21 1.66 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/13 17:10:24 1.67 @@ -1984,7 +1984,7 @@ (defun find-list-parent (form) "Find a list parent of `form' and return it. If a list parent -cannot be found, return nil" +cannot be found, return nil." (let ((parent (parent form))) (typecase parent (list-form parent) @@ -2000,23 +2000,23 @@ (when list-parent (funcall fn list-parent)))) -(defun find-list-child-offset (form fn &optional (min-offset 0)) - "Find a list child of `token' with a minimum start -offset of `min-offset' and return `fn' applied to this child token. -`Fn' should be a function that returns an offset when applied to a -token (eg. `start-offset' or `end-offset'). If a list child cannot -be found, return nil." - (labels ((has-list-child (form) - (some #'(lambda (child) - (if (and (form-list-p child) - (>= (start-offset child) - min-offset)) - child - (has-list-child child))) - (children form)))) - (let ((list-child (has-list-child form))) - (when (not (null list-child)) - (funcall fn list-child))))) +(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-if #'(lambda (child) + (typecase child + (list-form child) + (form (find-list-child child)))) + (children form))) + +(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." + (let ((list-child (find-list-child form))) + (when list-child + (funcall fn list-child)))) (defmethod backward-one-expression (mark (syntax lisp-syntax)) (update-parse syntax 0 (offset mark)) @@ -2137,12 +2137,16 @@ (defun down-list (mark syntax selector next-offset-fn target-offset-fn) (update-parse syntax 0 (offset mark)) - (labels ((find-offset (potential-form) + (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 (find-offset (funcall selector syntax - (funcall next-offset-fn potential-form))))))) + (t (next potential-form))))) (let ((new-offset (find-offset (funcall selector syntax (offset mark))))) (when new-offset (setf (offset mark) new-offset) From ahefner at common-lisp.net Sun Jan 13 20:23:59 2008 From: ahefner at common-lisp.net (ahefner) Date: Sun, 13 Jan 2008 15:23:59 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Experimental/freetype Message-ID: <20080113202359.5DF495B074@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv8112 Modified Files: freetype-fonts.lisp Log Message: Attempt to improve handling of broken freetype paths. Error immediately when a TTF file cannot be found. If call-next-method here was a feature, I hope no one misses it. Added potentially helpful restart. --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/06 01:37:06 1.15 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/13 20:23:59 1.16 @@ -137,7 +137,7 @@ (or (pop (display-free-glyph-ids display)) (incf (display-free-glyph-id-counter display)))) -(defvar *font-hash* +(defparameter *font-hash* (make-hash-table :test #'equalp)) (defstruct (glyph-info (:constructor glyph-info (id width height left right top))) @@ -386,7 +386,6 @@ ;;; Here are alternate mappings for the DejaVu family of fonts, which ;;; are a derivative of Vera with improved unicode coverage. - #+NIL (defparameter *families/faces* '(((:FIX :ROMAN) . "DejaVuSansMono.ttf") @@ -436,6 +435,24 @@ (defparameter *free-type-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 *freetype-font-path* is currently ~W~%The following files should exist:~&~{ ~A~^~%~}" + (missing-font-filename condition) + *freetype-font-path* + (mapcar #'cdr *families/faces*))))) + +(defun invoke-with-freetype-path-restart (continuation) + (restart-case (funcall continuation) + (change-font-path (new-path) + :report (lambda (stream) (format stream "Retry with alternate freetype font path")) + :interactive (lambda () + (format t "Enter new value: ") + (list (read-line))) + (setf *freetype-font-path* new-path) + (invoke-with-freetype-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 () @@ -453,14 +470,18 @@ (let* ((font-path-relative (cdr (assoc (list family face) *families/faces* :test #'equal))) (font-path (namestring (merge-pathnames font-path-relative *freetype-font-path*)))) + (unless (and font-path (probe-file font-path)) + (error 'missing-font :filename font-path)) + #+NIL (if (and font-path (probe-file font-path)) (make-free-type-face display font-path size) - (call-next-method))))))) + (call-next-method)) + (make-free-type-face display font-path size)))))) (t - (call-next-method))))))) + (call-next-method))))))) (cdr (if (eq (car lookaside) text-style) lookaside - (setf lookaside (cons text-style (f)))))))) + (setf lookaside (cons text-style (invoke-with-freetype-path-restart #'f)))))))) (defmethod clim-clx::text-style-to-X-font ((port clim-clx::clx-port) text-style) (error "You lost: ~S." text-style)) From dmurray at common-lisp.net Sun Jan 13 22:01:31 2008 From: dmurray at common-lisp.net (dmurray) Date: Sun, 13 Jan 2008 17:01:31 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080113220131.6B9C150016@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv2728/Drei Modified Files: drei-redisplay.lisp Log Message: Initial support for non-graphic characters, including #\Tabs. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/09 12:47:31 1.24 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/13 22:01:31 1.25 @@ -176,13 +176,18 @@ 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." +`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))) + (dimensions (make-dimensions)) + (widths) + (parts)) (defstruct (displayed-line (:conc-name line-)) "A line on display. A line delimits a buffer region (always @@ -377,15 +382,18 @@ (incf (line-stroke-count line)) (setf (line-end-offset line) (stroke-end-offset stroke))))) -(defun record-stroke (stroke x1 y1 x2 y2 +(defun record-stroke (stroke parts widths x1 y1 x2 y2 &optional (center (/ (- y2 y1) 2))) - "Record the fact that `stroke' has been drawn, and that it + "Record the fact that `stroke' has been drawn, that it consists +of parts `parts' with the widths `widths', and that it covers the specified area on screen. Updates the dirty- and modified-bits of `stroke' as well as the dimensions." (let ((dimensions (stroke-dimensions stroke))) (setf (stroke-dirty stroke) nil (stroke-modified stroke) nil - (x1 dimensions) x1 + (stroke-parts stroke) parts + (stroke-widths stroke) widths + (x1 dimensions) x1 (y1 dimensions) y1 (x2 dimensions) x2 (y2 dimensions) y2 @@ -395,6 +403,39 @@ "A text style specifying a roman face, but with unspecified family and size.") +(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 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 stroke-drawing-fn (stream view stroke cursor-x cursor-y) "Draw `stroke' to `stream' at the position (`cursor-x', `cursor-y'). `View' is the view object that `stroke' belongs @@ -406,7 +447,9 @@ (with-accessors ((start-offset stroke-start-offset) (end-offset stroke-end-offset) (dimensions stroke-dimensions) - (drawing-options stroke-drawing-options)) stroke + (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)) @@ -421,25 +464,66 @@ (text-style-ascent (text-style-ascent roman-text-style (sheet-medium stream))) (text-style-descent (text-style-descent roman-text-style (sheet-medium stream))) (text-style-height (+ text-style-ascent text-style-descent))) - (with-accessors ((x1 x1) (y1 y1) (x2 x2) (y2 y2) (center center)) dimensions - (multiple-value-bind (width ignore1 ignore2 ignore3 baseline) - (if (stroke-modified stroke) - (text-size stream stroke-string - :text-style merged-text-style) - (values (- x2 x1) (- y2 y1) nil nil center)) - (declare (ignore ignore1 ignore2 ignore3)) - (clear-rectangle* stream cursor-x cursor-y - (+ cursor-x width) (+ cursor-y text-style-height - (stream-vertical-spacing stream))) - (draw-text* stream stroke-string cursor-x (+ cursor-y - (- text-style-ascent - baseline)) - :text-style merged-text-style - :ink (face-ink (drawing-options-face drawing-options)) - :align-y :top) - (record-stroke stroke cursor-x cursor-y - (+ width cursor-x) (+ text-style-height cursor-y) - baseline)))))) + (with-accessors ((x1 x1) (x2 x2) (center center)) dimensions + (multiple-value-bind (stroke-parts width baseline part-widths) + (if (stroke-modified stroke) + (loop with parts = (analyse-stroke-string stroke-string) + with width = 0 + with baseline = 0 + with widths = (make-array 1 :adjustable t :fill-pointer t) + with tab-width + for (start end object) in parts + do (cond ((and object (eql object #\Tab)) + (incf width + (- (or tab-width (setf tab-width (tab-width stream view))) + (mod (+ width cursor-x) tab-width))) + (vector-push-extend width widths)) + (object + (multiple-value-bind (w ignore1 ignore2 ignore3 b) + (text-size stream object + :text-style merged-text-style) + (declare (ignore ignore1 ignore2 ignore3)) + (incf width w) + (setf baseline (max baseline b)) + (vector-push-extend width widths))) + (t + (multiple-value-bind (w ignore1 ignore2 ignore3 b) + (text-size stream stroke-string + :start start :end end + :text-style merged-text-style) + (declare (ignore ignore1 ignore2 ignore3)) + (incf width w) + (setf baseline (max baseline b)) + (vector-push-extend width widths)))) + finally (return (values parts width baseline widths))) + (values parts (- x2 x1) center widths)) + (clear-rectangle* stream cursor-x cursor-y + (+ cursor-x width) (+ cursor-y text-style-height + (stream-vertical-spacing stream))) + (loop for (start end object) in stroke-parts + for width across part-widths + do (cond ((and object (eq object #\Tab)) + nil) + (object + (draw-text* stream object (+ cursor-x width) + (+ cursor-y + (- text-style-ascent + baseline)) + :text-style merged-text-style + :ink +darkblue+ + :align-y :top)) + (t + (draw-text* stream stroke-string (+ cursor-x width) + (+ cursor-y + (- text-style-ascent + baseline)) + :start start :end end + :text-style merged-text-style + :ink (face-ink (drawing-options-face drawing-options)) + :align-y :top)))) + (record-stroke stroke stroke-parts part-widths cursor-x cursor-y + (+ width cursor-x) (+ text-style-height cursor-y) + baseline)))))) (defun draw-stroke (stream view stroke cursor-x cursor-y) "Draw `stroke' on `stream' at (`cursor-x', `cursor-y'). Nothing @@ -551,7 +635,9 @@ 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) + (let (output-record + (widths (make-array 2 :initial-contents (list 0 0))) + (parts (list 0 1))) #'(lambda (stream view stroke cursor-x cursor-y default-drawing-fn) (declare (ignore default-drawing-fn)) @@ -573,7 +659,9 @@ (+ cursor-x width) (+ cursor-y height (stream-vertical-spacing stream))) (replay output-record stream) - (record-stroke stroke cursor-x cursor-y (+ width cursor-x) + (setf (aref widths 1) width) + (record-stroke stroke parts widths + cursor-x cursor-y (+ width cursor-x) (+ (if (zerop height) (text-style-height (medium-text-style stream) stream) height) @@ -644,15 +732,25 @@ "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'," - (text-size stream (in-place-buffer-substring - (buffer view) (cache-string view) - (stroke-start-offset stroke) offset) - :end (- offset (stroke-start-offset stroke)) - :text-style (merge-text-styles - (face-style - (drawing-options-face - (stroke-drawing-options stroke))) - (medium-merged-text-style (sheet-medium stream))))) + (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 From thenriksen at common-lisp.net Sun Jan 13 22:22:06 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 13 Jan 2008 17:22:06 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080113222206.3827A72127@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv8307/Drei Modified Files: packages.lisp Log Message: Added facility for ESA for controlling whether or not a buffer is "saveable". Could be used for more than it currently is (such as integrating the user-confirmation stuff when the file already exists). --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/13 10:33:09 1.40 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/13 22:22:05 1.41 @@ -28,6 +28,8 @@ (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 From thenriksen at common-lisp.net Sun Jan 13 22:22:14 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 13 Jan 2008 17:22:14 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20080113222214.6521E74374@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv8307/ESA Modified Files: esa-io.lisp packages.lisp Log Message: Added facility for ESA for controlling whether or not a buffer is "saveable". Could be used for more than it currently is (such as integrating the user-confirmation stuff when the file already exists). --- /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2007/12/27 16:34:59 1.5 +++ /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2008/01/13 22:22:06 1.6 @@ -2,7 +2,7 @@ ;;; (c) copyright 2006 by ;;; Robert Strandh (strandh at labri.fr) -;;; (c) copyright 2007 by +;;; (c) copyright 2007-2008 by ;;; Troels Henriksen (athas at sigkill.dk) ;;; This library is free software; you can redistribute it and/or @@ -29,9 +29,45 @@ 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) @@ -170,6 +206,12 @@ 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)) @@ -208,27 +250,23 @@ (defmethod frame-save-buffer (application-frame buffer) (let ((filepath (or (filepath buffer) (accept 'pathname :prompt "Save Buffer to File")))) - (cond - ((directory-pathname-p filepath) - (display-message "~A is a directory." filepath) - (beep)) - (t - (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))))) + (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. @@ -237,22 +275,23 @@ (let ((buffer (current-buffer))) (if (or (null (filepath buffer)) (needs-saving buffer)) - (save-buffer buffer) + (handler-case (save-buffer buffer) + (buffer-writing-error (e) + (with-minibuffer-stream (minibuffer) + (let ((*print-escape* nil)) + (print-object e minibuffer))))) (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) - (cond - ((directory-pathname-p filepath) - (display-message "~A is a directory name." filepath)) - (t - (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))))) + (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 @@ -261,7 +300,11 @@ "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))) - (write-buffer filepath 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))) --- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/01/11 02:44:14 1.11 +++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/01/13 22:22:06 1.12 @@ -2,7 +2,7 @@ ;;; (c) copyright 2004-2006 by ;;; Robert Strandh (strandh at labri.fr) -;;; (c) copyright 2006 by +;;; (c) copyright 2006-2008 by ;;; Troels Henriksen (athas at sigkill.dk) ;;; This library is free software; you can redistribute it and/or @@ -106,8 +106,11 @@ (: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)) #-(or mcclim building-mcclim) From ahefner at common-lisp.net Sun Jan 13 23:02:35 2008 From: ahefner at common-lisp.net (ahefner) Date: Sun, 13 Jan 2008 18:02:35 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Experimental/freetype Message-ID: <20080113230235.59EC870DF@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv16465 Modified Files: freetype-fonts.lisp Log Message: Attempt to workaround nil text style issue. --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/13 20:23:59 1.16 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/13 23:02:34 1.17 @@ -461,6 +461,7 @@ (let ((display (clim-clx::clx-port-display port))) (setf face (or face :roman)) + (setf family (or family :fix)) (setf size (or size :normal)) (cond (size (setf size (getf *sizes* size size)) From ahefner at common-lisp.net Mon Jan 14 00:01:04 2008 From: ahefner at common-lisp.net (ahefner) Date: Sun, 13 Jan 2008 19:01:04 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20080114000104.5906061052@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv28382 Modified Files: port.lisp Log Message: Surely we mean finish rather than force output. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2007/09/11 19:54:40 1.129 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2008/01/14 00:01:04 1.130 @@ -279,7 +279,7 @@ #'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-force-output)) + (setf (xlib:display-after-function (clx-port-display port)) #'xlib:display-finish-output)) (setf (clx-port-screen port) (nth (getf options :screen-id) From ahefner at common-lisp.net Mon Jan 14 04:53:11 2008 From: ahefner at common-lisp.net (ahefner) Date: Sun, 13 Jan 2008 23:53:11 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20080114045311.B83D364125@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv15001 Modified Files: port.lisp Log Message: Better handle the situation where the DISPLAY variable is not set, which often causes problems on fringe platforms such as Win32 or the Macintosh. Specifically, McCLIM merged the user-provided server path against the server path read from the environment, which is wrong. Worse, it errored unless the environment variable was set, even if the user supplied their own server path. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2008/01/14 00:01:04 1.130 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2008/01/14 04:53:11 1.131 @@ -167,8 +167,7 @@ (selection-timestamp :initform nil :accessor selection-timestamp) (font-families :accessor font-families))) -(defun parse-clx-server-path (path) - (pop path) +(defun automagic-clx-server-path () (let ((name (get-environment-variable "DISPLAY"))) (assert name (name) "Environment variable DISPLAY is not set") @@ -178,13 +177,13 @@ (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 (when colon-i + (display (and colon-i (parse-integer name :start (if decnet-colon-p (+ colon-i 2) (1+ colon-i)) :end dot-i))) - (screen (when dot-i + (screen (and dot-i (parse-integer name :start (1+ dot-i)))) (protocol (cond ((or (string= host "") (string-equal host "unix")) :local) @@ -194,10 +193,20 @@ :keyword)) (t :internet)))) (list :clx - :host (getf path :host host) - :display-id (getf path :display-id (or display 0)) - :screen-id (getf path :screen-id (or screen 0)) - :protocol protocol)))) + :host host + :display-id (or display 0) + :screen-id (or screen 0) + :protocol protocol)))) + +(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)) + (automagic-clx-server-path))) (setf (get :x11 :port-type) 'clx-port) (setf (get :x11 :server-path-parser) 'parse-clx-server-path) From thenriksen at common-lisp.net Mon Jan 14 06:52:01 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 14 Jan 2008 01:52:01 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20080114065201.8B69968286@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv8448/Apps/Listener Modified Files: icons.lisp Log Message: Fixed the Listener to use MCCLIM-IMAGES for drawing rather than DRAW-PATTERN*. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/icons.lisp 2008/01/06 15:32:11 1.6 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/icons.lisp 2008/01/14 06:52:00 1.7 @@ -58,10 +58,8 @@ (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)))) + (mcclim-images:draw-image stream pattern) + (stream-increment-cursor-position stream (+ (mcclim-images:image-width pattern) extra-spacing) 0))) (defun precache-icons () (let ((pathnames (remove-if #'directoryp From ahefner at common-lisp.net Mon Jan 14 07:03:20 2008 From: ahefner at common-lisp.net (ahefner) Date: Mon, 14 Jan 2008 02:03:20 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080114070320.C521C16048@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv9791 Modified Files: design.lisp regions.lisp Log Message: Plug holes in the design composition functions. --- /project/mcclim/cvsroot/mcclim/design.lisp 2007/02/05 02:54:20 1.26 +++ /project/mcclim/cvsroot/mcclim/design.lisp 2008/01/14 07:03:15 1.27 @@ -47,6 +47,8 @@ ;; ;; --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: ;; @@ -283,13 +285,26 @@ ||# +;;;; 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) ()) -(defvar +foreground-ink+ (make-instance 'indirect-ink)) +(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) @@ -313,15 +328,25 @@ :type (real 0 1) :reader opacity-value))) -(defvar +transparent-ink+ - (make-instance 'standard-opacity :value 0)) +(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) - +foreground-ink+) + (cond ((= value 0) +transparent-ink+) + ((= value 1) +everywhere+) ; used to say +foreground-ink+ (t (make-instance 'standard-opacity :value value)))) @@ -427,10 +452,6 @@ :initarg :design :reader transformed-design-design))) -#+NIL -;; Commeted out because CLOS bites here. Ellipises will be transformed -;; by this method. No idea why. -;; --GB 2003-05-28 (defmethod transform-region (transformation (design design)) (make-instance 'transformed-design :transformation transformation @@ -456,34 +477,43 @@ ;;; -(defclass in-compositum (design) +(defclass masked-compositum (design) ((ink :initarg :ink :reader compositum-ink) (mask :initarg :mask :reader compositum-mask))) -(defmethod print-object ((object in-compositum) stream) - (print-unreadable-object (object stream :identity nil :type t) +(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) + :ink (compositum-ink object) :mask (compositum-mask object)))) -(defclass uniform-compositum (in-compositum) - ;; we use this class to represent rgbo values - ()) - -(defclass over-compositum (design) - ((foreground :initarg :foreground :reader compositum-foreground) - (background :initarg :background :reader compositum-background))) +(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 @@ -542,6 +572,14 @@ (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: @@ -648,6 +686,29 @@ ;;;; ------------------------------------------------------------------------------------------ ;;;; +;;;; 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 ;;;; @@ -702,7 +763,6 @@ (multiple-value-bind (r g b o) (multiple-value-call #'color-blend-function (color-rgb foreground) - 1 (color-rgb (compositum-ink background)) (opacity-value (compositum-mask background))) (make-uniform-compositum --- /project/mcclim/cvsroot/mcclim/regions.lisp 2007/02/05 03:07:22 1.34 +++ /project/mcclim/cvsroot/mcclim/regions.lisp 2008/01/14 07:03:18 1.35 @@ -4,7 +4,7 @@ ;;; Created: 1998-12-02 19:26 ;;; Author: Gilbert Baumann ;;; License: LGPL (See file COPYING for details). -;;; $Id: regions.lisp,v 1.34 2007/02/05 03:07:22 ahefner Exp $ +;;; $Id: regions.lisp,v 1.35 2008/01/14 07:03:18 ahefner Exp $ ;;; -------------------------------------------------------------------------------------- ;;; (c) copyright 1998,1999,2001 by Gilbert Baumann ;;; (c) copyright 2001 by Arnaud Rouanet (rouanet at emi.u-bordeaux.fr) @@ -81,8 +81,8 @@ (in-package :clim-internals) -(defclass nowhere-region (region) ()) -(defclass everywhere-region (region) ()) +(defclass nowhere-region (region nowhere-mixin) ()) +(defclass everywhere-region (region everywhere-mixin) ()) ;; coordinate is defined in coordinates.lisp From thenriksen at common-lisp.net Mon Jan 14 09:14:51 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 14 Jan 2008 04:14:51 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080114091451.E88CA68243@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv2325/Drei Modified Files: base.lisp lisp-syntax-commands.lisp Log Message: Fixed Indent Expression. --- /project/mcclim/cvsroot/mcclim/Drei/base.lisp 2008/01/05 20:08:32 1.10 +++ /project/mcclim/cvsroot/mcclim/Drei/base.lisp 2008/01/14 09:14:47 1.11 @@ -117,7 +117,7 @@ (as-region (,mark-sym ,mark2-sym) (loop while (and (mark<= ,mark-sym ,mark2-sym) (not (end-of-buffer-p ,mark-sym))) - do + do (let ((,line-var (clone-mark ,mark-sym))) , at body) (end-of-line ,mark-sym) --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2007/12/19 11:02:02 1.14 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2008/01/14 09:14:48 1.15 @@ -71,7 +71,7 @@ (define-command (com-indent-expression :name t :command-table lisp-table) ((count 'integer :prompt "Number of expressions" :default 1)) - (let ((mark (point))) + (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)))) From thenriksen at common-lisp.net Mon Jan 14 12:43:05 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 14 Jan 2008 07:43:05 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080114124305.C1CD837011@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv17192/Drei Modified Files: drei-redisplay.lisp Log Message: Made some small cleanups in Drei redisplay to prepare for bottom-adjusted drawing. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/13 22:01:31 1.25 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/14 12:43:05 1.26 @@ -383,13 +383,16 @@ (setf (line-end-offset line) (stroke-end-offset stroke))))) (defun record-stroke (stroke parts widths x1 y1 x2 y2 - &optional (center (/ (- y2 y1) 2))) - "Record the fact that `stroke' has been drawn, that it consists -of parts `parts' with the widths `widths', and that it -covers the specified area on screen. Updates the dirty- and -modified-bits of `stroke' as well as the dimensions." + &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) nil + (setf (stroke-dirty stroke) (and (stroke-dirty stroke) + (not drawn)) (stroke-modified stroke) nil (stroke-parts stroke) parts (stroke-widths stroke) widths @@ -436,6 +439,44 @@ (t (format nil "\\~O" code))))) +(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'. Four values will be returned: the total width of +the stroke, the baseline, 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 baseline = 0 + with widths = (make-array (length parts) :adjustable t :fill-pointer t) + with tab-width + for (start end object) in parts + do (cond ((and object (eql object #\Tab)) + (incf width + (- (or tab-width + (setf tab-width (tab-width stream (stream-default-view stream)))) + (mod (+ width x-position) tab-width))) + (vector-push-extend width widths)) + (object + (multiple-value-bind (w ignore1 ignore2 ignore3 b) + (text-size stream object + :text-style text-style) + (declare (ignore ignore1 ignore2 ignore3)) + (incf width w) + (setf baseline (max baseline b)) + (vector-push-extend width widths))) + (t + (multiple-value-bind (w ignore1 ignore2 ignore3 b) + (text-size stream stroke-string + :start start :end end + :text-style text-style) + (declare (ignore ignore1 ignore2 ignore3)) + (incf width w) + (setf baseline (max baseline b)) + (vector-push-extend width widths)))) + finally (return (values width baseline parts widths)))) + (defun stroke-drawing-fn (stream view stroke cursor-x cursor-y) "Draw `stroke' to `stream' at the position (`cursor-x', `cursor-y'). `View' is the view object that `stroke' belongs @@ -465,38 +506,10 @@ (text-style-descent (text-style-descent roman-text-style (sheet-medium stream))) (text-style-height (+ text-style-ascent text-style-descent))) (with-accessors ((x1 x1) (x2 x2) (center center)) dimensions - (multiple-value-bind (stroke-parts width baseline part-widths) + (multiple-value-bind (width baseline stroke-parts part-widths) (if (stroke-modified stroke) - (loop with parts = (analyse-stroke-string stroke-string) - with width = 0 - with baseline = 0 - with widths = (make-array 1 :adjustable t :fill-pointer t) - with tab-width - for (start end object) in parts - do (cond ((and object (eql object #\Tab)) - (incf width - (- (or tab-width (setf tab-width (tab-width stream view))) - (mod (+ width cursor-x) tab-width))) - (vector-push-extend width widths)) - (object - (multiple-value-bind (w ignore1 ignore2 ignore3 b) - (text-size stream object - :text-style merged-text-style) - (declare (ignore ignore1 ignore2 ignore3)) - (incf width w) - (setf baseline (max baseline b)) - (vector-push-extend width widths))) - (t - (multiple-value-bind (w ignore1 ignore2 ignore3 b) - (text-size stream stroke-string - :start start :end end - :text-style merged-text-style) - (declare (ignore ignore1 ignore2 ignore3)) - (incf width w) - (setf baseline (max baseline b)) - (vector-push-extend width widths)))) - finally (return (values parts width baseline widths))) - (values parts (- x2 x1) center widths)) + (calculate-stroke-width stroke-string merged-text-style stream cursor-x) + (values (- x2 x1) center parts widths)) (clear-rectangle* stream cursor-x cursor-y (+ cursor-x width) (+ cursor-y text-style-height (stream-vertical-spacing stream))) @@ -523,7 +536,7 @@ :align-y :top)))) (record-stroke stroke stroke-parts part-widths cursor-x cursor-y (+ width cursor-x) (+ text-style-height cursor-y) - baseline)))))) + t baseline)))))) (defun draw-stroke (stream view stroke cursor-x cursor-y) "Draw `stroke' on `stream' at (`cursor-x', `cursor-y'). Nothing From thenriksen at common-lisp.net Mon Jan 14 18:42:43 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 14 Jan 2008 13:42:43 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080114184243.4B04268101@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv4573/Drei Modified Files: drei-redisplay.lisp Log Message: Baseline-adjusted drawing for Drei. Please test. Is very slightly slower than it used to be, but enables an optimisation (reduction in number of distinct calls to draw-rectangle*) that I'll finish up shortly. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/14 12:43:05 1.26 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/14 18:42:43 1.27 @@ -100,11 +100,12 @@ (style nil)) (defconstant +default-stroke-drawer-dispatcher+ - #'(lambda (stream view stroke cursor-x cursor-y default-drawing-fn) - (funcall default-drawing-fn stream view stroke cursor-x cursor-y)) - "A simple function of six arguments that simply calls the first -argument as a function with the remaining five arguments. Used as -the default drawing-function of `drawing-options' objects.") + #'(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." @@ -142,7 +143,7 @@ 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." +the vertical axis. `Center' should be relative to `y1'." (x1 0) (y1 0) (x2 0) @@ -189,6 +190,13 @@ (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 @@ -391,8 +399,7 @@ 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)) + (setf (stroke-dirty stroke) (and (stroke-dirty stroke) (not drawn)) (stroke-modified stroke) nil (stroke-parts stroke) parts (stroke-widths stroke) widths @@ -443,12 +450,11 @@ "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'. Four values will be returned: the total width of -the stroke, the baseline, the parts of the stroke and the widths -of the parts of the stroke." +`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 baseline = 0 with widths = (make-array (length parts) :adjustable t :fill-pointer t) with tab-width for (start end object) in parts @@ -459,32 +465,32 @@ (mod (+ width x-position) tab-width))) (vector-push-extend width widths)) (object - (multiple-value-bind (w ignore1 ignore2 ignore3 b) + (multiple-value-bind (w ignore1 ignore2 ignore3 ignore4) (text-size stream object :text-style text-style) - (declare (ignore ignore1 ignore2 ignore3)) + (declare (ignore ignore1 ignore2 ignore3 ignore4)) (incf width w) - (setf baseline (max baseline b)) (vector-push-extend width widths))) (t - (multiple-value-bind (w ignore1 ignore2 ignore3 b) + (multiple-value-bind (w ignore1 ignore2 ignore3 ignore4) (text-size stream stroke-string :start start :end end :text-style text-style) - (declare (ignore ignore1 ignore2 ignore3)) + (declare (ignore ignore1 ignore2 ignore3 ignore4)) (incf width w) - (setf baseline (max baseline b)) (vector-push-extend width widths)))) - finally (return (values width baseline parts widths)))) + finally (return (values width parts widths)))) -(defun stroke-drawing-fn (stream view stroke cursor-x cursor-y) - "Draw `stroke' to `stream' at the position (`cursor-x', +(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. 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." +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) @@ -500,56 +506,56 @@ ;; 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)) + (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))) - (text-style-height (+ text-style-ascent text-style-descent))) + (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 baseline stroke-parts part-widths) + (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) center parts widths)) - (clear-rectangle* stream cursor-x cursor-y - (+ cursor-x width) (+ cursor-y text-style-height - (stream-vertical-spacing stream))) - (loop for (start end object) in stroke-parts - for width across part-widths - do (cond ((and object (eq object #\Tab)) - nil) - (object - (draw-text* stream object (+ cursor-x width) - (+ cursor-y - (- text-style-ascent - baseline)) - :text-style merged-text-style - :ink +darkblue+ - :align-y :top)) - (t - (draw-text* stream stroke-string (+ cursor-x width) - (+ cursor-y - (- text-style-ascent - baseline)) - :start start :end end - :text-style merged-text-style - :ink (face-ink (drawing-options-face drawing-options)) - :align-y :top)))) - (record-stroke stroke stroke-parts part-widths cursor-x cursor-y - (+ width cursor-x) (+ text-style-height cursor-y) - t baseline)))))) + (values (- x2 x1) parts widths)) + (when draw + (loop for (start end object) in stroke-parts + for width across part-widths + do (cond ((and object (eq 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 (= cursor-x (x1 (stroke-dimensions stroke))) + (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))) (defun draw-stroke (stream view stroke cursor-x cursor-y) - "Draw `stroke' on `stream' at (`cursor-x', `cursor-y'). Nothing -will be done unless `stroke' is dirty. Will use the function -specified in the drawing-options of `stroke' to carry out the -actual drawing." - (let* ((drawing-options (stroke-drawing-options stroke))) - (unless (and (= cursor-x (x1 (stroke-dimensions stroke))) - (= cursor-y (y1 (stroke-dimensions stroke)))) - (invalidate-stroke stroke :modified t)) - (when (stroke-dirty stroke) - (funcall (drawing-options-function drawing-options) stream view stroke - cursor-x cursor-y #'stroke-drawing-fn)))) + "Draw `stroke' on `stream' with a baseline at +`cursor-y'. Drawing starts at the horizontal offset +`cursor-x'. Stroke must thus have updated dimensional +informational. Nothing will be done unless `stroke' is dirty." + (when (stroke-dirty stroke) + (funcall (drawing-options-function (stroke-drawing-options stroke)) + stream view stroke cursor-x cursor-y #'stroke-drawing-fn t))) (defun end-line (line x1 y1 line-width line-height) "End the addition of strokes to `line' for now, and update the @@ -568,21 +574,20 @@ associated dimensions. Also clear from the bottom of strokes to the bottom of the line, and from the end of the line to the end of the sheet." + (declare (ignore old-line-width)) (end-line line line-x1 line-y1 line-width line-height) (with-accessors ((line-x1 x1) (line-y1 y1) (line-x2 x2) (line-y2 y2)) (line-dimensions line) - ;; If a has a lesser height than the line, clear from the bottom - ;; of the stroke to the bottom of the line, to avoid artifacts - ;; left over from prefvious redisplays. + ;; If a has a lesser height than the line, clear from the top of + ;; the line stroke to the top of the stroke, to avoid artifacts + ;; left over from previous redisplays. (do-displayed-line-strokes (stroke line) (let ((stroke-dimensions (stroke-dimensions stroke))) (with-accessors ((stroke-x1 x1) (stroke-y1 y1) (stroke-x2 x2) (stroke-y2 y2)) stroke-dimensions (when (> line-height (dimensions-height stroke-dimensions)) - (clear-rectangle* stream stroke-x1 stroke-y2 - stroke-x2 (+ stroke-y2 (- line-height - (dimensions-height stroke-dimensions)) - (stream-vertical-spacing stream))))))) + (clear-rectangle* stream stroke-x1 line-y1 + stroke-x2 stroke-y1))))) ;; Reset the dimensions of undisplayed lines. (do-undisplayed-line-strokes (stroke line) (let ((stroke-dimensions (stroke-dimensions stroke))) @@ -594,43 +599,58 @@ (clear-rectangle* stream line-x2 line-y1 (bounding-rectangle-width stream) (+ line-y1 (max line-height old-line-height) - (stream-vertical-spacing stream))) - (when (or (> old-line-height line-height) - (> old-line-width line-width)) - (clear-rectangle* stream line-x1 (+ line-y1 line-height) - (+ line-x1 (max old-line-width line-width)) - (+ line-y1 (max old-line-height line-height)))))) + (stream-vertical-spacing stream))))) (defun draw-line-strokes (stream view initial-pump-state start-offset cursor-x cursor-y) "Pump strokes from `view', using `initial-pump-state' to begin with, and draw them on `stream'. The line is set to start at the buffer offset `start-offset', and will be drawn starting -at (`cursor-x', `cursor-y')" +at (`cursor-x', `cursor-y')." (let* ((line (line-information view (displayed-lines-count view))) (old-line-height (dimensions-height (line-dimensions line))) (old-line-width (dimensions-width (line-dimensions line))) (orig-x-offset cursor-x) - (offset-change (- start-offset (line-start-offset line)))) + (offset-change (- start-offset (line-start-offset line))) + (line-spacing (stream-vertical-spacing stream))) (setf (line-start-offset line) start-offset (line-stroke-count line) 0) - (loop 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) then - (put-stroke view line pump-state offset-change) - do (draw-stroke stream view stroke cursor-x cursor-y) - (setf cursor-x (x2 stroke-dimensions)) - maximizing (dimensions-height stroke-dimensions) into line-height - summing (- (x2 stroke-dimensions) - (x1 stroke-dimensions)) into line-width - when (or (= (stroke-end-offset stroke) (size (buffer view))) - (eql (buffer-object (buffer view) (stroke-end-offset stroke)) #\Newline)) - return (progn (end-line-cleaning-up stream line orig-x-offset cursor-y - line-width old-line-width - line-height old-line-height) - (incf (displayed-lines-count view)) - (values pump-state line-height))))) + ;; So yeah, this is fairly black magic, but it's not actually + ;; ugly, just complex. + (multiple-value-bind (line-width line-height baseline pump-state) + ;; Pump all the line strokes and calculate their dimensions. + (loop 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) then + (put-stroke view line pump-state offset-change) + do (update-stroke-dimensions stream view stroke cursor-x cursor-y) + (setf cursor-x (x2 stroke-dimensions)) + maximizing (dimensions-height stroke-dimensions) into line-height + 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 line-height baseline pump-state)) + ;; Now actually draw them in a way that makes sure they all + ;; touch the bottom of the line. + (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)) + (when (stroke-dirty stroke) + (clear-rectangle* stream (x1 stroke-dimensions) cursor-y + (x2 stroke-dimensions) + (+ cursor-y line-height line-spacing)) + (setf last-clear-x (x2 stroke-dimensions))) + (draw-stroke stream view stroke + (x1 stroke-dimensions) baseline) + finally (progn (end-line-cleaning-up stream line orig-x-offset cursor-y + line-width old-line-width + line-height old-line-height) + (incf (displayed-lines-count view)) + (return (values pump-state line-height))))))) (defun clear-stale-lines (pane view) "Clear from the last displayed line to the end of `pane'." @@ -652,7 +672,7 @@ (widths (make-array 2 :initial-contents (list 0 0))) (parts (list 0 1))) #'(lambda (stream view stroke cursor-x cursor-y - default-drawing-fn) + default-drawing-fn draw) (declare (ignore default-drawing-fn)) (with-accessors ((start-offset stroke-start-offset) (drawing-options stroke-drawing-options)) stroke @@ -665,20 +685,17 @@ ;; 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. - (setf (output-record-position output-record) (values (+ cursor-x 0.1) cursor-y)) (let ((width (bounding-rectangle-width output-record)) (height (bounding-rectangle-height output-record))) - (clear-rectangle* stream cursor-x cursor-y - (+ cursor-x width) (+ cursor-y height - (stream-vertical-spacing stream))) - (replay output-record stream) + (setf (output-record-position output-record) + (values (+ cursor-x 0.1) (- cursor-y height))) + (when draw + (replay output-record stream)) (setf (aref widths 1) width) (record-stroke stroke parts widths - cursor-x cursor-y (+ width cursor-x) - (+ (if (zerop height) - (text-style-height (medium-text-style stream) stream) - height) - cursor-y)))))))) + cursor-x (- cursor-y height) + (+ width cursor-x) cursor-y + draw height))))))) (defmethod pump-state-for-offset ((view drei-buffer-view) (offset integer)) "For a `drei-buffer-view' a pump-state is merely an offset into @@ -767,7 +784,7 @@ (defgeneric offset-to-screen-position (pane view offset) (:documentation "Returns the position of offset as a screen -position. Returns `x', `y', `line-height', `OBJECT-WIDTH' as +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 @@ -786,7 +803,7 @@ (/= start-offset end-offset)) (return-from worker (values (x1 stroke-dimensions) (y1 stroke-dimensions) - (dimensions-height line-dimensions) + (dimensions-height stroke-dimensions) (if (= end-offset (1+ start-offset)) (dimensions-width stroke-dimensions) (offset-in-stroke-position pane view stroke (1+ offset)))))) @@ -796,7 +813,7 @@ (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 line-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)) @@ -815,9 +832,9 @@ ;; 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 line-height object-width) (worker) - (if (and x y line-height) - (values x y line-height (or object-width default-object-width)) [21 lines skipped] From thenriksen at common-lisp.net Mon Jan 14 19:06:52 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 14 Jan 2008 14:06:52 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080114190652.6E69369138@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv8142 Modified Files: NEWS Log Message: Added Drei stuff to NEWS. --- /project/mcclim/cvsroot/mcclim/NEWS 2008/01/11 06:01:38 1.28 +++ /project/mcclim/cvsroot/mcclim/NEWS 2008/01/14 19:06:52 1.29 @@ -6,6 +6,10 @@ applications. ** New extension: MCCLIM-IMAGES. This extension makes it easy to use McCLIM for loading and displaying images of various formats. +** Drei improvements +*** New redisplay engine that is faster and has more features. +*** Support for "views" concept. +*** Support for modes a la Emacs "mini-modes". * Changes in mcclim-0.9.5 relative to 0.9.4: ** Installation: the systems clim-listener, clim-examples, From thenriksen at common-lisp.net Mon Jan 14 19:57:02 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 14 Jan 2008 14:57:02 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080114195702.A0B6B240D4@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv15402/Drei Modified Files: drei-redisplay.lisp Log Message: Try to reduce the number of calls to `draw-rectangle*' in Drei. This improved performance in my trivial test by 15%. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/14 18:42:43 1.27 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/14 19:57:02 1.28 @@ -594,17 +594,12 @@ (with-accessors ((stroke-x1 x1) (stroke-y1 y1) (stroke-x2 x2) (stroke-y2 y2)) stroke-dimensions (setf stroke-x1 0 stroke-y1 0 - stroke-x2 0 stroke-y2 0)))) - ;; Clear from end of line to end of sheet. - (clear-rectangle* stream line-x2 line-y1 - (bounding-rectangle-width stream) - (+ line-y1 (max line-height old-line-height) - (stream-vertical-spacing stream))))) + stroke-x2 0 stroke-y2 0)))))) -(defun draw-line-strokes (stream view initial-pump-state +(defun draw-line-strokes (pane view initial-pump-state start-offset cursor-x cursor-y) "Pump strokes from `view', using `initial-pump-state' to begin -with, and draw them on `stream'. The line is set to start at the +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')." (let* ((line (line-information view (displayed-lines-count view))) @@ -612,7 +607,7 @@ (old-line-width (dimensions-width (line-dimensions line))) (orig-x-offset cursor-x) (offset-change (- start-offset (line-start-offset line))) - (line-spacing (stream-vertical-spacing stream))) + (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 @@ -624,29 +619,38 @@ for stroke-dimensions = (stroke-dimensions stroke) for pump-state = (put-stroke view line initial-pump-state offset-change) then (put-stroke view line pump-state offset-change) - do (update-stroke-dimensions stream view stroke cursor-x cursor-y) + do (update-stroke-dimensions pane view stroke cursor-x cursor-y) (setf cursor-x (x2 stroke-dimensions)) maximizing (dimensions-height stroke-dimensions) into line-height 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 line-height baseline pump-state)) + ;; 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 (bounding-rectangle-width pane)))) ;; Now actually draw them in a way that makes sure they all ;; touch the bottom of the line. - (loop with last-clear-x = orig-x-offset - for stroke-index below (line-stroke-count 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 (unless (= baseline (+ cursor-y (center stroke-dimensions))) - (invalidate-stroke stroke)) - (when (stroke-dirty stroke) - (clear-rectangle* stream (x1 stroke-dimensions) cursor-y - (x2 stroke-dimensions) - (+ cursor-y line-height line-spacing)) - (setf last-clear-x (x2 stroke-dimensions))) - (draw-stroke stream view stroke - (x1 stroke-dimensions) baseline) - finally (progn (end-line-cleaning-up stream line orig-x-offset cursor-y + do (draw-stroke pane view stroke (x1 stroke-dimensions) baseline) + finally (progn (end-line-cleaning-up pane line orig-x-offset cursor-y line-width old-line-width line-height old-line-height) (incf (displayed-lines-count view)) From thenriksen at common-lisp.net Mon Jan 14 20:50:11 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 14 Jan 2008 15:50:11 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20080114205011.0CDBD4A42D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv24744/ESA Modified Files: esa.lisp Log Message: Fixed ESA macro replaying. --- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2007/12/19 11:01:57 1.13 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/01/14 20:50:11 1.14 @@ -1542,7 +1542,7 @@ (define-command (com-call-last-kbd-macro :name t :command-table keyboard-macro-table) - ((count 'integer :prompt "How many times?")) + ((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*) From thenriksen at common-lisp.net Mon Jan 14 20:58:30 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 14 Jan 2008 15:58:30 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080114205830.164795D166@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv25330/Drei Modified Files: drei-redisplay.lisp Log Message: Fixed cursor-height calculation when at end of line. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/14 19:57:02 1.28 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/14 20:58:29 1.29 @@ -822,9 +822,12 @@ (- (x2 stroke-dimensions) absolute-x-position) (- (offset-in-stroke-position pane view stroke (1+ offset)) relative-x-position))))))))) - (return-from - worker (values (x2 line-dimensions) (y1 line-dimensions) - (dimensions-height line-dimensions)))))))) + ;; 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 From thenriksen at common-lisp.net Mon Jan 14 21:43:49 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 14 Jan 2008 16:43:49 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080114214349.2E19748152@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv2479/Drei Modified Files: drei-redisplay.lisp Log Message: Don't draw the cursor if the result would be a null rectangle. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/14 20:58:29 1.29 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/14 21:43:48 1.30 @@ -875,10 +875,11 @@ (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)) - (draw-rectangle* stream - cursor-x cursor-y - (+ cursor-x object-width) (+ cursor-y stroke-height) - :ink (ink 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 display-drei-view-cursor :after ((stream extended-output-stream) (view drei-view) (cursor point-cursor)) From thenriksen at common-lisp.net Tue Jan 15 06:55:34 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 15 Jan 2008 01:55:34 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080115065534.B7EED6915C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv21518/Drei Modified Files: motion.lisp Log Message: Make paragraph-movement commands move the beginning or end of buffer even if no paragraph delimiter can be found. --- /project/mcclim/cvsroot/mcclim/Drei/motion.lisp 2008/01/05 20:08:32 1.6 +++ /project/mcclim/cvsroot/mcclim/Drei/motion.lisp 2008/01/15 06:55:30 1.7 @@ -476,10 +476,9 @@ (unless (beginning-of-buffer-p mark) (backward-object mark 1) (if (search-backward mark (coerce (paragraph-delimiter syntax) 'vector)) - (progn (forward-object mark (length (paragraph-delimiter syntax))) - t) - (progn (beginning-of-buffer mark) - nil)))) + (forward-object mark (length (paragraph-delimiter syntax))) + (beginning-of-buffer mark)) + t)) (defgeneric forward-one-paragraph (mark syntax) (:documentation @@ -490,10 +489,9 @@ (unless (end-of-buffer-p mark) (forward-object mark 1) (if (search-forward mark (coerce (paragraph-delimiter syntax) 'vector)) - (progn (backward-object mark (length (paragraph-delimiter syntax))) - t) - (progn (end-of-buffer mark) - nil)))) + (backward-object mark (length (paragraph-delimiter syntax))) + (end-of-buffer mark)) + t)) (define-motion-fns paragraph) From thenriksen at common-lisp.net Tue Jan 15 07:27:15 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 15 Jan 2008 02:27:15 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080115072715.673335E40A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv31482/Drei Modified Files: syntax.lisp Log Message: Removed default method on update-syntax that did nothing but confuse the results and sometimes lower performance. --- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/01/13 10:33:10 1.14 +++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/01/15 07:27:14 1.15 @@ -94,11 +94,7 @@ 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) - (:method values-max-min ((syntax syntax) (unchanged-prefix integer) - (unchanged-suffix integer) &optional (begin 0) - (end (- (size (buffer syntax)) unchanged-suffix))) - (values begin end))) + (:method-combination values-max-min :most-specific-last)) (defgeneric eval-defun (mark syntax)) From thenriksen at common-lisp.net Tue Jan 15 07:43:06 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 15 Jan 2008 02:43:06 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080115074306.EECB56828C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv1160/Drei Modified Files: views.lisp Log Message: Removed attempts at figuring out when not to reparse from view code, only the syntax modules can really make that decision. --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/13 10:33:10 1.18 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/15 07:43:05 1.19 @@ -662,14 +662,10 @@ force-p (begin 0) (end (size (buffer view)))) (assert (>= end begin)) ;; If nothing changed, then don't call the other methods. - (let ((high-offset (- (size (buffer view)) (suffix-size view)))) - (when (or (and (> begin (prefix-size view)) - (> high-offset begin)) - (and (> end (prefix-size view)) - (>= (prefix-size view) begin)) - (/= (size (buffer view)) (buffer-size view)) - force-p) - (call-next-method)))) + (when (or (not (= (prefix-size view) (suffix-size view) + (buffer-size view) (size (buffer view)))) + force-p) + (call-next-method))) (defmethod synchronize-view ((view drei-syntax-view) &key (begin 0) (end (size (buffer view)))) From thenriksen at common-lisp.net Tue Jan 15 07:56:15 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 15 Jan 2008 02:56:15 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080115075615.0F9B75E40A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv2727/Drei Modified Files: drei-redisplay.lisp Log Message: Removed optimisation that destroyed tab support. Also some other cleanup as a bonus. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/14 21:43:48 1.30 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/15 07:56:15 1.31 @@ -455,7 +455,7 @@ of the stroke." (loop with parts = (analyse-stroke-string stroke-string) with width = 0 - with widths = (make-array (length parts) :adjustable t :fill-pointer t) + with widths = (make-array 1 :adjustable t :fill-pointer t) with tab-width for (start end object) in parts do (cond ((and object (eql object #\Tab)) @@ -567,14 +567,12 @@ (y2 dimensions) (+ y1 line-height)))) (defun end-line-cleaning-up (stream line line-x1 line-y1 - line-width old-line-width - line-height old-line-height) + line-width line-height) "End the addition of strokes to `line' for now, and update the dimensions of `line'. Update all undisplayed lines to have no associated dimensions. Also clear from the bottom of strokes to the bottom of the line, and from the end of the line to the end of the sheet." - (declare (ignore old-line-width)) (end-line line line-x1 line-y1 line-width line-height) (with-accessors ((line-x1 x1) (line-y1 y1) (line-x2 x2) (line-y2 y2)) (line-dimensions line) @@ -603,8 +601,6 @@ buffer offset `start-offset', and will be drawn starting at (`cursor-x', `cursor-y')." (let* ((line (line-information view (displayed-lines-count view))) - (old-line-height (dimensions-height (line-dimensions line))) - (old-line-width (dimensions-width (line-dimensions line))) (orig-x-offset cursor-x) (offset-change (- start-offset (line-start-offset line))) (line-spacing (stream-vertical-spacing pane))) @@ -651,8 +647,7 @@ for stroke-dimensions = (stroke-dimensions stroke) do (draw-stroke pane view stroke (x1 stroke-dimensions) baseline) finally (progn (end-line-cleaning-up pane line orig-x-offset cursor-y - line-width old-line-width - line-height old-line-height) + line-width line-height) (incf (displayed-lines-count view)) (return (values pump-state line-height))))))) From thenriksen at common-lisp.net Tue Jan 15 08:05:10 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 15 Jan 2008 03:05:10 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20080115080510.08E5B70ED@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv4848/ESA Modified Files: esa-io.lisp Log Message: When saving a buffer with no associated pathname, act as Write Buffer. This needs some more thought, the save/write buffer dichotomy is not awesome. --- /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2008/01/13 22:22:06 1.6 +++ /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2008/01/15 08:05:09 1.7 @@ -269,18 +269,22 @@ (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. + "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 (or (null (filepath buffer)) - (needs-saving buffer)) - (handler-case (save-buffer buffer) - (buffer-writing-error (e) - (with-minibuffer-stream (minibuffer) - (let ((*print-escape* nil)) - (print-object e minibuffer))))) - (display-message "No changes need to be saved from ~a" (name 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) + (buffer-writing-error (e) + (with-minibuffer-stream (minibuffer) + (let ((*print-escape* nil)) + (print-object e minibuffer))))) + (display-message "No changes need to be saved from ~a" (name buffer)))))) (set-key 'com-save-buffer 'esa-io-table '((#\x :control) (#\s :control))) From ahefner at common-lisp.net Tue Jan 15 09:06:52 2008 From: ahefner at common-lisp.net (ahefner) Date: Tue, 15 Jan 2008 04:06:52 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Experimental/freetype Message-ID: <20080115090652.D49AB240CE@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv15462 Modified Files: freetype-fonts.lisp Log Message: Fix busted text size calculation in the fixed-width path. Typed (length string), meant (- end start). Could happen to anyone. --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/13 23:02:34 1.17 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/15 09:06:52 1.18 @@ -252,15 +252,15 @@ ;; out of here, but I doubt it would shave more than a few percent ;; off a draw-text benchmark. (macrolet ((compute () - `(loop with cache = (slot-value font 'glyph-width-cache) + `(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 cache code) - (gcache-set cache code (clim-clx::font-glyph-width font 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) (length string)) + (* (slot-value font 'fixed-width) (- end start)) (typecase string (simple-string (locally (declare (type simple-string string)) From thenriksen at common-lisp.net Tue Jan 15 09:10:29 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 15 Jan 2008 04:10:29 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080115091029.0A30C240F1@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv15912/Drei Modified Files: drei-redisplay.lisp Log Message: Removed unused values in a multiple-value-bind. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/15 07:56:15 1.31 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/15 09:10:29 1.32 @@ -465,18 +465,16 @@ (mod (+ width x-position) tab-width))) (vector-push-extend width widths)) (object - (multiple-value-bind (w ignore1 ignore2 ignore3 ignore4) + (multiple-value-bind (w) (text-size stream object :text-style text-style) - (declare (ignore ignore1 ignore2 ignore3 ignore4)) (incf width w) (vector-push-extend width widths))) (t - (multiple-value-bind (w ignore1 ignore2 ignore3 ignore4) + (multiple-value-bind (w) (text-size stream stroke-string :start start :end end :text-style text-style) - (declare (ignore ignore1 ignore2 ignore3 ignore4)) (incf width w) (vector-push-extend width widths)))) finally (return (values width parts widths)))) From thenriksen at common-lisp.net Tue Jan 15 09:35:28 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 15 Jan 2008 04:35:28 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080115093528.33BFE554BD@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv20463/Drei Modified Files: drei-redisplay.lisp Log Message: Fixed drawing of tabs, I thinl --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/15 09:10:29 1.32 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/15 09:35:27 1.33 @@ -409,9 +409,19 @@ (y2 dimensions) y2 (center dimensions) center))) -(defconstant +roman-face-style+ (make-text-style nil :roman nil) - "A text style specifying a roman face, but with unspecified -family and size.") +(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 @@ -432,20 +442,6 @@ into parts finally (return parts))) -(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 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 @@ -458,7 +454,7 @@ with widths = (make-array 1 :adjustable t :fill-pointer t) with tab-width for (start end object) in parts - do (cond ((and object (eql object #\Tab)) + do (cond ((eql object #\Tab) (incf width (- (or tab-width (setf tab-width (tab-width stream (stream-default-view stream)))) @@ -479,6 +475,10 @@ (vector-push-extend width widths)))) finally (return (values width parts widths)))) +(defconstant +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 @@ -515,7 +515,7 @@ (when draw (loop for (start end object) in stroke-parts for width across part-widths - do (cond ((and object (eq object #\Tab)) + do (cond ((eql object #\Tab) nil) (object (draw-text* stream object (+ cursor-x width) @@ -540,7 +540,8 @@ 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 (= cursor-x (x1 (stroke-dimensions stroke))) + (unless (and (= cursor-x (x1 (stroke-dimensions stroke))) + (not (stroke-dirty stroke))) (invalidate-stroke stroke :modified t)) (when (stroke-dirty stroke) (funcall (drawing-options-function (stroke-drawing-options stroke)) stream view stroke From thenriksen at common-lisp.net Tue Jan 15 14:08:19 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 15 Jan 2008 09:08:19 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080115140819.C031E5C000@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv18243/Drei Modified Files: drei-redisplay.lisp views.lisp Log Message: Reintroduce early support for long lines (and horizontal scrolling) in Drei. Still doesn't deal properly with cursors, and is very eager at scrolling back. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/15 09:35:27 1.33 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/15 14:08:19 1.34 @@ -547,14 +547,17 @@ (funcall (drawing-options-function (stroke-drawing-options stroke)) stream view stroke cursor-x cursor-y #'stroke-drawing-fn nil))) -(defun draw-stroke (stream view stroke cursor-x cursor-y) - "Draw `stroke' on `stream' with a baseline at +(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 -informational. Nothing will be done unless `stroke' is dirty." +information. Nothing will be done unless `stroke' is dirty." (when (stroke-dirty stroke) + (when (> (x2 (stroke-dimensions stroke)) + (bounding-rectangle-width pane)) + (change-space-requirements pane :width (x2 (stroke-dimensions stroke)))) (funcall (drawing-options-function (stroke-drawing-options stroke)) - stream view stroke cursor-x cursor-y #'stroke-drawing-fn t))) + pane view stroke cursor-x cursor-y #'stroke-drawing-fn t))) (defun end-line (line x1 y1 line-width line-height) "End the addition of strokes to `line' for now, and update the @@ -565,7 +568,7 @@ (x2 dimensions) (+ x1 line-width) (y2 dimensions) (+ y1 line-height)))) -(defun end-line-cleaning-up (stream line line-x1 line-y1 +(defun end-line-cleaning-up (view pane line line-x1 line-y1 line-width line-height) "End the addition of strokes to `line' for now, and update the dimensions of `line'. Update all undisplayed lines to have no @@ -575,6 +578,9 @@ (end-line line line-x1 line-y1 line-width line-height) (with-accessors ((line-x1 x1) (line-y1 y1) (line-x2 x2) (line-y2 y2)) (line-dimensions line) + (setf (max-line-width view) + (max (max-line-width view) + (dimensions-width (line-dimensions line)))) ;; If a has a lesser height than the line, clear from the top of ;; the line stroke to the top of the stroke, to avoid artifacts ;; left over from previous redisplays. @@ -583,7 +589,7 @@ (with-accessors ((stroke-x1 x1) (stroke-y1 y1) (stroke-x2 x2) (stroke-y2 y2)) stroke-dimensions (when (> line-height (dimensions-height stroke-dimensions)) - (clear-rectangle* stream stroke-x1 line-y1 + (clear-rectangle* pane stroke-x1 line-y1 stroke-x2 stroke-y1))))) ;; Reset the dimensions of undisplayed lines. (do-undisplayed-line-strokes (stroke line) @@ -645,7 +651,7 @@ 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 pane line orig-x-offset cursor-y + finally (progn (end-line-cleaning-up view pane line orig-x-offset cursor-y line-width line-height) (incf (displayed-lines-count view)) (return (values pump-state line-height))))))) @@ -882,6 +888,54 @@ (when (> br-height (bounding-rectangle-height stream)) (change-space-requirements stream :height br-height)))) +(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)) + (max-x2 0)) + (do-displayed-lines (line view) + (setf max-x2 (max max-x2 + (x2 (line-dimensions line))))) + (values (x1 (line-dimensions first-line)) + (y1 (line-dimensions first-line)) + max-x2 + (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*'. Takes the cursors of `drei-instance' into +account." + (multiple-value-bind (x1 y1 x2 y2) + (view-bounding-rectangle* (view drei-instance)) + (dolist (cursor (cursors drei-instance)) + (multiple-value-bind (cursor-x1 cursor-y1 cursor-x2 cursor-y2) + (bounding-rectangle* cursor) + (unless (= cursor-x1 cursor-y1 cursor-x2 cursor-y2 0) + (setf x1 (min x1 cursor-x1) + y1 (min y1 cursor-y1) + x2 (max x2 cursor-x2) + y2 (max y2 cursor-y2))))) + (values x1 y1 x2 y2))) + +(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. @@ -903,13 +957,14 @@ (height (+ ascent descent))) (multiple-value-bind (x1 y1 x2 y2) (call-next-method) - (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))) + (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))))))) ;; XXX: Full redraw for every replay, should probably use the `region' @@ -949,25 +1004,21 @@ (defun display-drei-area (drei) (with-accessors ((stream editor-pane) (view view)) drei (replay drei stream) - (with-bounding-rectangle* (dx1 dy1 dx2 dy2) drei - (declare (ignore dx1 dy1 dy2)) - (when (point-cursor drei) - (with-bounding-rectangle* (x1 y1 x2 y2) (point-cursor drei) - (apply #'change-space-requirements stream (when (> x2 dx2) - (list :width x2))) - (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))))))))))) + (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)))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -1019,7 +1070,7 @@ has `view'.")) (defmethod fix-pane-viewport ((pane drei-pane) (view drei-view)) - (let* ((output-width (bounding-rectangle-width (stream-current-output-record pane))) + (let* ((output-width (bounding-rectangle-width view)) (viewport (pane-viewport pane)) (viewport-width (and viewport (bounding-rectangle-width viewport))) (pane-width (bounding-rectangle-width pane))) --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/15 07:43:05 1.19 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/15 14:08:19 1.20 @@ -532,7 +532,12 @@ :type integer :documentation "The number of lines in the views `displayed-lines' array that are actually live, that -is, used for display right now.")) +is, used for display right now.") + (%max-line-width :accessor max-line-width + :initform 0 + :type integer + :documentation "The width of the longest +displayed line in device units.")) (:metaclass modual-class) (:documentation "A view that contains a `drei-buffer' object. The buffer is displayed on a simple line-by-line basis, @@ -562,13 +567,6 @@ (setf (fill-pointer string) 0) string)) -(defmethod observer-notified ((view drei-buffer-view) (buffer drei-buffer) - changed-region) - (dotimes (i (displayed-lines-count view)) - (let ((line (line-information view i))) - (when (<= (car changed-region) (line-end-offset line)) - (invalidate-line-strokes line :modified t))))) - (defclass drei-syntax-view (drei-buffer-view) ((%syntax :accessor syntax :documentation "An instance of the syntax class used From crhodes at common-lisp.net Tue Jan 15 15:45:17 2008 From: crhodes at common-lisp.net (crhodes) Date: Tue, 15 Jan 2008 10:45:17 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080115154517.4B9E96913C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv8335 Modified Files: regions.lisp Log Message: Frob standard-ellipse and standard-elliptical-arc superclasses (Otherwise, methods on clim:design are more specific than methods on climi::elliptical-thing, which means that everything goes haywire.) --- /project/mcclim/cvsroot/mcclim/regions.lisp 2008/01/14 07:03:18 1.35 +++ /project/mcclim/cvsroot/mcclim/regions.lisp 2008/01/15 15:45:17 1.36 @@ -4,7 +4,7 @@ ;;; Created: 1998-12-02 19:26 ;;; Author: Gilbert Baumann ;;; License: LGPL (See file COPYING for details). -;;; $Id: regions.lisp,v 1.35 2008/01/14 07:03:18 ahefner Exp $ +;;; $Id: regions.lisp,v 1.36 2008/01/15 15:45:17 crhodes Exp $ ;;; -------------------------------------------------------------------------------------- ;;; (c) copyright 1998,1999,2001 by Gilbert Baumann ;;; (c) copyright 2001 by Arnaud Rouanet (rouanet at emi.u-bordeaux.fr) @@ -552,8 +552,8 @@ (and end-angle (* (/ 180 pi) end-angle)) tr))) -(defclass standard-ellipse (ellipse elliptical-thing) ()) -(defclass standard-elliptical-arc (elliptical-arc elliptical-thing) ()) +(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 --------- From thenriksen at common-lisp.net Tue Jan 15 15:53:54 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 15 Jan 2008 10:53:54 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080115155354.2B0D824004@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv10638/Drei Modified Files: lisp-syntax.lisp Log Message: Removed superfluous (drei-motion:define-motion-fns list). --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/13 17:10:24 1.67 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/15 15:53:53 1.68 @@ -2133,8 +2133,6 @@ do (setf (offset mark) (start-offset potential-form)) (return t))) -(drei-motion:define-motion-fns list) - (defun down-list (mark syntax selector next-offset-fn target-offset-fn) (update-parse syntax 0 (offset mark)) (labels ((next (continue-from) From crhodes at common-lisp.net Tue Jan 15 16:24:23 2008 From: crhodes at common-lisp.net (crhodes) Date: Tue, 15 Jan 2008 11:24:23 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20080115162423.04C5A5C181@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv21737/ESA Modified Files: esa-io.lisp Log Message: Fix another file-write-date issue. --- /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2008/01/15 08:05:09 1.7 +++ /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2008/01/15 16:24:23 1.8 @@ -236,7 +236,7 @@ (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 (file-write-date filepath)) + (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 From thenriksen at common-lisp.net Tue Jan 15 18:43:29 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 15 Jan 2008 13:43:29 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080115184329.4EE8555355@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv4273/Drei Modified Files: drei-clim.lisp drei-redisplay.lisp views.lisp Log Message: Alright! Horizontal-scrolling workage, I think. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/11 02:44:13 1.28 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/15 18:43:28 1.29 @@ -346,9 +346,13 @@ (defmethod initialize-instance :after ((area drei-area) &key) (setf (input-editor-position area) - (multiple-value-list (output-record-position area))) + (multiple-value-list (output-record-position area)) + (extend-pane-bottom (view area)) t) (tree-recompute-extent area)) +(defmethod (setf view) :after ((new-view drei-view) (drei drei-area)) + (setf (extend-pane-bottom new-view) t)) + (defmethod esa-current-window ((drei drei-area)) (editor-pane drei)) --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/15 14:08:19 1.34 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/15 18:43:29 1.35 @@ -556,6 +556,9 @@ (when (> (x2 (stroke-dimensions stroke)) (bounding-rectangle-width pane)) (change-space-requirements pane :width (x2 (stroke-dimensions stroke)))) + (when (> (y2 (stroke-dimensions stroke)) + (bounding-rectangle-height pane)) + (change-space-requirements pane :height (y2 (stroke-dimensions stroke)))) (funcall (drawing-options-function (stroke-drawing-options stroke)) pane view stroke cursor-x cursor-y #'stroke-drawing-fn t))) @@ -744,7 +747,8 @@ actual-end-offset))) (defmethod display-drei-view-contents ((pane basic-pane) (view drei-buffer-view)) - (setf (displayed-lines-count view) 0) + (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 with start-offset = (offset (beginning-of-line (top view))) @@ -756,7 +760,8 @@ (setf pump-state new-pump-state start-offset (1+ (line-end-offset line))) (incf cursor-y (+ line-height (stream-vertical-spacing pane)))) - when (or (>= (y2 (line-dimensions line)) pane-height) + 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)) @@ -848,6 +853,30 @@ (- (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)) + :width (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)) @@ -881,13 +910,6 @@ (+ cursor-x object-width) (+ cursor-y stroke-height) :ink (ink cursor)))))) -(defmethod display-drei-view-cursor :after ((stream extended-output-stream) (view drei-view) - (cursor point-cursor)) - ;; Make sure there is room for the cursor. - (let ((br-height (bounding-rectangle-height (bounding-rectangle cursor)))) - (when (> br-height (bounding-rectangle-height stream)) - (change-space-requirements stream :height br-height)))) - (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 @@ -895,14 +917,10 @@ (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)) - (max-x2 0)) - (do-displayed-lines (line view) - (setf max-x2 (max max-x2 - (x2 (line-dimensions line))))) + (last-line (last-displayed-line view))) (values (x1 (line-dimensions first-line)) (y1 (line-dimensions first-line)) - max-x2 + (max-line-width view) (y2 (line-dimensions last-line)))))) (defmethod bounding-rectangle-width ((view drei-buffer-view)) @@ -1070,34 +1088,33 @@ has `view'.")) (defmethod fix-pane-viewport ((pane drei-pane) (view drei-view)) - (let* ((output-width (bounding-rectangle-width 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 (or (> output-width pane-width) - (and viewport - (> pane-width viewport-width) - (>= viewport-width output-width))) + (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)) - (multiple-value-bind (cursor-x cursor-y line-height object-width) - (offset-to-screen-position pane view (offset (point view))) + (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 ((> (+ cursor-x object-width) (+ x-position viewport-width)) - (move-sheet pane (round (- (- cursor-x viewport-width))) 0)) - ((> x-position (+ cursor-x object-width)) - (move-sheet pane (if (> viewport-width cursor-x) - 0 - (round (- cursor-x))) - 0))) - (when (> (+ cursor-y line-height) (+ y-position viewport-height)) + (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 (> y2 (+ y-position viewport-height)) (full-redisplay pane) ;; We start all over! (display-drei-pane (pane-frame pane) pane))))))) --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/15 14:08:19 1.20 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/15 18:43:29 1.21 @@ -435,7 +435,14 @@ 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.")) +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 From thenriksen at common-lisp.net Tue Jan 15 19:31:57 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 15 Jan 2008 14:31:57 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080115193157.0B2CA761AC@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv31123/Drei Modified Files: drei-redisplay.lisp Log Message: Oops, no such thing as view-bounding-rectangle. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/15 18:43:29 1.35 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/15 19:31:54 1.36 @@ -935,7 +935,7 @@ `bounding-rectangle*'. Takes the cursors of `drei-instance' into account." (multiple-value-bind (x1 y1 x2 y2) - (view-bounding-rectangle* (view drei-instance)) + (bounding-rectangle* (view drei-instance)) (dolist (cursor (cursors drei-instance)) (multiple-value-bind (cursor-x1 cursor-y1 cursor-x2 cursor-y2) (bounding-rectangle* cursor) From thenriksen at common-lisp.net Tue Jan 15 23:17:50 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 15 Jan 2008 18:17:50 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080115231750.9432E4814D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv20557 Modified Files: NEWS Log Message: Mention label-pane fix. --- /project/mcclim/cvsroot/mcclim/NEWS 2008/01/14 19:06:52 1.29 +++ /project/mcclim/cvsroot/mcclim/NEWS 2008/01/15 23:17:50 1.30 @@ -10,6 +10,7 @@ *** New redisplay engine that is faster and has more features. *** Support for "views" concept. *** Support for modes a la Emacs "mini-modes". +** Bug fix: label panes no longer have a restrictive maximum width. * Changes in mcclim-0.9.5 relative to 0.9.4: ** Installation: the systems clim-listener, clim-examples, From thenriksen at common-lisp.net Wed Jan 16 09:03:26 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 16 Jan 2008 04:03:26 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080116090326.D14BA6A03D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv11323/Drei Modified Files: views.lisp Log Message: Fixed post-edit cursor positioning for Drei areas. --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/15 18:43:29 1.21 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/16 09:03:26 1.22 @@ -542,7 +542,7 @@ is, used for display right now.") (%max-line-width :accessor max-line-width :initform 0 - :type integer + :type number :documentation "The width of the longest displayed line in device units.")) (:metaclass modual-class) From thenriksen at common-lisp.net Wed Jan 16 09:03:27 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 16 Jan 2008 04:03:27 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080116090327.6BEDC6A03A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv11323 Modified Files: input-editing-drei.lisp Log Message: Fixed post-edit cursor positioning for Drei areas. --- /project/mcclim/cvsroot/mcclim/input-editing-drei.lisp 2006/12/03 19:18:06 1.4 +++ /project/mcclim/cvsroot/mcclim/input-editing-drei.lisp 2008/01/16 09:03:27 1.5 @@ -101,15 +101,6 @@ (define-condition rescan-condition (condition) ()) -(defun reposition-stream-cursor (stream) - "Moves the cursor somewhere clear of the 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)))) - (defgeneric finalize (editing-stream input-sensitizer) (:documentation "Do any cleanup on an editing stream, like turning off the cursor, etc.")) @@ -127,7 +118,8 @@ (stream-add-output-record real-stream record) (when (stream-drawing-p real-stream) (replay record real-stream))))) - (reposition-stream-cursor real-stream))) + (setf (stream-cursor-position real-stream) + (values 0 (nth-value 3 (input-editing-stream-bounding-rectangle stream)))))) (defgeneric invoke-with-input-editing (stream continuation input-sensitizer initial-contents class)) @@ -189,7 +181,7 @@ (immediate-rescan stream))) (defmethod input-editing-stream-bounding-rectangle ((stream standard-input-editing-stream)) - (bounding-rectangle* (drei:drei-instance stream))) + (bounding-rectangle* (view (drei:drei-instance stream)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From thenriksen at common-lisp.net Wed Jan 16 12:01:06 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 16 Jan 2008 07:01:06 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080116120106.2C5BB5625A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv18517/Drei Modified Files: drei-redisplay.lisp Log Message: Removed some seemingly unnecessary code from the input-editor Drei variant. I admit I never really fully grasped how it worked, and I may need someone with major output-record foo to help me figure out the last bugs. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/15 19:31:54 1.36 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/16 12:01:05 1.37 @@ -990,19 +990,9 @@ (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-current-output-record stream) drei) - ((stream-cursor-position stream) (values-list (input-editor-position drei)))) - ;; XXX: If the display begins with a blank area - for example - ;; spaces - CLIM will (rightly) think the output records - ;; position is at the first output. This is not good, because - ;; it means that the output record will "walk" across the - ;; screen if the buffer starts with blanks. Therefore, we make - ;; sure that an output record exists at the very beginning of - ;; the output. - (with-new-output-record (stream 'standard-sequence-output-record record) - (invalidate-all-strokes (view drei)) - (display-drei-view-contents stream (view drei)) - (setf (output-record-position record) (values-list (input-editor-position drei)))))) + (letf (((stream-cursor-position stream) (values-list (input-editor-position drei)))) + (invalidate-all-strokes (view drei)) + (display-drei-view-contents stream (view drei)))) (defmethod replay-output-record :after ((drei drei-area) (stream extended-output-stream) &optional (x-offset 0) (y-offset 0) (region +everywhere+)) @@ -1014,10 +1004,9 @@ (x-offset 0) (y-offset 0) (region +everywhere+)) (declare (ignore x-offset y-offset region)) (clear-output-record cursor) - (when (active cursor) - (with-output-recording-options (stream :record t :draw nil) - (letf (((stream-current-output-record stream) cursor)) - (display-drei-view-cursor stream (view cursor) cursor))))) + (with-output-recording-options (stream :record t :draw nil) + (when (active cursor) + (display-drei-view-cursor stream (view cursor) cursor)))) (defun display-drei-area (drei) (with-accessors ((stream editor-pane) (view view)) drei From thenriksen at common-lisp.net Wed Jan 16 13:12:41 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 16 Jan 2008 08:12:41 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080116131241.3530D610BE@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv13598/Drei Modified Files: drei-redisplay.lisp Log Message: More redisplay optimisations (so fast!). Also, don't end in an infinite loop if we can't even fit a single line on the screen. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/16 12:01:05 1.37 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/16 13:12:40 1.38 @@ -541,7 +541,9 @@ 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))) - (not (stroke-dirty 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 @@ -571,36 +573,14 @@ (x2 dimensions) (+ x1 line-width) (y2 dimensions) (+ y1 line-height)))) -(defun end-line-cleaning-up (view pane line line-x1 line-y1 +(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'. Update all undisplayed lines to have no -associated dimensions. Also clear from the bottom of strokes to -the bottom of the line, and from the end of the line to the end -of the sheet." +dimensions of `line'." (end-line line line-x1 line-y1 line-width line-height) - (with-accessors ((line-x1 x1) (line-y1 y1) - (line-x2 x2) (line-y2 y2)) (line-dimensions line) - (setf (max-line-width view) - (max (max-line-width view) - (dimensions-width (line-dimensions line)))) - ;; If a has a lesser height than the line, clear from the top of - ;; the line stroke to the top of the stroke, to avoid artifacts - ;; left over from previous redisplays. - (do-displayed-line-strokes (stroke line) - (let ((stroke-dimensions (stroke-dimensions stroke))) - (with-accessors ((stroke-x1 x1) (stroke-y1 y1) - (stroke-x2 x2) (stroke-y2 y2)) stroke-dimensions - (when (> line-height (dimensions-height stroke-dimensions)) - (clear-rectangle* pane stroke-x1 line-y1 - stroke-x2 stroke-y1))))) - ;; Reset the dimensions of undisplayed lines. - (do-undisplayed-line-strokes (stroke line) - (let ((stroke-dimensions (stroke-dimensions stroke))) - (with-accessors ((stroke-x1 x1) (stroke-y1 y1) - (stroke-x2 x2) (stroke-y2 y2)) stroke-dimensions - (setf stroke-x1 0 stroke-y1 0 - stroke-x2 0 stroke-y2 0)))))) + (setf (max-line-width view) + (max (max-line-width view) + (dimensions-width (line-dimensions line))))) (defun draw-line-strokes (pane view initial-pump-state start-offset cursor-x cursor-y) @@ -654,7 +634,7 @@ 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 pane line orig-x-offset cursor-y + 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))))))) @@ -1103,7 +1083,8 @@ 0 (round x1)) 0))) - (when (> y2 (+ y-position viewport-height)) + (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))))))) From thenriksen at common-lisp.net Wed Jan 16 15:19:30 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 16 Jan 2008 10:19:30 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080116151930.D9282640D7@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv15022/Drei Modified Files: drei-redisplay.lisp Log Message: More input-editor redisplay simplications. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/16 13:12:40 1.38 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/16 15:19:30 1.39 @@ -972,19 +972,15 @@ (declare (ignore x-offset y-offset region)) (letf (((stream-cursor-position stream) (values-list (input-editor-position drei)))) (invalidate-all-strokes (view drei)) - (display-drei-view-contents stream (view drei)))) - -(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)) + (display-drei-view-contents stream (view drei))) (dolist (cursor (cursors drei)) (replay cursor stream))) -(defmethod replay-output-record :before ((cursor drei-cursor) stream &optional - (x-offset 0) (y-offset 0) (region +everywhere+)) +(defmethod replay-output-record ((cursor drei-cursor) stream &optional + (x-offset 0) (y-offset 0) (region +everywhere+)) (declare (ignore x-offset y-offset region)) (clear-output-record cursor) - (with-output-recording-options (stream :record t :draw nil) + (with-output-recording-options (stream :record nil :draw t) (when (active cursor) (display-drei-view-cursor stream (view cursor) cursor)))) From thenriksen at common-lisp.net Wed Jan 16 17:11:52 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 16 Jan 2008 12:11:52 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080116171152.C9F0A55355@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv11063/Drei Modified Files: drei-clim.lisp Log Message: Respect the :x-position and :y-position initargs for Drei areas. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/15 18:43:28 1.29 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/16 17:11:52 1.30 @@ -344,9 +344,10 @@ record.")) (defmethod initialize-instance :after ((area drei-area) - &key) - (setf (input-editor-position area) - (multiple-value-list (output-record-position area)) + &key x-position y-position) + (check-type x-position integer) + (check-type y-position integer) + (setf (input-editor-position area) (list x-position y-position) (extend-pane-bottom (view area)) t) (tree-recompute-extent area)) From thenriksen at common-lisp.net Wed Jan 16 18:32:33 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 16 Jan 2008 13:32:33 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080116183233.4BA8E4F01A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv29806/Drei Modified Files: drei-redisplay.lisp Log Message: Output recording must be enabled when drawing cursors, or auto-scrolling won't work. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/16 15:19:30 1.39 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/16 18:32:33 1.40 @@ -980,7 +980,7 @@ (x-offset 0) (y-offset 0) (region +everywhere+)) (declare (ignore x-offset y-offset region)) (clear-output-record cursor) - (with-output-recording-options (stream :record nil :draw t) + (with-output-recording-options (stream :record t :draw t) (when (active cursor) (display-drei-view-cursor stream (view cursor) cursor)))) From thenriksen at common-lisp.net Wed Jan 16 21:30:05 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 16 Jan 2008 16:30:05 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080116213005.826A855357@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv29581/Drei Modified Files: drei.lisp Log Message: Added simple print-object method for Drei instances. --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/13 10:33:09 1.26 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/16 21:30:04 1.27 @@ -343,6 +343,10 @@ (defmethod esa-current-window ((drei drei)) drei) +(defmethod print-object ((object drei) stream) + (print-unreadable-object (object stream :type t :identity t) + (format stream "~A" (type-of (view object))))) + ;; Main redisplay entry point. (defgeneric display-drei (drei) (:documentation "`Drei' must be an object of type `drei' and From thenriksen at common-lisp.net Wed Jan 16 22:40:16 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 16 Jan 2008 17:40:16 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080116224016.EAC7C5E121@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv10409/Drei Modified Files: drei-redisplay.lisp Log Message: Clean and fix some more Drei input-editor related redisplay stuff. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/16 18:32:33 1.40 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/16 22:40:14 1.41 @@ -954,7 +954,12 @@ (descent (text-style-descent style pane)) (height (+ ascent descent))) (multiple-value-bind (x1 y1 x2 y2) - (call-next-method) + (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 (input-editor-position drei)) + y1 (second (input-editor-position drei)))) (values x1 y1 (max x2 (+ x1 style-width) (cond ((numberp min-width) @@ -965,6 +970,10 @@ (t 0))) (max y2 (+ y1 height))))))) +(defmethod bounding-rectangle ((drei drei-area)) + (with-bounding-rectangle* (x1 y1 x2 y2) drei + (make-rectangle* x1 y1 x2 y2))) + ;; 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 @@ -986,7 +995,12 @@ (defun display-drei-area (drei) (with-accessors ((stream editor-pane) (view view)) drei + (clear-output-record drei) (replay drei stream) + (with-bounding-rectangle* (x1 y1 x2 y2) drei + (letf (((stream-current-output-record stream) drei)) + ;; XXX: This sets the size of the output record. + (draw-rectangle* stream x1 y1 x2 y2 :ink +transparent-ink+))) (when (point-cursor drei) (with-bounding-rectangle* (x1 y1 x2 y2) (point-cursor drei) (when (pane-viewport stream) @@ -1120,10 +1134,9 @@ (if (adjust-pane drei-pane) (display-drei-pane frame drei-pane) ;; Point must be on top of all other cursors. - (progn - (dolist (cursor (cursors drei-pane)) - (display-drei-view-cursor drei-pane view cursor)) - (fix-pane-viewport drei-pane (view drei-pane))))))) + (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'.")) From thenriksen at common-lisp.net Wed Jan 16 22:50:07 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 16 Jan 2008 17:50:07 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080116225007.7DF5F5B0B2@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv12491/Drei Modified Files: drei-clim.lisp Log Message: Accept all numbers, not just integers. McCLIM is very happy about fractional pixels, after all. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/16 17:11:52 1.30 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/16 22:50:06 1.31 @@ -345,8 +345,8 @@ (defmethod initialize-instance :after ((area drei-area) &key x-position y-position) - (check-type x-position integer) - (check-type y-position integer) + (check-type x-position number) + (check-type y-position number) (setf (input-editor-position area) (list x-position y-position) (extend-pane-bottom (view area)) t) (tree-recompute-extent area)) From ahefner at common-lisp.net Thu Jan 17 07:11:16 2008 From: ahefner at common-lisp.net (ahefner) Date: Thu, 17 Jan 2008 02:11:16 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20080117071116.240946D257@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv10674 Modified Files: port.lisp Log Message: Add a restart around the magic clx server path generator to use the local display. Somewhat redundant, but the restart provided by assert is not the friendliest interface, and what value it wants is not 100% obvious. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2008/01/14 04:53:11 1.131 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2008/01/17 07:11:15 1.132 @@ -167,7 +167,7 @@ (selection-timestamp :initform nil :accessor selection-timestamp) (font-families :accessor font-families))) -(defun automagic-clx-server-path () +(defun automagic-clx-server-path () (let ((name (get-environment-variable "DISPLAY"))) (assert name (name) "Environment variable DISPLAY is not set") @@ -198,6 +198,12 @@ :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 @@ -206,7 +212,7 @@ :display-id (getf path :display-id 0) :screen-id (getf path :screen-id 0) :protocol (getf path :protocol :internet)) - (automagic-clx-server-path))) + (helpfully-automagic-clx-server-path))) (setf (get :x11 :port-type) 'clx-port) (setf (get :x11 :server-path-parser) 'parse-clx-server-path) From ahefner at common-lisp.net Thu Jan 17 07:23:56 2008 From: ahefner at common-lisp.net (ahefner) Date: Thu, 17 Jan 2008 02:23:56 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20080117072356.1590E5003B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv12535 Modified Files: medium.lisp Log Message: Precompile indexed -> RGBA converter function for the most common pixel formats (that is, the ones my computers use), to avoid the delay while they're compiled the first time draw-pattern* is called. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2008/01/11 05:55:52 1.84 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2008/01/17 07:23:48 1.85 @@ -321,7 +321,7 @@ (:msbfirst #'identity)) (loop for i from 0 below num-bytes collect i))))) -(defun generate-indexed-converter-expr (rgb-masks num-bytes byte-order) +(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) @@ -409,13 +409,27 @@ (defparameter *pixel-converter-cache* (make-hash-table :test 'equal)) -(defun 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))) - (key (list rgb-masks byte-order bytes-per-pixel))) +(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 bytes-per-pixel byte-order))))))) + (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))) @@ -432,7 +446,8 @@ (if (and bytes-per-pixel (member byte-order '(:lsbfirst :msbfirst)) - (setf pixel-converter (get-indexed-converter visual-info byte-order bytes-per-pixel))) + (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 From ahefner at common-lisp.net Thu Jan 17 07:57:55 2008 From: ahefner at common-lisp.net (ahefner) Date: Thu, 17 Jan 2008 02:57:55 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Experimental/freetype Message-ID: <20080117075755.60B946413D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv14215 Modified Files: freetype-fonts.lisp mcclim-freetype.asd Added Files: fontconfig.lisp Log Message: Now that everything is working fairly reliably, break it all by changing how the font path is configured. Call fc-match for each possible family/face combination, and build the map from that, allowing fontconfig to do what it is designed for. In this way, systems using DejaVu instead of Vera work automatically, and changing the default font choices require just changing one font name rather than four filenames. Via the magic of merge-pathnames, the old approach of a relative mapping and *freetype-font-path* still works. --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/15 09:06:52 1.18 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/17 07:57:55 1.19 @@ -6,6 +6,7 @@ ;;; 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 @@ -177,7 +178,6 @@ (glyph-info glyph-id dx dy left right top))))) ;;;;;;; mcclim interface - (defclass freetype-face () ((display :initarg :display :reader freetype-face-display) (font :initarg :font :reader freetype-face-name) @@ -367,7 +367,7 @@ :very-large 18 :huge 24)) -(defparameter *families/faces* +(defparameter *vera-families/faces* '(((:fix :roman) . "VeraMono.ttf") ((:fix :italic) . "VeraMoIt.ttf") ((:fix (:bold :italic)) . "VeraMoBI.ttf") @@ -386,8 +386,7 @@ ;;; Here are alternate mappings for the DejaVu family of fonts, which ;;; are a derivative of Vera with improved unicode coverage. -#+NIL -(defparameter *families/faces* +(defparameter *dejavu-families/faces* '(((:FIX :ROMAN) . "DejaVuSansMono.ttf") ((:FIX :ITALIC) . "DejaVuSansMono-Oblique.ttf") ((:FIX (:BOLD :ITALIC)) . "DejaVuSansMono-BoldOblique.ttf") @@ -404,8 +403,9 @@ ((:SANS-SERIF (:ITALIC :BOLD)) . "DejaVuSans-BoldOblique.ttf") ((:SANS-SERIF :BOLD) . "DejaVuSans-Bold.ttf"))) +(defvar *families/faces* *vera-families/faces*) -(defvar *freetype-font-path*) +(defparameter *freetype-font-path* #p"/usr/share/fonts/truetype/ttf-dejavu/") (fmakunbound 'clim-clx::text-style-to-x-font) --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/mcclim-freetype.asd 2008/01/01 18:44:39 1.8 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/mcclim-freetype.asd 2008/01/17 07:57:55 1.9 @@ -34,46 +34,15 @@ #+sbcl ((:file "freetype-package") (:uncompiled-cl-source-file "freetype-ffi") - (:file "freetype-fonts")) + (:file "freetype-fonts") + (:file "fontconfig")) #-sbcl ((:file "freetype-package-cffi") (:uncompiled-cl-source-file "freetype-cffi") (:file "freetype-fonts-cffi"))) -;;; Freetype autodetection - -(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 - (make-pathname :directory (pathname-directory filename))))) - -(defun warn-about-unset-font-path () - (warn "~%~%NOTE:~%~ -* 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/~%~%~%")) - (defmethod perform :after ((o load-op) (s (eql (asdf:find-system :mcclim-freetype)))) - (unless - (setf (symbol-value (intern "*FREETYPE-FONT-PATH*" :mcclim-freetype)) - (find-bitstream-fonts)) - (warn-about-unset-font-path))) + "Detect fonts using fc-match" + (funcall (find-symbol (symbol-name '#:autoconfigure-fonts) :mcclim-freetype))) -(defun find-bitstream-fonts () - (with-input-from-string - (s (with-output-to-string (asdf::*verbose-out*) - (let ((code (asdf:run-shell-command "fc-match -v Bitstream Vera"))) - (unless (zerop code) - (warn "~&fc-match failed with code ~D.~%" code))))) - (parse-fontconfig-output s))) --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/fontconfig.lisp 2008/01/17 07:57:55 NONE +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/fontconfig.lisp 2008/01/17 07:57:55 1.1 ;;; -*- 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. (in-package :MCCLIM-FREETYPE) (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-bitstream-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-bitstream-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)))) From ahefner at common-lisp.net Thu Jan 17 09:54:36 2008 From: ahefner at common-lisp.net (ahefner) Date: Thu, 17 Jan 2008 04:54:36 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Experimental/freetype Message-ID: <20080117095436.860BB16054@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv10002 Modified Files: freetype-fonts.lisp Log Message: Simple implementation of ttf device fonts by their proper name (as opposed to filename), using fc-match. 'make-fontconfig-font-name' creates such a font name, given a name, size, and list of options in the syntax of fontconfig. --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/17 07:57:55 1.19 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/17 09:54:21 1.20 @@ -411,15 +411,38 @@ (defstruct freetype-device-font-name (font-file (error "missing argument")) - (size (error "missing argument"))) + (size (error "missing argument"))) -(defmethod clim-clx::text-style-to-X-font :around +(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))) - (make-free-type-face display - (freetype-device-font-name-font-file font-name) - (freetype-device-font-name-size font-name)))) + (typecase font-name + (freetype-device-font-name + (make-free-type-face display + (namestring (freetype-device-font-name-font-file font-name)) + (freetype-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-freetype-device-font-name + :font-file (find-bitstream-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) From thenriksen at common-lisp.net Thu Jan 17 11:29:56 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 17 Jan 2008 06:29:56 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080117112956.387297212B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv28700/Drei Modified Files: core-commands.lisp drei.lisp input-editor.lisp lisp-syntax-commands.lisp modes.lisp packages.lisp search-commands.lisp targets.lisp Log Message: Changed *drei-instance* to be a function (drei-instance). Change of active window in Climacs will work better now. --- /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2007/12/27 13:39:25 1.12 +++ /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2008/01/17 11:29:55 1.13 @@ -39,7 +39,7 @@ 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) *drei-instance* + (with-slots (overwrite-mode) (current-view) (setf overwrite-mode (not overwrite-mode)))) (set-key 'com-overwrite-mode @@ -212,13 +212,13 @@ "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 (view *drei-instance*)))) + (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 (view *drei-instance*)))) + (tab-space-count (current-view)))) (define-command (com-indent-line :name t :command-table indent-table) () (indent-current-line (current-view) (point))) @@ -531,7 +531,7 @@ 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)) *drei-instance* + (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))) @@ -620,8 +620,8 @@ (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 *drei-instance*) - (not (region-visible-p *drei-instance*)))) + (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) () --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/16 21:30:04 1.27 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/17 11:29:55 1.28 @@ -63,16 +63,26 @@ ;;; ;;; Convenience stuff. -(defvar *drei-instance* nil - "The currently running Drei instance.") +(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 currently running Drei instance. This function +calls `drei-instance-of' on its argument." + (drei-instance-of object)) -(defun current-view (&optional (object *drei-instance*)) +(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 (`*drei-instance*') -will be used." +provided, the currently running Drei instance will be used." (view object)) -(defun (setf current-view) (new-view &optional (object *drei-instance*)) +(defun (setf current-view) (new-view &optional (object (drei-instance))) (setf (view object) new-view)) (defun point (&optional (object (current-view))) @@ -183,14 +193,14 @@ "Prompt for a command name and arguments, then run it." (let ((item (handler-case (accept - `(command :command-table ,(command-table *drei-instance*)) + `(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))) + (execute-drei-command (drei-instance) item))) (set-key 'com-drei-extended-command 'exclusive-gadget-table @@ -207,11 +217,11 @@ "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)) + (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) + (additional-command-tables (drei-instance) table) (when (use-editor-commands-p (current-view)) '(editor-table)))) @@ -343,6 +353,9 @@ (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))))) @@ -404,21 +417,21 @@ ;; at, for example, the buffer level, after all. `(handler-case (progn , at body) (user-condition-mixin (c) - (handle-drei-condition *drei-instance* c)) + (handle-drei-condition (drei-instance) c)) (offset-before-beginning (c) - (handle-drei-condition *drei-instance* c)) + (handle-drei-condition (drei-instance) c)) (offset-after-end (c) - (handle-drei-condition *drei-instance* c)) + (handle-drei-condition (drei-instance) c)) (motion-before-beginning (c) - (handle-drei-condition *drei-instance* c)) + (handle-drei-condition (drei-instance) c)) (motion-after-end (c) - (handle-drei-condition *drei-instance* c)) + (handle-drei-condition (drei-instance) c)) (no-expression (c) - (handle-drei-condition *drei-instance* c)) + (handle-drei-condition (drei-instance) c)) (no-such-operation (c) - (handle-drei-condition *drei-instance* c)) + (handle-drei-condition (drei-instance) c)) (buffer-read-only (c) - (handle-drei-condition *drei-instance* c)))) + (handle-drei-condition (drei-instance) c)))) (defmacro with-bound-drei-special-variables ((drei-instance &key (kill-ring nil kill-ring-p) @@ -429,7 +442,7 @@ (prompt nil prompt-p)) &body body) "Evaluate `body' with a set of Drei special -variables (`*drei-instance*', `*kill-ring*', `*minibuffer*', +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 @@ -438,18 +451,17 @@ value in `drei-instance'. This macro binds all of the usual Drei special variables, but also some CLIM special variables needed for ESA-style command parsing." - `(let* ((*drei-instance* ,drei-instance) - (*esa-instance* *drei-instance*) + `(let* ((*esa-instance* ,drei-instance) (*kill-ring* ,(if kill-ring-p kill-ring - `(kill-ring *drei-instance*))) + `(kill-ring (drei-instance)))) (*minibuffer* ,(if minibuffer-p minibuffer - `(or (minibuffer *drei-instance*) *minibuffer*))) + `(or (minibuffer (drei-instance)) *minibuffer*))) (*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*))) + `(previous-command (drei-instance)))) (*extended-command-prompt* ,(if prompt-p prompt "Extended command: "))) , at body)) --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2007/12/13 07:57:15 1.21 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/01/17 11:29:55 1.22 @@ -33,7 +33,7 @@ ;; `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 + ((%drei-instance :accessor drei-instance-of :initarg :drei-instance) (%input-position :accessor input-position :initform 0) --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2008/01/14 09:14:48 1.15 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2008/01/17 11:29:55 1.16 @@ -65,7 +65,7 @@ #'(lambda (mark) (proper-line-indentation (current-view) mark)) fill-column - (tab-space-count (view *drei-instance*)) + (tab-space-count (current-view)) (current-syntax) t))))) --- /project/mcclim/cvsroot/mcclim/Drei/modes.lisp 2007/12/28 10:08:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/modes.lisp 2008/01/17 11:29:55 1.2 @@ -137,6 +137,6 @@ `(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)))) + (if (mode-enabled-p (drei-instance) ',mode-name) + (disable-mode (drei-instance) ',mode-name) + (enable-mode (drei-instance) ',mode-name)))) --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/13 22:22:05 1.41 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/17 11:29:55 1.42 @@ -302,9 +302,7 @@ #:mark #:mark-of #:current-syntax #:current-view - - ;; Info variables. - #:*drei-instance* + #:drei-instance #:drei-instance-of ;; Configuration. #:*foreground-color* --- /project/mcclim/cvsroot/mcclim/Drei/search-commands.lisp 2007/12/08 08:53:49 1.5 +++ /project/mcclim/cvsroot/mcclim/Drei/search-commands.lisp 2008/01/17 11:29:55 1.6 @@ -61,7 +61,7 @@ ((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* + (simple-search-forward (drei-instance) #'(lambda (mark) (search-forward mark string :test (case-relevant-test string))))) @@ -70,7 +70,7 @@ ((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* + (simple-search-backward (drei-instance) #'(lambda (mark) (search-backward mark string :test (case-relevant-test string))))) @@ -83,7 +83,7 @@ ((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* + (simple-search-forward (drei-instance) #'(lambda (mark) (search-word-forward mark word)))) @@ -91,7 +91,7 @@ ((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* + (simple-search-backward (drei-instance) #'(lambda (mark) (search-backward mark word)))) @@ -166,7 +166,7 @@ (define-command (com-isearch-forward :name t :command-table search-table) () (display-message "Isearch: ") - (isearch-command-loop *drei-instance* t)) + (isearch-command-loop (drei-instance) t)) (set-key 'com-isearch-forward 'search-table @@ -174,14 +174,14 @@ (define-command (com-isearch-backward :name t :command-table search-table) () (display-message "Isearch backward: ") - (isearch-command-loop *drei-instance* nil)) + (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*)) + (let* ((states (isearch-states (drei-instance))) (string (concatenate 'string (search-string (first states)) (string char))) @@ -189,7 +189,7 @@ (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))) + (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*)) @@ -198,7 +198,7 @@ (isearch-append-char #\Newline)) (defun isearch-append-text (movement-function) - (let* ((states (isearch-states *drei-instance*)) + (let* ((states (isearch-states (drei-instance))) (start (clone-mark (point))) (mark (clone-mark (search-mark (first states)))) (forwardp (search-forward-p (first states)))) @@ -212,7 +212,7 @@ 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)))) + (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))))) @@ -221,7 +221,7 @@ (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*)) + (let* ((states (isearch-states (drei-instance))) (yank (handler-case (kill-ring-yank *kill-ring*) (empty-kill-ring () ""))) @@ -232,19 +232,19 @@ (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))) + (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*))) + (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 *drei-instance*)) + (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 (drei-instance))) (if (search-forward-p state) (+ (offset (search-mark state)) (length (search-string state))) @@ -255,26 +255,26 @@ (display-string (search-string state))))))) (define-command (com-isearch-search-forward :name t :command-table isearch-drei-table) () - (let* ((states (isearch-states *drei-instance*)) + (let* ((states (isearch-states (drei-instance))) (string (if (null (second states)) - (isearch-previous-string *drei-instance*) + (isearch-previous-string (drei-instance)) (search-string (first states)))) (mark (clone-mark (point)))) - (isearch-from-mark *drei-instance* mark string t))) + (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*)) + (let* ((states (isearch-states (drei-instance))) (string (if (null (second states)) - (isearch-previous-string *drei-instance*) + (isearch-previous-string (drei-instance)) (search-string (first states)))) (mark (clone-mark (point)))) - (isearch-from-mark *drei-instance* mark string nil))) + (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*)) + (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) + (setf (isearch-mode (drei-instance)) nil) (when (string= string "") (execute-frame-command *application-frame* (funcall @@ -343,7 +343,7 @@ t)))) (define-command (com-query-replace :name t :command-table search-table) () - (let* ((drei *drei-instance*) + (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))) @@ -394,7 +394,7 @@ '((#\% :shift :meta))) (define-command (com-query-replace-replace :name t :command-table query-replace-drei-table) () - (let ((state (query-replace-state *drei-instance*))) + (let ((state (query-replace-state (drei-instance)))) (with-accessors ((string1 string1) (string2 string2) (occurrences occurrences) @@ -410,13 +410,13 @@ (if (query-replace-find-next-match state) (display-message "Replace ~A with ~A:" string1 string2) - (setf (query-replace-mode *drei-instance*) nil)))))) + (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*))) + (let ((state (query-replace-state (drei-instance)))) (with-accessors ((string1 string1) (string2 string2) (occurrences occurrences) @@ -429,13 +429,13 @@ string2 (no-upper-p string1)) (incf occurrences) - (setf (query-replace-mode *drei-instance*) nil))))) + (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*))) + (let ((state (query-replace-state (drei-instance)))) (with-accessors ((string1 string1) (string2 string2) (occurrences occurrences) @@ -449,19 +449,19 @@ (no-upper-p string1)) (incf occurrences) while (query-replace-find-next-match state) - finally (setf (query-replace-mode *drei-instance*) nil)))))) + 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*))) + (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))))) + (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)) + (setf (query-replace-mode (drei-instance)) nil)) (defun query-replace-set-key (gesture command) (add-command-to-command-table command 'query-replace-drei-table @@ -497,7 +497,7 @@ :delimiter-gestures nil :activation-gestures '(:newline :return)))) - (simple-search-forward *drei-instance* + (simple-search-forward (drei-instance) #'(lambda (mark) (re-search-forward mark (normalise-minibuffer-regex string)))))) @@ -506,7 +506,7 @@ :delimiter-gestures nil :activation-gestures '(:newline :return)))) - (simple-search-backward *drei-instance* + (simple-search-backward (drei-instance) #'(lambda (mark) (re-search-backward mark (normalise-minibuffer-regex string)))))) --- /project/mcclim/cvsroot/mcclim/Drei/targets.lisp 2007/12/08 08:53:49 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/targets.lisp 2008/01/17 11:29:55 1.3 @@ -27,7 +27,7 @@ (in-package :drei-core) (defclass target-specification () - ((%drei :reader drei-instance + ((%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, From thenriksen at common-lisp.net Thu Jan 17 13:42:27 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 17 Jan 2008 08:42:27 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080117134227.DFBC53C092@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv1537/Drei Modified Files: drei-redisplay.lisp Log Message: Fixed obscure case where the height of a line was sometimes miscalculated by Drei. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/16 22:40:14 1.41 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/17 13:42:22 1.42 @@ -596,7 +596,7 @@ (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 line-height baseline pump-state) + (multiple-value-bind (line-width baseline descent pump-state) ;; Pump all the line strokes and calculate their dimensions. (loop for index from 0 for stroke = (line-stroke-information line index) @@ -605,39 +605,41 @@ (put-stroke view line pump-state offset-change) do (update-stroke-dimensions pane view stroke cursor-x cursor-y) (setf cursor-x (x2 stroke-dimensions)) - maximizing (dimensions-height stroke-dimensions) into line-height + 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 line-height baseline pump-state)) - ;; 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) + 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 (bounding-rectangle-width pane)))) + ;; 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 (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 (bounding-rectangle-width pane)))) - ;; 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))))))) + 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) "Clear from the last displayed line to the end of `pane'." From thenriksen at common-lisp.net Thu Jan 17 17:01:48 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 17 Jan 2008 12:01:48 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080117170148.A65A94F025@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv15799/Drei Modified Files: drawing-options.lisp Log Message: Changed a defparameter to defvar. --- /project/mcclim/cvsroot/mcclim/Drei/drawing-options.lisp 2008/01/12 11:44:56 1.4 +++ /project/mcclim/cvsroot/mcclim/Drei/drawing-options.lisp 2008/01/17 17:01:47 1.5 @@ -75,7 +75,7 @@ and special operators, in most other languages, it should probably be used for language keywords.") -(defparameter *special-variable-drawing-options* +(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 From thenriksen at common-lisp.net Thu Jan 17 17:25:32 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 17 Jan 2008 12:25:32 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080117172532.109A131062@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv21050/Drei Modified Files: drei-redisplay.lisp Log Message: Fixed truly obscure case where stale information from old strokes was accidentally reused. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/17 13:42:22 1.42 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/17 17:25:31 1.43 @@ -381,7 +381,7 @@ (old-end-offset (stroke-end-offset stroke)) (old-drawing-options (stroke-drawing-options stroke))) (prog1 (stroke-pump view stroke pump-state) - (unless (and old-end-offset + (unless (and old-start-offset (= (+ old-start-offset line-change) (stroke-start-offset stroke)) (= (+ old-end-offset line-change) (stroke-end-offset stroke)) (drawing-options-equal old-drawing-options @@ -580,7 +580,15 @@ (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))))) + (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) + (setf (stroke-start-offset stroke) nil)))) (defun draw-line-strokes (pane view initial-pump-state start-offset cursor-x cursor-y) From thenriksen at common-lisp.net Thu Jan 17 23:11:06 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 17 Jan 2008 18:11:06 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080117231106.A59FB5D16E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv16451/Drei Modified Files: drei-clim.lisp drei-redisplay.lisp Log Message: Changed Drei areas to be proper and well-behaved output records. Interestingly, they ended up quite similar to parts of Goatee. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/16 22:50:06 1.31 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/17 23:11:06 1.32 @@ -319,7 +319,7 @@ (table drei-command-table)) `(exclusive-gadget-table)) -(defclass drei-area (drei standard-sequence-output-record +(defclass drei-area (drei displayed-output-record region command-processor instant-macro-execution-mixin) ((%background-ink :initarg :background-ink @@ -332,12 +332,17 @@ 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.") - (%drei-position :accessor input-editor-position - :initarg :input-editor-position - :documentation "The position of the Drei + (%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.")) +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 @@ -347,9 +352,8 @@ &key x-position y-position) (check-type x-position number) (check-type y-position number) - (setf (input-editor-position area) (list x-position y-position) - (extend-pane-bottom (view area)) t) - (tree-recompute-extent area)) + (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)) @@ -360,6 +364,97 @@ (defmethod display-drei ((drei drei-area)) (display-drei-area drei)) +;;; 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)) + (setf (area-position record) (list new-x 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) (list 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)) + '()) + +(defmethod output-record-count ((record drei-area)) + 0) + +(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 function x y x-offset y-offset function-args)) + nil) + +(defmethod map-over-output-records-overlapping-region + (function (record drei-area) region + &optional (x-offset 0) (y-offset 0) + &rest function-args) + (declare (ignore function region x-offset y-offset function-args)) + nil) + +(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 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. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/17 17:25:31 1.43 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/17 23:11:06 1.44 @@ -955,41 +955,12 @@ (when errorp-supplied errorp)))) -(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)) - (ascent (text-style-ascent style pane)) - (descent (text-style-descent style pane)) - (height (+ ascent descent))) - (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 (input-editor-position drei)) - y1 (second (input-editor-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 bounding-rectangle ((drei drei-area)) - (with-bounding-rectangle* (x1 y1 x2 y2) drei - (make-rectangle* x1 y1 x2 y2))) - ;; 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) (values-list (input-editor-position drei)))) + (letf (((stream-cursor-position stream) (output-record-start-cursor-position drei))) (invalidate-all-strokes (view drei)) (display-drei-view-contents stream (view drei))) (dolist (cursor (cursors drei)) @@ -1005,12 +976,13 @@ (defun display-drei-area (drei) (with-accessors ((stream editor-pane) (view view)) drei - (clear-output-record drei) - (replay drei stream) - (with-bounding-rectangle* (x1 y1 x2 y2) drei - (letf (((stream-current-output-record stream) drei)) - ;; XXX: This sets the size of the output record. - (draw-rectangle* stream x1 y1 x2 y2 :ink +transparent-ink+))) + (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 (and (= new-x1 old-x1) (= new-y1 old-y2) + (= new-x2 old-x2) (= new-y2 old-y2)) + (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) From ahefner at common-lisp.net Fri Jan 18 06:54:50 2008 From: ahefner at common-lisp.net (ahefner) Date: Fri, 18 Jan 2008 01:54:50 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20080118065450.445937323B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv23701/Apps/Listener Modified Files: dev-commands.lisp Log Message: In Show Class Slots, make sure the class is a standard-class. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/01/11 06:00:04 1.45 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/01/18 06:54:50 1.46 @@ -675,9 +675,10 @@ :command-table show-commands :menu "Class Slots" :provide-output-destination-keyword t) - ((class-name 'clim:symbol :prompt "class name")) + ((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)))) @@ -685,6 +686,8 @@ (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) From thenriksen at common-lisp.net Fri Jan 18 08:34:46 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 18 Jan 2008 03:34:46 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080118083446.6FE121F009@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv10534/Drei Removed Files: motion-commands.lisp Log Message: Removed unused motion-commands.lisp file. From thenriksen at common-lisp.net Fri Jan 18 11:00:23 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 18 Jan 2008 06:00:23 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080118110023.BCC093C0B7@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv8387/Drei Modified Files: basic-commands.lisp views.lisp Log Message: Added line motion with goal columns. --- /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp 2007/12/21 14:22:07 1.10 +++ /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp 2008/01/18 11:00:22 1.11 @@ -137,11 +137,36 @@ ;;; Autogenerate commands (define-motion-commands word movement-table) -(define-motion-commands line 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 --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/16 09:03:26 1.22 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/18 11:00:23 1.23 @@ -734,7 +734,10 @@ (defclass point-mark-view (drei-buffer-view) ((%point :initform nil :initarg :point :accessor point-of) - (%mark :initform nil :initarg :mark :accessor mark-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.")) @@ -762,8 +765,6 @@ ((%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 next-line and previous-line commands - (%goal-column :initform nil :accessor goal-column) ;; for dynamic abbrev expansion (%original-prefix :initform nil :accessor original-prefix) (%prefix-start-offset :initform nil :accessor prefix-start-offset) From thenriksen at common-lisp.net Sat Jan 19 09:38:20 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 19 Jan 2008 04:38:20 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080119093820.D9CC34B0B2@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv26826/Drei Modified Files: input-editor.lisp Log Message: Added docstrings for input-editor related stuff. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/01/17 11:29:55 1.22 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/01/19 09:38:20 1.23 @@ -732,7 +732,10 @@ (defun add-input-editor-command (gestures function) "Set up Drei so performing `gestures' will result in the -invocation of `function' " +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*) From thenriksen at common-lisp.net Sat Jan 19 09:38:21 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 19 Jan 2008 04:38:21 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080119093821.D204F4F019@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv26826 Modified Files: decls.lisp input-editing-drei.lisp input-editing.lisp Log Message: Added docstrings for input-editor related stuff. --- /project/mcclim/cvsroot/mcclim/decls.lisp 2007/08/20 14:27:14 1.47 +++ /project/mcclim/cvsroot/mcclim/decls.lisp 2008/01/19 09:38:20 1.48 @@ -528,7 +528,6 @@ (defgeneric stream-input-buffer (stream)) (defgeneric (setf stream-input-buffer) (buffer stream)) -(defgeneric stream-pointer-position (stream &key pointer)) ;; (defgeneric (setf* stream-pointer-position)) (defgeneric stream-set-input-focus (stream)) (defgeneric stream-read-gesture @@ -555,28 +554,96 @@ ;;; 24.1 The Input Editor -(defgeneric input-editor-format (stream format-string &rest args)) -(defgeneric redraw-input-buffer (stream &optional start-from)) +(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)) -(defgeneric (setf stream-insertion-pointer) (pointer stream)) -(defgeneric stream-scan-pointer (stream)) -(defgeneric (setf stream-scan-pointer) (pointer stream)) -(defgeneric stream-rescanning-p (stream)) -(defgeneric reset-scan-pointer (stream &optional scan-pointer)) -(defgeneric immediate-rescan (stream)) -(defgeneric queue-rescan (stream)) -(defgeneric rescan-if-necessary (stream &optional inhibit-activation)) -(defgeneric erase-input-buffer (stream &optional start-position)) +(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)) +(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 --- /project/mcclim/cvsroot/mcclim/input-editing-drei.lisp 2008/01/16 09:03:27 1.5 +++ /project/mcclim/cvsroot/mcclim/input-editing-drei.lisp 2008/01/19 09:38:20 1.6 @@ -43,7 +43,12 @@ input-editing-stream standard-encapsulating-stream) ((scan-pointer :accessor stream-scan-pointer :initform 0) - (rescan-queued :accessor rescan-queued :initform nil))) + (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 stream-accept ((stream standard-input-editing-stream) type &rest args --- /project/mcclim/cvsroot/mcclim/input-editing.lisp 2007/08/20 14:27:14 1.56 +++ /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/01/19 09:38:20 1.57 @@ -31,10 +31,22 @@ "I true, use the Goatee editing component instead of Drei. The Goatee component is faster and more mature than Drei.") -(defvar *activation-gestures* nil) -(defvar *standard-activation-gestures* '(:newline :return)) - -(defvar *delimiter-gestures* nil) +(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.") ;;; These helper functions take the arguments of ACCEPT so that they ;;; can be used directly by ACCEPT. @@ -63,6 +75,19 @@ (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. @@ -83,6 +108,21 @@ , at 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. @@ -103,12 +143,16 @@ , at 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) @@ -119,6 +163,32 @@ &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 @@ -184,6 +254,21 @@ (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 @@ -222,6 +307,15 @@ (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)) @@ -232,9 +326,18 @@ ;;; 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)) @@ -244,20 +347,50 @@ (:report (lambda (condition stream) (format stream "Input ~S is not of required type ~S" (not-required-type-string condition) - (not-required-type-type 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)) -(defvar *help-gestures* '(:help)) -(defvar *possibilities-gestures* '(:possibilities)) +(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))) + :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. @@ -584,11 +717,34 @@ :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")) From thenriksen at common-lisp.net Sat Jan 19 10:24:19 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 19 Jan 2008 05:24:19 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Doc Message-ID: <20080119102419.1ECCA72130@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc In directory clnet:/tmp/cvs-serv3342/Doc Modified Files: drei.texi Log Message: Updated Drei documentation. --- /project/mcclim/cvsroot/mcclim/Doc/drei.texi 2008/01/13 10:33:09 1.11 +++ /project/mcclim/cvsroot/mcclim/Doc/drei.texi 2008/01/19 10:24:18 1.12 @@ -82,13 +82,27 @@ * Access Functions:: @end menu + at node Access Functions + at subsection Access Functions + +The access functions are the primary interface to Drei state, and should +be used to access the various parts. It is not recommended to save the +return value of these functions, as they are by nature ephemeral, and +may change over the course of a command. + + at include fun-drei-drei-instance.texi + at include fun-drei-current-view.texi + at include fun-esa-current-buffer.texi + at include fun-drei-point.texi + at include fun-drei-mark.texi + at include fun-drei-current-syntax.texi + @node Special Variables @subsection Special Variables -Drei uses a number of special variables to provide access to data -structures. These are described below. +Drei uses only a few special variables to provide access to data +structures. - at include var-drei-star-drei-instance-star.texi @include var-drei-kill-ring-star-kill-ring-star.texi Additionally, a number of ESA special variables are used in Drei. @@ -96,19 +110,6 @@ @include var-esa-star-minibuffer-star.texi @include var-esa-star-previous-command-star.texi - at node Access Functions - at subsection Access Functions - -The special variables essentially provide all that is needed to access -all parts of the Drei state, but for convenience, a number of utility -functions providing access to commonly used objects have been defined. - - at include fun-drei-current-view.texi - at include fun-esa-current-buffer.texi - at include fun-drei-point.texi - at include fun-drei-mark.texi - at include fun-drei-current-syntax.texi - @node External API @section External API From thenriksen at common-lisp.net Sat Jan 19 10:24:20 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 19 Jan 2008 05:24:20 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080119102420.8F27F72132@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv3342/Drei Modified Files: drei.lisp Log Message: Updated Drei documentation. --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/17 11:29:55 1.28 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/19 10:24:19 1.29 @@ -70,8 +70,8 @@ return `object'.")) (defun drei-instance (&optional (object *esa-instance*)) - "Return the currently running Drei instance. This function -calls `drei-instance-of' on its argument." + "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*)) From thenriksen at common-lisp.net Sat Jan 19 12:39:29 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 19 Jan 2008 07:39:29 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080119123929.5ADEF586D5@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv28952/Drei Modified Files: drei-redisplay.lisp packages.lisp Log Message: Added facility for highlighting strokes. Useful for debugging, as well as idle curiosity. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/17 23:11:06 1.44 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/19 12:39:28 1.45 @@ -549,20 +549,35 @@ (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) - (when (> (x2 (stroke-dimensions stroke)) - (bounding-rectangle-width pane)) - (change-space-requirements pane :width (x2 (stroke-dimensions stroke)))) - (when (> (y2 (stroke-dimensions stroke)) - (bounding-rectangle-height pane)) - (change-space-requirements pane :height (y2 (stroke-dimensions stroke)))) - (funcall (drawing-options-function (stroke-drawing-options stroke)) - pane view stroke cursor-x cursor-y #'stroke-drawing-fn t))) + (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 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 @@ -637,7 +652,7 @@ (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 (bounding-rectangle-width pane)))) + finally (maybe-clear (1+ last-clear-x) (bounding-rectangle-width pane)))) ;; 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) --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/17 11:29:55 1.42 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/19 12:39:28 1.43 @@ -276,6 +276,10 @@ #:*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 From thenriksen at common-lisp.net Sat Jan 19 20:06:01 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 19 Jan 2008 15:06:01 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/Tests Message-ID: <20080119200601.B4AEA56238@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv30054/Drei/Tests Modified Files: core-tests.lisp lisp-syntax-tests.lisp Log Message: Improved Forward Expression and fixed minor bug in Drei test suite. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/core-tests.lisp 2007/12/08 08:53:49 1.6 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/core-tests.lisp 2008/01/19 20:06:01 1.7 @@ -453,6 +453,6 @@ (backward-object mark2) (dolist (low (list 2 mark1)) (dolist (high (list (- (size (current-buffer)) 2) mark2)) - (with-narrowed-buffer (*drei-instance* low high t) + (with-narrowed-buffer ((drei-instance) low high t) (is (= (offset (point)) 2)) (is (= (offset (mark)) (- (size (current-buffer)) 2))))))))) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2008/01/13 17:10:24 1.14 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2008/01/19 20:06:01 1.15 @@ -828,7 +828,9 @@ (nil nil (5 18 2) "#+nil (list 1 2 3)") (nil nil (0 2 nil) - "#+nil (list 1 2 3)")) + "#+nil (list 1 2 3)") + (nil nil (6 7 3) + " (nil) ")) (motion-fun-one-test (list lisp-syntax) (64 4 (22 41 11) From thenriksen at common-lisp.net Sat Jan 19 20:06:02 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 19 Jan 2008 15:06:02 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080119200602.2FCC66F23F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv30054/Drei Modified Files: lisp-syntax.lisp Log Message: Improved Forward Expression and fixed minor bug in Drei test suite. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/15 15:53:53 1.68 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/19 20:06:01 1.69 @@ -2034,13 +2034,17 @@ (update-parse syntax 0 (offset mark)) (let ((potential-form (or (form-after syntax (offset mark)) (form-around syntax (offset mark))))) - (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))))))) + (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)) From thenriksen at common-lisp.net Sat Jan 19 20:35:47 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 19 Jan 2008 15:35:47 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080119203547.EDB034C007@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv2101 Modified Files: decls.lisp Log Message: Minor docstring fix. --- /project/mcclim/cvsroot/mcclim/decls.lisp 2008/01/19 09:38:20 1.48 +++ /project/mcclim/cvsroot/mcclim/decls.lisp 2008/01/19 20:35:47 1.49 @@ -643,7 +643,7 @@ (: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.")) +returns the two values `gesture' and `type'.")) ;;; 24.4 Reading and Writing of Tokens From thenriksen at common-lisp.net Sun Jan 20 19:45:24 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 20 Jan 2008 14:45:24 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080120194524.D0F5C2E1D8@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv11650/Drei Modified Files: lisp-syntax.lisp Log Message: Don't try to extract package from invalid in-package forms. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/19 20:06:01 1.69 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/20 19:45:24 1.70 @@ -1254,7 +1254,8 @@ (and (form-token-p candidate) (eq (form-to-object syntax candidate :no-error t) - 'cl:in-package))))) + 'cl:in-package) + (second-form (children x)))))) (extract (x) (let ((designator (second-form (children x)))) (form-to-object syntax designator From thenriksen at common-lisp.net Sun Jan 20 19:50:21 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 20 Jan 2008 14:50:21 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080120195021.4531232023@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv12206/Drei Modified Files: core-commands.lisp drei-redisplay.lisp packages.lisp views.lisp Log Message: Improved support for nonbuffer views, including various bugfixes here and there, used that support to revamp Climacs' typeout panes, which in turn required some ESA changes. Stability not guaranteed, please test. --- /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2008/01/17 11:29:55 1.13 +++ /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2008/01/20 19:50:20 1.14 @@ -296,7 +296,7 @@ '((:home :control))) (define-command (com-page-down :name t :command-table movement-table) () - (page-down (current-view))) + (page-down (editor-pane (drei-instance)) (current-view))) (set-key 'com-page-down 'movement-table @@ -307,7 +307,7 @@ '((:next))) (define-command (com-page-up :name t :command-table movement-table) () - (page-up (current-view))) + (page-up (editor-pane (drei-instance)) (current-view))) (set-key 'com-page-up 'movement-table --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/19 12:39:28 1.45 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/20 19:50:20 1.46 @@ -652,7 +652,7 @@ (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 (1+ last-clear-x) (bounding-rectangle-width pane)))) + finally (maybe-clear last-clear-x (bounding-rectangle-width pane)))) ;; 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) @@ -994,8 +994,9 @@ (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 (and (= new-x1 old-x1) (= new-y1 old-y2) - (= new-x2 old-x2) (= new-y2 old-y2)) + (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) @@ -1018,6 +1019,22 @@ ;;; ;;; 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." @@ -1037,14 +1054,15 @@ "Reposition the pane if point is outside the region delimited by the top/bot marks of its view. Returns true if adjustment was needed." - (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))) + (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)))) -(defun page-down (view) +(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)) @@ -1052,7 +1070,7 @@ (setf (offset (point view)) (offset top)) (invalidate-all-strokes view)))) -(defun page-up (view) +(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)) @@ -1096,11 +1114,6 @@ ;; We start all over! (display-drei-pane (pane-frame pane) pane))))))) -(defmethod handle-repaint ((pane drei-pane) region) - (declare (ignore region)) - (invalidate-all-strokes (view pane) :cleared t) - (redisplay-frame-pane (pane-frame pane) pane)) - (defmethod pane-needs-redisplay :around ((pane drei-pane)) (values (call-next-method) nil)) --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/19 12:39:28 1.43 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/20 19:50:20 1.44 @@ -216,7 +216,7 @@ ;; Views and their facilities. #:drei-view #:modified-p #:no-cursors - #:drei-buffer-view #:buffer #:top #:bot + #:drei-buffer-view #:buffer #:top #:bot #:buffer-view-p #:drei-syntax-view #:syntax #:pump-state-for-offset-with-syntax #:stroke-pump-with-syntax @@ -248,12 +248,14 @@ #:minibuffer - #:drei #:drei-pane #:drei-gadget-pane #:drei-area + #: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 --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/18 11:00:23 1.23 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/20 19:50:20 1.24 @@ -504,6 +504,14 @@ 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.")) + (defclass drei-buffer-view (drei-view) ((%buffer :accessor buffer :initform (make-instance 'drei-buffer) @@ -574,6 +582,10 @@ (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)) + (defclass drei-syntax-view (drei-buffer-view) ((%syntax :accessor syntax :documentation "An instance of the syntax class used From thenriksen at common-lisp.net Sun Jan 20 19:50:22 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 20 Jan 2008 14:50:22 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20080120195022.165A73307E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv12206/ESA Modified Files: esa.lisp packages.lisp Log Message: Improved support for nonbuffer views, including various bugfixes here and there, used that support to revamp Climacs' typeout panes, which in turn required some ESA changes. Stability not guaranteed, please test. --- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/01/14 20:50:11 1.14 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/01/20 19:50:21 1.15 @@ -1048,15 +1048,29 @@ ;;; ;;; Help -(defgeneric help-stream (frame title)) - -(defmethod help-stream (frame title) - (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)) +(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) + , at body))) (defun read-gestures-for-help (command-table) (with-input-focus (t) @@ -1389,12 +1403,12 @@ ((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 ((stream (help-stream *application-frame* (format nil "Help: Describe Bindings"))) - (command-table (find-applicable-command-table *application-frame*))) - (describe-bindings stream command-table - (if sort-by-keystrokes - #'sort-by-keystrokes - #'sort-by-name)))) + (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))) @@ -1412,12 +1426,10 @@ (let ((gesture-name (format nil "~{~A~#[~; ~; ~]~}" (mapcar #'gesture-name gestures)))) (if command - (let ((out-stream - (help-stream *application-frame* - (format nil "~10THelp: Describe Key for ~A" gesture-name)))) + (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)) + :command-table command-table + :stream out-stream)) (display-message "Unbound gesture: ~A" gesture-name)))))) (set-key 'com-describe-key @@ -1427,15 +1439,14 @@ (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*)) - (out-stream (help-stream *application-frame* - (format nil "~10THelp: Describe Command for ~A" + (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))) + :errorp nil))) + (describe-command-to-stream command + :command-table command-table + :stream out-stream)))) (set-key `(com-describe-command ,*unsupplied-argument-marker*) 'help-table @@ -1480,30 +1491,28 @@ collect (cons function keys)))) (if (null results) (display-message "No results for ~{~A~^, ~}" words) - (let ((out-stream (help-stream *application-frame* - (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))))))) + (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 --- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/01/13 22:22:06 1.12 +++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/01/20 19:50:21 1.13 @@ -82,7 +82,7 @@ #:convert-to-gesture #:gesture-name #:global-esa-table #:keyboard-macro-table #:help-table - #:help-stream + #:invoke-with-help-stream #:with-help-stream #:set-key #:find-applicable-command-table #:esa-command-parser From ahefner at common-lisp.net Mon Jan 21 01:07:49 2008 From: ahefner at common-lisp.net (ahefner) Date: Sun, 20 Jan 2008 20:07:49 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20080121010749.2D2F728143@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv21406 Modified Files: port.lisp Log Message: Patch from Nikodemus Siivola fixing warnings. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2008/01/17 07:11:15 1.132 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2008/01/21 01:07:49 1.133 @@ -111,6 +111,8 @@ :initarg :ascent :reader fontset-width))) +(defvar *fontset* nil) + (defmethod print-object ((object fontset) stream) (format stream "#" (fontset-name object))) @@ -681,6 +683,8 @@ ;; 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 @@ -688,7 +692,6 @@ request first-keycode count &allow-other-keys) (declare (ignore display request first-keycode count)) - (declare (special *clx-port*)) (let ((sheet (and window (port-lookup-sheet *clx-port* window)))) (when sheet (case event-key @@ -878,7 +881,6 @@ (declare (ignore wait-function)) (let* ((*clx-port* port) (display (clx-port-display port))) - (declare (special *clx-port*)) (unless (xlib:event-listen display) (xlib:display-finish-output (clx-port-display port))) ; temporary solution @@ -959,8 +961,6 @@ (xlib:open-font display (first fonts)) (xlib:open-font display "fixed")))) -(defvar *fontset* nil) - (defmethod text-style-mapping ((port clx-port) text-style &optional character-set) (declare (ignore character-set)) From ahefner at common-lisp.net Mon Jan 21 01:08:58 2008 From: ahefner at common-lisp.net (ahefner) Date: Sun, 20 Jan 2008 20:08:58 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20080121010858.4FFF62828F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv21511 Modified Files: font-selector.lisp Log Message: Default to the current port. --- /project/mcclim/cvsroot/mcclim/Examples/font-selector.lisp 2006/12/24 14:27:48 1.1 +++ /project/mcclim/cvsroot/mcclim/Examples/font-selector.lisp 2008/01/21 01:08:58 1.2 @@ -38,6 +38,7 @@ (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) From ahefner at common-lisp.net Mon Jan 21 01:10:08 2008 From: ahefner at common-lisp.net (ahefner) Date: Sun, 20 Jan 2008 20:10:08 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20080121011008.5FC902E1D7@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv21600 Modified Files: misc-tests.lisp Log Message: Goofy line width transformation test, functions to print tests using the Postscript backend. --- /project/mcclim/cvsroot/mcclim/Examples/misc-tests.lisp 2007/07/19 06:58:30 1.3 +++ /project/mcclim/cvsroot/mcclim/Examples/misc-tests.lisp 2008/01/21 01:10:07 1.4 @@ -70,6 +70,24 @@ (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) @@ -134,7 +152,7 @@ (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 backgroud, and should show through the empty row/column of the table." + "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) @@ -219,4 +237,25 @@ (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+)))))))) + + From ahefner at common-lisp.net Mon Jan 21 01:26:42 2008 From: ahefner at common-lisp.net (ahefner) Date: Sun, 20 Jan 2008 20:26:42 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080121012642.E1E1D830B1@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv24542 Modified Files: graphics.lisp medium.lisp recording.lisp sheets.lisp Log Message: Drawing optimizations, with a focus on eliminating clipping rectangle changes and transformation cache invalidations (the latter generally caused by the former). Shortcuts for special cases in d-g-w-o-internal, merge-text-styles, regions. Further mcclim-freetype optimization - minimize modification of picture-clip-rectangle and painting of the foreground tile (this used to happen for every single draw-text call). One or two optimizations in output record playback. The mcclim-freetype changes require a fix to CLX, available in Christophe's CLX in darcs, or from here: http://vintage-digital.com/hefner/mcclim/xrender-clip-state.diff --- /project/mcclim/cvsroot/mcclim/graphics.lisp 2008/01/09 16:57:54 1.59 +++ /project/mcclim/cvsroot/mcclim/graphics.lisp 2008/01/21 01:26:42 1.60 @@ -89,26 +89,29 @@ (changed-line-style line-style-p) (changed-text-style text-style-p)) (unwind-protect - (progn + (progn (when (eq ink old-ink) (setf ink nil)) - (if ink + (when ink (setf (medium-ink medium) ink)) - (if transformation + (when transformation (setf (medium-transformation medium) (compose-transformations old-transform transformation))) (when (and clipping-region old-clip - (region-equal clipping-region old-clip)) - (setf clipping-region nil)) - - (if clipping-region - (setf (medium-clipping-region medium) - (region-intersection (if transformation - (transform-region transformation old-clip) - old-clip) - clipping-region))) - (if (null line-style) + (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) @@ -128,7 +131,7 @@ (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))) + (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 --- /project/mcclim/cvsroot/mcclim/medium.lisp 2007/03/20 01:41:17 1.63 +++ /project/mcclim/cvsroot/mcclim/medium.lisp 2008/01/21 01:26:42 1.64 @@ -199,7 +199,8 @@ (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)) +(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 @@ -236,6 +237,10 @@ ;;; 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)) @@ -398,7 +403,7 @@ (defmethod (setf medium-clipping-region) :after (region (medium medium)) (declare (ignore region)) - (let ((sheet (medium-sheet medium))) + (let ((sheet (medium-sheet medium))) (when sheet (invalidate-cached-regions sheet)))) --- /project/mcclim/cvsroot/mcclim/recording.lisp 2007/09/07 16:49:11 1.135 +++ /project/mcclim/cvsroot/mcclim/recording.lisp 2008/01/21 01:26:42 1.136 @@ -518,6 +518,7 @@ ;; 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 @@ -1030,15 +1031,21 @@ (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 + (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) +(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 + (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) +(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)) @@ -1122,8 +1129,12 @@ (defmethod replay-output-record :around ((record gs-clip-mixin) stream &optional region x-offset y-offset) (declare (ignore region x-offset y-offset)) - (with-drawing-options (stream :clipping-region (graphics-state-clip record)) - (call-next-method))) + (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) @@ -1719,7 +1730,7 @@ (: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))))) + (incf bottom (+ point-xy (ceiling (- ascent descent) 2))))) (values left top right bottom)))) (defmethod* (setf output-record-position) :around @@ -1875,6 +1886,11 @@ ;; 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) @@ -2131,6 +2147,7 @@ line string-width &optional (start 0) end) + (when (and (stream-recording-p stream) (slot-value stream 'local-record-p)) (let* ((medium (sheet-medium stream)) @@ -2150,9 +2167,10 @@ :text-style text-style)) height ascent)))) + (when (stream-drawing-p stream) (without-local-recording stream - (call-next-method)))) + (call-next-method)))) #+nil (defmethod stream-write-char :around ((stream standard-output-recording-stream) char) --- /project/mcclim/cvsroot/mcclim/sheets.lisp 2007/03/20 01:43:55 1.54 +++ /project/mcclim/cvsroot/mcclim/sheets.lisp 2008/01/21 01:26:42 1.55 @@ -643,8 +643,8 @@ (update-mirror-geometry sheet)) (defmethod sheet-native-region ((sheet mirrored-sheet-mixin)) - (with-slots (native-region) sheet - (unless native-region + (with-slots (native-region) sheet + (unless native-region (let ((this-region (transform-region (sheet-native-transformation sheet) (sheet-region sheet))) (parent (sheet-parent sheet))) From ahefner at common-lisp.net Mon Jan 21 01:26:43 2008 From: ahefner at common-lisp.net (ahefner) Date: Sun, 20 Jan 2008 20:26:43 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20080121012643.26933830B1@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv24542/Backends/CLX Modified Files: medium.lisp Log Message: Drawing optimizations, with a focus on eliminating clipping rectangle changes and transformation cache invalidations (the latter generally caused by the former). Shortcuts for special cases in d-g-w-o-internal, merge-text-styles, regions. Further mcclim-freetype optimization - minimize modification of picture-clip-rectangle and painting of the foreground tile (this used to happen for every single draw-text call). One or two optimizations in output record playback. The mcclim-freetype changes require a fix to CLX, available in Christophe's CLX in darcs, or from here: http://vintage-digital.com/hefner/mcclim/xrender-clip-state.diff --- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2008/01/17 07:23:48 1.85 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2008/01/21 01:26:43 1.86 @@ -37,6 +37,7 @@ (defclass clx-medium (basic-medium) ((gc :initform nil) (picture :initform nil) + (clipping-region-dirty :initform t) (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.") @@ -108,7 +109,7 @@ (let ((clipping-region (medium-device-region medium)) (tmp (slot-value medium 'clipping-region-tmp)) (port (port medium))) - (cond + (cond ((region-equal clipping-region +nowhere+) (setf (xlib:gcontext-clip-mask gc) #())) ((typep clipping-region 'standard-rectangle) @@ -135,8 +136,9 @@ (defmethod (setf medium-clipping-region) :after (region (medium clx-medium)) (declare (ignore region)) - (with-slots (gc) medium - (when gc (%set-gc-clipping-region medium gc)))) + (with-slots (#|gc|# clipping-region-dirty) medium + (setf clipping-region-dirty t) + #+NIL (when gc (%set-gc-clipping-region medium gc)))) (defgeneric medium-gcontext (medium ink)) @@ -155,7 +157,7 @@ (let* ((port (port medium)) (mirror (port-lookup-mirror port (medium-sheet medium))) (line-style (medium-line-style medium))) - (with-slots (gc) medium + (with-slots (gc clipping-region-dirty) medium (unless gc (setq gc (xlib:create-gcontext :drawable mirror)) ;; this is kind of false, since the :unit should be taken @@ -175,7 +177,9 @@ (let ((fn (text-style-to-X-font port (medium-text-style medium)))) (when (typep fn 'xlib:font) (setf (xlib:gcontext-font gc) fn))) - (%set-gc-clipping-region medium gc) + (when clipping-region-dirty + (%set-gc-clipping-region medium gc) + (setf clipping-region-dirty nil)) gc))) (defmethod medium-gcontext ((medium clx-medium) (ink (eql +transparent-ink+))) @@ -620,7 +624,7 @@ (ink (medium-ink ,medium)) (gc (medium-gcontext ,medium ink))) line-style ink - (unwind-protect + (unwind-protect (unless (eql ink +transparent-ink+) (progn , at body)) #+ignore(xlib:free-gcontext gc)))))) From ahefner at common-lisp.net Mon Jan 21 01:26:43 2008 From: ahefner at common-lisp.net (ahefner) Date: Sun, 20 Jan 2008 20:26:43 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Experimental/freetype Message-ID: <20080121012643.6D3986915C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv24542/Experimental/freetype Modified Files: freetype-fonts.lisp Log Message: Drawing optimizations, with a focus on eliminating clipping rectangle changes and transformation cache invalidations (the latter generally caused by the former). Shortcuts for special cases in d-g-w-o-internal, merge-text-styles, regions. Further mcclim-freetype optimization - minimize modification of picture-clip-rectangle and painting of the foreground tile (this used to happen for every single draw-text call). One or two optimizations in output record playback. The mcclim-freetype changes require a fix to CLX, available in Christophe's CLX in darcs, or from here: http://vintage-digital.com/hefner/mcclim/xrender-clip-state.diff --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/17 09:54:21 1.20 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/21 01:26:43 1.21 @@ -117,7 +117,7 @@ (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 + (first (xlib::find-matching-picture-formats display :alpha 8 :red 0 :green 0 :blue 0))))))) (setf lookaside (cons display glyph-set)) glyph-set)))) @@ -289,54 +289,86 @@ (xlib:drawable-root drawable)))))) (defun gcontext-picture (drawable gcontext) - (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))) - (list - (xlib::render-create-picture - pixmap - :format (xlib::find-window-picture-format (xlib:drawable-root drawable)) - :repeat :on) - pixmap))))) + (flet ((update-foreground (picture) + ;; FIXME! This makes assumptions about pixel format, and breaks + ;; on 16 bpp displays. + (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)))) -(let ((buffer (make-array 1024 :element-type '(unsigned-byte 32) ; TODO: thread safety + +;;; Arbitrary restriction: No more than 65536 glyphs cached from +;;; a single font. I don't think that's unreasonable. + +(let ((buffer (make-array 1024 :element-type '(unsigned-byte 16) ; TODO: thread safety :adjustable nil :fill-pointer nil))) - (defmethod clim-clx::font-draw-glyphs ((font freetype-face) mirror gc x y string &key start end translate) - (declare (optimize (speed 3))) + (defun clim-clx::font-draw-glyphs (font #|(font freetype-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 32) + :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* ((fg (xlib:gcontext-foreground gc)) - (cache (slot-value font 'glyph-id-cache)) + (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*) - (or (gcache-get cache code) - (gcache-set cache code (font-glyph-id font char))))) + (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-fill-rectangle source-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) - (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 + x y glyph-ids :end (- end start))))))) @@ -533,15 +565,34 @@ (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 (position #\newline string :start start))) + (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 @@ -626,17 +677,18 @@ start end align-x align-y toward-x toward-y transform-glyphs) - (declare (ignore 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) + (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)) + + (unless (and (eq align-x :left) (eq align-y :baseline)) (setq x (- x (ecase align-x (:left 0) (:center (round text-width 2)) @@ -645,17 +697,18 @@ (: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) - (font-draw-glyphs - (text-style-to-X-font (port medium) (medium-text-style medium)) - mirror gc x y string - :start start :end end - :translate #'translate))))))) + (: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)) @@ -679,5 +732,9 @@ (clim:region-intersection r (clim:sheet-region s))))) (unless (eql r clim:+nowhere+) (clim:with-drawing-options (m :clipping-region r) - (clim:draw-design m r :ink clim:+background-ink+) - (call-next-method s r))))) + ; This causes the logic cube to flicker. Is it critical? + ;(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)))))) + From ahefner at common-lisp.net Mon Jan 21 01:34:14 2008 From: ahefner at common-lisp.net (ahefner) Date: Sun, 20 Jan 2008 20:34:14 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080121013414.6325D232BC@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv25741 Modified Files: regions.lisp Log Message: Missed one. --- /project/mcclim/cvsroot/mcclim/regions.lisp 2008/01/15 15:45:17 1.36 +++ /project/mcclim/cvsroot/mcclim/regions.lisp 2008/01/21 01:34:13 1.37 @@ -4,7 +4,7 @@ ;;; Created: 1998-12-02 19:26 ;;; Author: Gilbert Baumann ;;; License: LGPL (See file COPYING for details). -;;; $Id: regions.lisp,v 1.36 2008/01/15 15:45:17 crhodes Exp $ +;;; $Id: regions.lisp,v 1.37 2008/01/21 01:34:13 ahefner Exp $ ;;; -------------------------------------------------------------------------------------- ;;; (c) copyright 1998,1999,2001 by Gilbert Baumann ;;; (c) copyright 2001 by Arnaud Rouanet (rouanet at emi.u-bordeaux.fr) @@ -2213,7 +2213,8 @@ (not (region-equal +nowhere+ (region-intersection a b)))) (defmethod region-contains-region-p ((a region) (b region)) - (region-equal +nowhere+ (region-difference b a))) + (or (eq a b) + (region-equal +nowhere+ (region-difference b a)))) ;;;; ==================================================================================================== From thenriksen at common-lisp.net Mon Jan 21 17:08:28 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 21 Jan 2008 12:08:28 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080121170828.D980674016@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv18432/Drei Modified Files: core-commands.lisp drei.lisp packages.lisp views.lisp Log Message: Added new command table, `view-table', that contains generic commands used for all views. Currently this is limited to page-up/page-down commands, and it's not likely it will ever get anything but very high-level movement/scrolling commands (I want to add generic end-of-view/beginning-of-view commands too), because we can make so few assumptions about views. --- /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2008/01/20 19:50:20 1.14 +++ /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2008/01/21 17:08:28 1.15 @@ -295,26 +295,26 @@ 'movement-table '((:home :control))) -(define-command (com-page-down :name t :command-table movement-table) () +(define-command (com-page-down :name t :command-table view-table) () (page-down (editor-pane (drei-instance)) (current-view))) (set-key 'com-page-down - 'movement-table + 'view-table '((#\v :control))) (set-key 'com-page-down - 'movement-table + 'view-table '((:next))) -(define-command (com-page-up :name t :command-table movement-table) () +(define-command (com-page-up :name t :command-table view-table) () (page-up (editor-pane (drei-instance)) (current-view))) (set-key 'com-page-up - 'movement-table + 'view-table '((#\v :meta))) (set-key 'com-page-up - 'movement-table + 'view-table '((:prior))) (define-command (com-end-of-buffer :name t :command-table movement-table) () --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/19 10:24:19 1.29 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/21 17:08:28 1.30 @@ -162,6 +162,8 @@ (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 --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/20 19:50:20 1.44 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/21 17:08:28 1.45 @@ -244,6 +244,7 @@ #: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 --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/20 19:50:20 1.24 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/21 17:08:28 1.25 @@ -472,7 +472,7 @@ 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 From thenriksen at common-lisp.net Mon Jan 21 20:23:40 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 21 Jan 2008 15:23:40 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080121202340.2C7962E208@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv14980/Drei Modified Files: drei-redisplay.lisp Log Message: Be careful to draw only inside the strokes when highlighting them. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/20 19:50:20 1.46 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/21 20:23:40 1.47 @@ -576,7 +576,7 @@ (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 x2 (1- y2) :filled nil :ink *stroke-boundary-ink*) + (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) From thenriksen at common-lisp.net Mon Jan 21 20:54:48 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 21 Jan 2008 15:54:48 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080121205448.994A75535A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv23985 Modified Files: X11-colors.lisp design.lisp Log Message: Moved the +black+ and +white+ colour definitions to design.lisp. The rationale that these are hardly X11-specific, and they're needed before colors.lisp is loaded anyway. --- /project/mcclim/cvsroot/mcclim/X11-colors.lisp 2003/03/21 21:36:58 1.2 +++ /project/mcclim/cvsroot/mcclim/X11-colors.lisp 2008/01/21 20:54:48 1.3 @@ -59,8 +59,6 @@ (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 +white+ (make-named-color "white" 1.0000 1.0000 1.0000)) -(defconstant +black+ (make-named-color "black" 0.0000 0.0000 0.0000)) (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)) --- /project/mcclim/cvsroot/mcclim/design.lisp 2008/01/14 07:03:15 1.27 +++ /project/mcclim/cvsroot/mcclim/design.lisp 2008/01/21 20:54:48 1.28 @@ -917,6 +917,11 @@ (= 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) From ahefner at common-lisp.net Mon Jan 21 22:24:33 2008 From: ahefner at common-lisp.net (ahefner) Date: Mon, 21 Jan 2008 17:24:33 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080121222433.17B155F06E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv28208 Modified Files: recording.lisp Log Message: Patch from Nikodemus Siivola --- /project/mcclim/cvsroot/mcclim/recording.lisp 2008/01/21 01:26:42 1.136 +++ /project/mcclim/cvsroot/mcclim/recording.lisp 2008/01/21 22:24:32 1.137 @@ -1730,7 +1730,7 @@ (:bottom (incf top (- point-y descent)) (incf bottom (- point-y descent))) (:center (incf top (+ point-y (ceiling (- ascent descent) 2))) - (incf bottom (+ point-xy (ceiling (- ascent descent) 2))))) + (incf bottom (+ point-y (ceiling (- ascent descent) 2))))) (values left top right bottom)))) (defmethod* (setf output-record-position) :around From thenriksen at common-lisp.net Tue Jan 22 08:51:03 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 22 Jan 2008 03:51:03 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080122085103.14069232E4@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv19045 Modified Files: commands.lisp frames.lisp Log Message: Committed patch from Nikodemus Siivola fixing undefined variables. --- /project/mcclim/cvsroot/mcclim/commands.lisp 2007/12/10 19:33:18 1.72 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2008/01/22 08:51:02 1.73 @@ -332,7 +332,7 @@ (command-name-from-symbol command-name)) (errorp (error 'command-not-accessible :command-table-name - (command-table-designator-as-name table))) + (command-table-designator-as-name command-table))) (t nil))) (defun find-menu-item (menu-name command-table &key (errorp t)) @@ -436,7 +436,7 @@ (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 table))) + (command-table-designator-as-name command-table))) (if in-table (setf (nth in-table keystroke-items) item) (progn @@ -474,7 +474,7 @@ (setf (cdr items-tail) (cddr items-tail)))) (when errorp (error 'command-not-present :command-table-name - (command-table-designator-as-name table))))))) + (command-table-designator-as-name command-table))))))) nil) (defun map-over-command-table-keystrokes (function command-table) @@ -499,7 +499,7 @@ do (return-from find-keystroke-item (values item command-table))) (if errorp (error 'command-not-present :command-table-name - (command-table-designator-as-name table)) + (command-table-designator-as-name command-table)) nil))) (defun lookup-keystroke-item (gesture command-table @@ -522,11 +522,11 @@ (values sub-item sub-command-table)))))) command-table)))) -(defun partial-command-from-name (command-name) +(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 table)) + (command-table-designator-as-name command-table)) (cons command-name (mapcar #'(lambda (foo) (declare (ignore foo)) @@ -549,7 +549,7 @@ (if item (let* ((value (command-menu-item-value item)) (command (case (command-menu-item-type item) - (:command + (:command value) (:function (funcall value gesture numeric-arg)) @@ -558,7 +558,7 @@ (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) + (partial-command-from-name command command-table) command) numeric-arg) gesture)) --- /project/mcclim/cvsroot/mcclim/frames.lisp 2008/01/01 00:27:34 1.128 +++ /project/mcclim/cvsroot/mcclim/frames.lisp 2008/01/22 08:51:02 1.129 @@ -521,13 +521,14 @@ (object) (call-next-method) (menu-item - (let ((command (command-menu-item-value object))) + (let ((command (command-menu-item-value object)) + (table (frame-command-table frame))) (unless (listp command) - (setq command (partial-command-from-name command))) + (setq command (partial-command-from-name command table))) (if (and (typep stream 'interactor-pane) (partial-command-p command)) (command-line-read-remaining-arguments-for-partial-command - (frame-command-table frame) stream command 0) + table stream command 0) command))))) (defmethod read-frame-command ((frame application-frame) From thenriksen at common-lisp.net Tue Jan 22 15:21:07 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 22 Jan 2008 10:21:07 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080122152107.DCA2316061@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv16834/Drei Modified Files: drei-redisplay.lisp views.lisp Log Message: Fixed redisplay issue where changes to the contents of strokes were sometimes not picked up correctly. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/21 20:23:40 1.47 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/22 15:21:07 1.48 @@ -330,6 +330,31 @@ (end-offset (stroke-end-offset stroke)))) (return stroke)))))) +(defun find-index-of-line-containing-offset (view offset) + "Return the index of the line 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)) + ((mark> offset line-start) + (setf low-index (1+ middle))) + ((mark< 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." @@ -379,14 +404,24 @@ (let* ((stroke (line-stroke-information line (line-stroke-count line))) (old-start-offset (stroke-start-offset stroke)) (old-end-offset (stroke-end-offset stroke)) - (old-drawing-options (stroke-drawing-options stroke))) + (old-drawing-options (stroke-drawing-options stroke)) + (changed-region (first (changed-regions view)))) (prog1 (stroke-pump view stroke pump-state) (unless (and old-start-offset (= (+ old-start-offset line-change) (stroke-start-offset stroke)) (= (+ old-end-offset line-change) (stroke-end-offset stroke)) (drawing-options-equal old-drawing-options - (stroke-drawing-options stroke))) + (stroke-drawing-options stroke)) + (or (null changed-region) + (not (overlaps (stroke-start-offset stroke) (stroke-end-offset stroke) + (car changed-region) (cdr changed-region))))) (invalidate-stroke stroke :modified t)) + ;; Move to the next changed region, if it is not possible for + ;; more stroks to overlap with the current one. + (when (and changed-region + (>= (stroke-end-offset stroke) + (cdr changed-region))) + (pop (changed-regions view))) (incf (line-stroke-count line)) (setf (line-end-offset line) (stroke-end-offset stroke))))) --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/21 17:08:28 1.25 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/22 15:21:07 1.26 @@ -552,7 +552,13 @@ :initform 0 :type number :documentation "The width of the longest -displayed line in device units.")) +displayed line in device units.") + (%changed-regions :accessor changed-regions + :initform nil + :documentation "A list of (start . end) conses +of buffer offsets, delimiting the regions of the buffer that have +changed since the last redisplay. The regions are not +overlapping, and are sorted in ascending order.")) (:metaclass modual-class) (:documentation "A view that contains a `drei-buffer' object. The buffer is displayed on a simple line-by-line basis, @@ -586,6 +592,47 @@ "Return true if `view' is a `drei-buffer-view'." (typep view 'drei-buffer-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))) + +(defun remember-changed-region (view start end) + "Note that the buffer region delimited by the offset `start' +and `end' has been modified." + (labels ((worker (list) + ;; Return a new changed-regions list. Try to extend old + ;; regions instead of adding new ones. + (cond ((null list) + (list (cons start end))) + ;; If start/end overlaps with (first list), extend + ;; (first list) + ((overlaps start end (car (first list)) (cdr (first list))) + (setf (car (first list)) (min start (car (first list))) + (cdr (first list)) (max end (cdr (first list)))) + list) + ;; If start/end is wholly before (first list), push + ;; on a new region. + ((< start (car (first list))) + (setf (first list) + (cons (cons start end) (first list))) + list) + ;; If start/end is wholly before (first list), go + ;; further down list. If at end of list, add new + ;; element. + ((< (cdr (first list)) end) + (setf (rest list) (worker (rest list))) + list)))) + (setf (changed-regions view) (worker (changed-regions view))))) + +(defmethod observer-notified ((view drei-buffer-view) (buffer drei-buffer) + changed-region) + ;; If something has been redisplayed, and there have been changes to + ;; some of those lines, mark them as dirty. + (remember-changed-region view (car changed-region) (cdr changed-region))) + (defclass drei-syntax-view (drei-buffer-view) ((%syntax :accessor syntax :documentation "An instance of the syntax class used @@ -675,48 +722,49 @@ (modified-p view) t)) (call-next-method)) -(defmethod synchronize-view :around ((view drei-syntax-view) &key - force-p (begin 0) (end (size (buffer view)))) - (assert (>= end begin)) - ;; If nothing changed, then don't call the other methods. - (when (or (not (= (prefix-size view) (suffix-size view) - (buffer-size view) (size (buffer view)))) - force-p) - (call-next-method))) +(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)))) + &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." - (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) + (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 (>= parsed-end (- (size (buffer view)) suffix-size)) - (- (size (buffer view)) parsed-start) + (suffix-size view) (max (if (>= end (- (size (buffer view)) suffix-size)) + (max (- (size (buffer view)) begin) suffix-size) suffix-size) - suffix-size))) - (call-next-method))) + 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 From thenriksen at common-lisp.net Tue Jan 22 20:14:43 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 22 Jan 2008 15:14:43 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080122201443.DA055232F6@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv11831/Drei Modified Files: views.lisp Log Message: Fixed small bug in `remember-changed-region'. --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/22 15:21:07 1.26 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/22 20:14:43 1.27 @@ -616,9 +616,7 @@ ;; If start/end is wholly before (first list), push ;; on a new region. ((< start (car (first list))) - (setf (first list) - (cons (cons start end) (first list))) - list) + (cons (cons start end) (first list))) ;; If start/end is wholly before (first list), go ;; further down list. If at end of list, add new ;; element. From thenriksen at common-lisp.net Tue Jan 22 22:35:38 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 22 Jan 2008 17:35:38 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080122223538.2A0995F081@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv3056/Drei Modified Files: drei-redisplay.lisp Log Message: Fixed width calculation of Drei views. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/22 15:21:07 1.48 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/22 22:35:38 1.49 @@ -960,7 +960,7 @@ (last-line (last-displayed-line view))) (values (x1 (line-dimensions first-line)) (y1 (line-dimensions first-line)) - (max-line-width view) + (+ (x1 (line-dimensions first-line)) (max-line-width view)) (y2 (line-dimensions last-line)))))) (defmethod bounding-rectangle-width ((view drei-buffer-view)) From thenriksen at common-lisp.net Tue Jan 22 23:00:09 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 22 Jan 2008 18:00:09 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080122230009.76D17830D8@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv7026/Drei Modified Files: lisp-syntax.lisp Log Message: Only highlight parentheses when the view is active. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/20 19:45:24 1.70 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/22 23:00:04 1.71 @@ -1832,6 +1832,17 @@ (progn (cache-symbol-info syntax symbol-form) (global-boundp symbol-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+)) + (define-syntax-highlighting-rules emacs-style-highlighting (error-lexeme (*error-drawing-options*)) (string-form (*string-drawing-options*)) @@ -1845,13 +1856,7 @@ ((symbol-form-is-boundp (syntax view) form) *special-variable-drawing-options*) (t +default-drawing-options+))))) - (parenthesis-lexeme (:function #'(lambda (view form) - (if (and (typep view 'point-mark-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+))))) + (parenthesis-lexeme (:function #'parenthesis-highlighter))) (define-syntax-highlighting-rules retro-highlighting (error-symbol (*error-drawing-options*)) @@ -1863,13 +1868,7 @@ +bold-face-drawing-options+) (t +default-drawing-options+))))) ;; XXX: Ugh, copied from above. - (parenthesis-lexeme (:function #'(lambda (view form) - (if (and (typep view 'point-mark-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+))))) + (parenthesis-lexeme (:function #'parenthesis-highlighter))) (defparameter *syntax-highlighting-rules* 'emacs-style-highlighting "The syntax highlighting rules used for highlighting Lisp From thenriksen at common-lisp.net Wed Jan 23 10:16:26 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 23 Jan 2008 05:16:26 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080123101626.6C16717099@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv6127/Drei Modified Files: input-editor.lisp Log Message: I decided that input-editing was too simple, so I added some more incomprehensible complexity. This should ensure commercial CLIM never copies code from us. Incidentally, also fixes prompting semantics, probably broke something else though. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/01/19 09:38:20 1.23 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/01/23 10:16:25 1.24 @@ -155,8 +155,7 @@ ;; 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 (or (stream-rescanning-p stream) - (= (stream-scan-pointer stream) (input-position stream))) + (unless (stream-rescanning-p stream) (call-next-method) ;; We skip ahead of any noise strings to put us past the ;; prompt. This is safe, because the noise strings are to be @@ -478,7 +477,8 @@ (with-accessors ((insertion-pointer stream-insertion-pointer) (scan-pointer stream-scan-pointer) (activation-gesture activation-gesture)) stream - (let ((buffer (buffer (view (drei-instance 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) @@ -486,7 +486,8 @@ do (let ((gesture (buffer-object buffer scan-pointer))) ;; Skip noise strings. (cond ((typep gesture 'noise-string) - (incf scan-pointer)) + (incf scan-pointer) + (setf last-was-noisy t)) ((and (not peek-p) (typep gesture 'accept-result)) (incf scan-pointer) @@ -512,8 +513,10 @@ (unless peek-p (incf scan-pointer)) (return-from stream-read-gesture gesture)) - (t (incf scan-pointer))))) - (setf (stream-rescanning stream) nil) + (t (incf scan-pointer) + (setf last-was-noisy nil))))) + (unless last-was-noisy ; This prevents double-prompting. + (setf (stream-rescanning stream) nil)) (when activation-gesture (return-from stream-read-gesture (prog1 activation-gesture From thenriksen at common-lisp.net Wed Jan 23 10:23:50 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 23 Jan 2008 05:23:50 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080123102350.A184A1603E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv8629 Modified Files: NEWS Log Message: Added some more things to NEWS. --- /project/mcclim/cvsroot/mcclim/NEWS 2008/01/15 23:17:50 1.30 +++ /project/mcclim/cvsroot/mcclim/NEWS 2008/01/23 10:23:50 1.31 @@ -10,6 +10,10 @@ *** 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. * Changes in mcclim-0.9.5 relative to 0.9.4: From thenriksen at common-lisp.net Wed Jan 23 19:01:41 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 23 Jan 2008 14:01:41 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080123190141.36B6714172@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv13721/Drei Modified Files: packages.lisp views.lisp Log Message: Add `syntax-view-p' and `mark-view-p'. --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/21 17:08:28 1.45 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/23 19:01:40 1.46 @@ -217,10 +217,10 @@ ;; Views and their facilities. #:drei-view #:modified-p #:no-cursors #:drei-buffer-view #:buffer #:top #:bot #:buffer-view-p - #:drei-syntax-view #:syntax + #:drei-syntax-view #:syntax #:syntax-view-p #:pump-state-for-offset-with-syntax #:stroke-pump-with-syntax - #:point-mark-view + #: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 --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/22 20:14:43 1.27 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/23 19:01:40 1.28 @@ -616,7 +616,7 @@ ;; If start/end is wholly before (first list), push ;; on a new region. ((< start (car (first list))) - (cons (cons start end) (first list))) + (cons (cons start end) list)) ;; If start/end is wholly before (first list), go ;; further down list. If at end of list, add new ;; element. @@ -697,6 +697,10 @@ (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)) @@ -819,6 +823,10 @@ (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) From thenriksen at common-lisp.net Wed Jan 23 22:18:03 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 23 Jan 2008 17:18:03 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20080123221803.61E7056224@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv27270/Examples Modified Files: clim-fig.lisp Log Message: Try to make CLIM-FIG not draw null beziers. --- /project/mcclim/cvsroot/mcclim/Examples/clim-fig.lisp 2007/03/20 01:46:14 1.32 +++ /project/mcclim/cvsroot/mcclim/Examples/clim-fig.lisp 2008/01/23 22:18:03 1.33 @@ -84,9 +84,11 @@ (design (climi::make-bezier-thing* 'climi::bezier-area (list x y cp-x1 cp-y1 cp-x2 cp-y2 x1 y1)))) - (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+))))))) + (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) From thenriksen at common-lisp.net Wed Jan 23 22:37:09 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 23 Jan 2008 17:37:09 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080123223709.511B456222@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv31102 Modified Files: regions.lisp Log Message: Added support for zero-radius ellipses. I hope I didn't break anything... --- /project/mcclim/cvsroot/mcclim/regions.lisp 2008/01/21 01:34:13 1.37 +++ /project/mcclim/cvsroot/mcclim/regions.lisp 2008/01/23 22:37:08 1.38 @@ -4,7 +4,7 @@ ;;; Created: 1998-12-02 19:26 ;;; Author: Gilbert Baumann ;;; License: LGPL (See file COPYING for details). -;;; $Id: regions.lisp,v 1.37 2008/01/21 01:34:13 ahefner Exp $ +;;; $Id: regions.lisp,v 1.38 2008/01/23 22:37:08 thenriksen Exp $ ;;; -------------------------------------------------------------------------------------- ;;; (c) copyright 1998,1999,2001 by Gilbert Baumann ;;; (c) copyright 2001 by Arnaud Rouanet (rouanet at emi.u-bordeaux.fr) @@ -633,15 +633,17 @@ (xn (- (/ yc d))) (yn (/ xc d))) (transform-distance tr xn yn))))) - (multiple-value-bind (vdx vdy) (contact-radius* 1 0) - (declare (ignore vdx)) - (multiple-value-bind (hdx hdy) (contact-radius* 0 1) - (declare (ignore hdy)) - (multiple-value-bind (cx cy) (ellipse-center-point* region) - (let ((rx (abs hdx)) - (ry (abs vdy))) - (values (- cx rx) (- cy ry) - (+ cx rx) (+ cy ry))))))))) + (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. From thenriksen at common-lisp.net Wed Jan 23 23:07:55 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 23 Jan 2008 18:07:55 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20080123230755.A945D1F00D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv6723/Examples Modified Files: clim-fig.lisp Log Message: Fixed undo in CLIM-FIG. Remaining bugs (such as the semirandom undo order) is probably not the fault of CLIM-FIG. --- /project/mcclim/cvsroot/mcclim/Examples/clim-fig.lisp 2008/01/23 22:18:03 1.33 +++ /project/mcclim/cvsroot/mcclim/Examples/clim-fig.lisp 2008/01/23 23:07:55 1.34 @@ -320,6 +320,9 @@ 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 @@ -338,7 +341,8 @@ (defmethod generate-panes :after (frame-manager (frame clim-fig)) (declare (ignore frame-manager)) (setf (clim-fig-output-record frame) - (stream-current-output-record (frame-standard-input 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))) From thenriksen at common-lisp.net Thu Jan 24 09:25:18 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 24 Jan 2008 04:25:18 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080124092518.626867A064@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv18349/Drei Modified Files: views.lisp Log Message: When clearing the undo history, also clear the undo accumulator. --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/23 19:01:40 1.28 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/24 09:25:17 1.29 @@ -259,7 +259,8 @@ (defmethod clear-undo-history ((undo-maintainer undo-mixin)) (setf (slot-value undo-maintainer 'tree) - (make-instance 'standard-undo-tree))) + (make-instance 'standard-undo-tree) + (undo-accumulate undo-maintainer) '())) ;;; undo-mixin delegation (here because of the package) From thenriksen at common-lisp.net Thu Jan 24 15:45:35 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 24 Jan 2008 10:45:35 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080124154535.DE78064117@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv8875/Drei Modified Files: packages.lisp Log Message: Export drei:clear-undo-history. --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/23 19:01:40 1.46 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/24 15:45:33 1.47 @@ -205,7 +205,7 @@ #:insert-record #:delete-record #:compound-record - #:with-undo + #:with-undo #:clear-undo-history #:drei-buffer From ahefner at common-lisp.net Fri Jan 25 07:36:39 2008 From: ahefner at common-lisp.net (ahefner) Date: Fri, 25 Jan 2008 02:36:39 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20080125073639.E4294A186@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv25703 Modified Files: medium.lisp Log Message: Fix clipping bug. The device region is the final determiner of our clipping rectangle. This is computed from both the medium clipping region and the sheet (native) region. When the device region changes, update the clipping region the next time we sync the gcontext, so that it does not continue to clip to the size of the old window. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2008/01/21 01:26:43 1.86 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2008/01/25 07:36:39 1.87 @@ -37,7 +37,7 @@ (defclass clx-medium (basic-medium) ((gc :initform nil) (picture :initform nil) - (clipping-region-dirty :initform t) + (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.") @@ -134,12 +134,6 @@ ;; to clx :] we stick with :unsorted until that can be sorted out (setf (xlib:gcontext-clip-mask gc :unsorted) rect-seq))))))) -(defmethod (setf medium-clipping-region) :after (region (medium clx-medium)) - (declare (ignore region)) - (with-slots (#|gc|# clipping-region-dirty) medium - (setf clipping-region-dirty t) - #+NIL (when gc (%set-gc-clipping-region medium gc)))) - (defgeneric medium-gcontext (medium ink)) @@ -157,7 +151,7 @@ (let* ((port (port medium)) (mirror (port-lookup-mirror port (medium-sheet medium))) (line-style (medium-line-style medium))) - (with-slots (gc clipping-region-dirty) 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 @@ -177,9 +171,9 @@ (let ((fn (text-style-to-X-font port (medium-text-style medium)))) (when (typep fn 'xlib:font) (setf (xlib:gcontext-font gc) fn))) - (when clipping-region-dirty - (%set-gc-clipping-region medium gc) - (setf clipping-region-dirty nil)) + (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+))) From thenriksen at common-lisp.net Sat Jan 26 00:23:40 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 25 Jan 2008 19:23:40 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/Tests Message-ID: <20080126002340.2253F76369@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv16402/Drei/Tests Modified Files: buffer-tests.lisp Log Message: Changed DELETE-BUFFER-REGION to use DELETE-ELEMENTS*. Requires Flexichain 1.3 (currently, this means CVS). Increases region-killing performance by more than a hundredfold for most cases. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/buffer-tests.lisp 2007/12/08 08:53:49 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/buffer-tests.lisp 2008/01/26 00:23:37 1.4 @@ -231,40 +231,40 @@ (let ((m (make-buffer-mark buffer 3 :left)) (m2 (make-buffer-mark buffer 5 :left))) (delete-region m m2) - (is (= (size buffer) 5)) + (is (= 5 (size buffer))) (is (eq (buffer m) (buffer m2))) - (is (= (offset m) 3)) - (is (= (offset m2) 3)) + (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 (= (size buffer) 5)) + (is (= 5 (size buffer))) (is (eq (buffer m) (buffer m2))) - (is (= (offset m) 3)) - (is (= (offset m2) 3)) + (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 (= (size buffer) 5)) + (is (= 5 (size buffer))) (is (eq (buffer m) (buffer m2))) - (is (= (offset m) 3)) - (is (= (offset m2) 3)) + (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 (= (size buffer) 5)) + (is (= 5 (size buffer))) (is (eq (buffer m) (buffer m2))) - (is (= (offset m) 3)) - (is (= (offset m2) 3)) + (is (= 3 (offset m))) + (is (= 3 (offset m2))) (is (string= (buffer-substring buffer 0 5) "clics")))) (signals error (let ((buffer (make-instance %%buffer)) @@ -280,11 +280,11 @@ (m2 (make-buffer-mark buffer 5 :left))) (delete-region m 5) (delete-region 1 m2) - (is (= (size buffer) 3)) + (is (= 3 (size buffer))) (is (eq (buffer m) (buffer m2))) - (is (= (offset m) 1)) - (is (= (offset m2) 1)) - (is (string= (buffer-substring buffer 0 3) "ccs"))))) + (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))) From thenriksen at common-lisp.net Sat Jan 26 00:23:40 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 25 Jan 2008 19:23:40 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080126002340.81FAB7A01C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv16402/Drei Modified Files: buffer.lisp Log Message: Changed DELETE-BUFFER-REGION to use DELETE-ELEMENTS*. Requires Flexichain 1.3 (currently, this means CVS). Increases region-killing performance by more than a hundredfold for most cases. --- /project/mcclim/cvsroot/mcclim/Drei/buffer.lisp 2008/01/03 16:19:42 1.7 +++ /project/mcclim/cvsroot/mcclim/Drei/buffer.lisp 2008/01/26 00:23:40 1.8 @@ -516,8 +516,7 @@ (make-condition 'offset-after-end :offset offset)) (assert (<= (+ offset n) (size buffer)) () (make-condition 'offset-after-end :offset (+ offset n))) - (loop repeat n - do (delete* (contents buffer) offset))) + (delete-elements* (contents buffer) offset n)) (defgeneric delete-range (mark &optional n) (:documentation "Delete `n' objects after `(if n > 0)' or From rschlatte at common-lisp.net Sat Jan 26 05:09:40 2008 From: rschlatte at common-lisp.net (rschlatte) Date: Sat, 26 Jan 2008 00:09:40 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20080126050940.4C1616D070@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv30427/Apps/Listener Modified Files: dev-commands.lisp Log Message: Multiple context-menu commands for text files: Edit, Show Also, activate code for showing file in a separate window --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/01/18 06:54:50 1.46 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/01/26 05:09:39 1.47 @@ -1285,11 +1285,7 @@ (mv-or (when mime-type (mime-type-to-command mime-type pathname)) (when command - (values command doc pointer-doc)) - (when (and mime-type (subtypep mime-type 'text)) - (values `(com-edit-file ,pathname) - "Edit File" - (format nil "Edit ~A" pathname))) )))))) + (values command doc pointer-doc)))))))) (define-presentation-translator automagic-pathname-translator (clim:pathname clim:command filesystem-commands @@ -1399,9 +1395,6 @@ ((pathname 'pathname :prompt "pathname")) (clim-sys:make-process (lambda () (ed pathname)))) -;; Leave this translator disabled for now, the automagic translator will now produce -;; com-edit-file where there is not a more specific handler for a text mime type. -#+IGNORE (define-presentation-to-command-translator edit-file (clim:pathname com-edit-file filesystem-commands :gesture :select :pointer-documentation ((object stream) @@ -1410,7 +1403,9 @@ :tester ((object) (and (not (wild-pathname-p object)) (probe-file object) - (pathname-name object)))) + (pathname-name object) + (let ((mime-type (pathname-mime-type object))) + (and mime-type (subtypep mime-type 'text)))))) (object) (list object)) @@ -1420,6 +1415,20 @@ ((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 @@ -1448,10 +1457,8 @@ (list object)) -;; CLIM:OPEN-WINDOW-STREAM seems to be broken. -;; Less broken since I hacked on it, but still bad.. (defun show-file (pathname) - (let ( #+ignore(*standard-output* (open-window-stream :scroll-bars :both)) ) + (let ((*standard-output* (open-window-stream :scroll-bars :both)) ) (with-open-file (in pathname) (loop for line = (read-line in nil) while line From thenriksen at common-lisp.net Sat Jan 26 11:33:03 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 26 Jan 2008 06:33:03 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080126113303.0FFE862133@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv10853 Modified Files: NEWS Log Message: Added mentions of some more bug fixes to NEWS. --- /project/mcclim/cvsroot/mcclim/NEWS 2008/01/23 10:23:50 1.31 +++ /project/mcclim/cvsroot/mcclim/NEWS 2008/01/26 11:33:02 1.32 @@ -15,6 +15,9 @@ *** 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. * Changes in mcclim-0.9.5 relative to 0.9.4: ** Installation: the systems clim-listener, clim-examples, From thenriksen at common-lisp.net Sat Jan 26 12:37:25 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 26 Jan 2008 07:37:25 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080126123725.B44D75F072@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv24230/Drei Modified Files: search-commands.lisp Log Message: Fixed some trivial bugs in search/replace. --- /project/mcclim/cvsroot/mcclim/Drei/search-commands.lisp 2008/01/17 11:29:55 1.6 +++ /project/mcclim/cvsroot/mcclim/Drei/search-commands.lisp 2008/01/26 12:37:25 1.7 @@ -332,7 +332,7 @@ (defun query-replace-find-next-match (state) (with-accessors ((string string1) (targets targets)) state - (let* ((mark (point (drei-instance (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) @@ -400,7 +400,7 @@ (occurrences occurrences) (targets targets)) state (let ((string1-length (length string1)) - (mark (point (drei-instance targets)))) + (mark (point (view (drei-instance targets))))) (backward-object mark string1-length) (replace-one-string mark string1-length From afuchs at common-lisp.net Sat Jan 26 17:28:10 2008 From: afuchs at common-lisp.net (afuchs) Date: Sat, 26 Jan 2008 12:28:10 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim-website Message-ID: <20080126172810.749B532049@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim-website In directory clnet:/tmp/cvs-serv30884 Log Message: I dedicate this module to the mcclim web presence Status: Vendor Tag: WEB Release Tags: initial N mcclim-website/License N mcclim-website/McCLIM-3.png N mcclim-website/clim-paper.pdf N mcclim-website/index.html N mcclim-website/mcclim.css N mcclim-website/downloads/index.html N mcclim-website/images/addressbook-small.jpg N mcclim-website/images/addressbook.jpg N mcclim-website/images/bach262-small.jpg N mcclim-website/images/bach262.jpg N mcclim-website/images/calc.jpg N mcclim-website/images/colorslider-small.jpg N mcclim-website/images/colorslider.jpg N mcclim-website/images/index.html N mcclim-website/images/listener1-small.jpg N mcclim-website/images/listener1.jpg No conflicts created by this import From afuchs at common-lisp.net Sat Jan 26 17:32:21 2008 From: afuchs at common-lisp.net (afuchs) Date: Sat, 26 Jan 2008 12:32:21 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Webpage Message-ID: <20080126173221.ADD3256220@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Webpage In directory clnet:/tmp/cvs-serv31616 Removed Files: License McCLIM-3.png clim-paper.pdf index.html mcclim.css Log Message: Move the mcclim web presence to module "mcclim-website". From afuchs at common-lisp.net Sat Jan 26 17:32:22 2008 From: afuchs at common-lisp.net (afuchs) Date: Sat, 26 Jan 2008 12:32:22 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Webpage/downloads Message-ID: <20080126173222.11EB17A00B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Webpage/downloads In directory clnet:/tmp/cvs-serv31616/downloads Removed Files: index.html Log Message: Move the mcclim web presence to module "mcclim-website". From afuchs at common-lisp.net Sat Jan 26 17:32:22 2008 From: afuchs at common-lisp.net (afuchs) Date: Sat, 26 Jan 2008 12:32:22 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Webpage/images Message-ID: <20080126173222.CED3414161@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Webpage/images In directory clnet:/tmp/cvs-serv31616/images Removed Files: addressbook-small.jpg addressbook.jpg bach262-small.jpg bach262.jpg calc.jpg colorslider-small.jpg colorslider.jpg index.html listener1-small.jpg listener1.jpg Log Message: Move the mcclim web presence to module "mcclim-website". From thenriksen at common-lisp.net Sat Jan 26 23:59:00 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 26 Jan 2008 18:59:00 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim-website Message-ID: <20080126235900.937DF4C006@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim-website In directory clnet:/tmp/cvs-serv30340 Added Files: mcclim.cliki.png Log Message: Added logo for the McCLIM wiki. --- /project/mcclim/cvsroot/mcclim-website/mcclim.cliki.png 2008/01/26 23:59:00 NONE +++ /project/mcclim/cvsroot/mcclim-website/mcclim.cliki.png 2008/01/26 23:59:00 1.1 ?PNG  IHDR?2^D? UIDATx???kPW?O?Kf`x??????4?P???ZEKa?R?P(R???l?U+?l( E?aQ???n\V??X??a??PP???????m?? S??????=?t?????=????/[? lX ?? ??c????26??M+C?%;?Htr:?BA???????/Z???,???B?ddd?2???Mq??@?ih?S??%{5MDD???? ??=z???????? ??????p?T*???{d?X?????????d??????????OLL??<???y??7hUXX8{?I???1s???:?E???&f +=9????????gc??}}}eeed????P(??????P(T*?J?"?,_????????jwww?O????s???IOOg?X?`Ax<^ii)?a???????lQQQ???V???G??h?????/fee???P?G?H??Z#W6???~??u???U3_?2T????Y???????L&??;v????S(????????#NNNLd??? N????_y??????`??-[? ??????????'N?~#0y????'=?6????|?R?N???????{Uy????w?F%?????(?J?u???3g??Y???f???????.\?x?b??? {??!n:?x?@`?w???????YR?D"?????+{'c??9}NN??>S???~G?N???C?ZLt?[??? Xn?1????sssq???<**j?0?@????|????N????????????kjj?.]jvG? p?v?A?d?Go????????W???O4?_??gG?UaNS???????????v?????Y????M*?$INN?m?N???=c?H$?r?[?n5?#???X??&?|66H?y?F???-M??~??E?`?*???T*??.??|???TUU????vLL 2?heee???&o*qqq????s???? ??????*?Phooov/&??????~??h??-??Hg?@&??|t???E??GY?`???N????{???)????????o!!!f??bggw??A?FQ???S"?????????^L@??k?Xo?????tw)??a??? ?x?#" r??????n%???dQ?y?85??????????0? ?????D??:?OBB1]???uu{???p??r????V?Z??O?z>???????]J s???{????l?}????xY???v?Zhh(????y??UE?????!!a???F???j0?k4/N?M2?L??+ ?s??Mt:7???*???-?h?T?l??????*??2??????Cw??%J???HII!????OKKkll4r9??/blG???`W?I3|_d2)?b_???`0222???w???;w?455=y????yhh???c??????~tt41(766?JeOOn??;???%???\???{g?Z?V3???$|EQ??????n? ????r?..???? Update of /project/mcclim/cvsroot/mcclim/Apps/Debugger In directory clnet:/tmp/cvs-serv32572 Modified Files: clim-debugger.lisp Log Message: Patch from Cyrus Harmon: "The following patch fixes the mcclim debugger to work with swank. The condition-references slot is now gone, although there is some remnant of this in the 'compiler-condition and in the condition-extras. I think the right thing to do is to remove the slot from 'debugger-info, BICBW." --- /project/mcclim/cvsroot/mcclim/Apps/Debugger/clim-debugger.lisp 2005/04/26 03:19:34 1.1 +++ /project/mcclim/cvsroot/mcclim/Apps/Debugger/clim-debugger.lisp 2008/01/27 04:52:11 1.2 @@ -106,8 +106,6 @@ :initarg :type-of-condition) (condition-extra :accessor condition-extra :initarg :condition-extra) - (condition-references :accessor condition-references - :initarg :condition-references) (restarts :accessor restarts :initarg :restarts) (backtrace :accessor backtrace @@ -273,10 +271,6 @@ pane))) (when (condition-extra (condition-info pane)) (std-form pane "Extra:" (condition-extra (condition-info pane)) - :family :fix)) - (when (condition-references (condition-info pane)) - (std-form pane "References:" (condition-references (condition-info - pane)) :family :fix))) (fresh-line) @@ -389,7 +383,6 @@ :type-of-condition (type-of condition) :condition-message (swank::safe-condition-message condition) :condition-extra (swank::condition-extras condition) - :condition-references (swank::condition-references condition) :restarts (compute-restarts) :backtrace (compute-backtrace 0 20))) (run-debugger-frame)) From thenriksen at common-lisp.net Sun Jan 27 09:36:07 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 27 Jan 2008 04:36:07 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080127093607.7D8E956232@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv29065/Drei Modified Files: drei-clim.lisp drei-redisplay.lisp drei.lisp input-editor.lisp Log Message: Changed a bit in how cursors work, they are now always part of the output history, and aren't arbitrarily added and removed as their state changes. Also restores the blue inactive-cursors in Climacs. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/17 23:11:06 1.32 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/27 09:36:07 1.33 @@ -55,6 +55,12 @@ ;;; 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. When a cursor is created, it adds +;;; itself to its 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 @@ -90,6 +96,10 @@ Drei buffer. The most important role for instances of subclasses of this class is to visually represent the position of point.")) +(defmethod initialize-instance :after ((object drei-cursor) &rest initargs) + (declare (ignore initargs)) + (stream-add-output-record (output-stream object) object)) + (defmethod active ((cursor drei-cursor)) "Whether the cursor is active or not. An active cursor is drawn using the active ink, and an @@ -106,9 +116,6 @@ (active-ink cursor) (inactive-ink cursor))) -(defmethod (setf enabled) ((new-value null) (cursor drei-cursor)) - (erase-output-record cursor (output-stream cursor) nil)) - (defclass point-cursor (drei-cursor) () (:default-initargs @@ -136,7 +143,7 @@ (defmethod enabled ((cursor mark-cursor)) *show-mark*) -(defgeneric visible (cursor view) +(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 @@ -146,6 +153,12 @@ (: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) @@ -174,7 +187,7 @@ ;; display surface. drei) -(defmethod visible and (cursor (view drei-view)) +(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. (<= (offset (top view)) --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/22 22:35:38 1.49 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/27 09:36:07 1.50 @@ -83,7 +83,7 @@ is *guaranteed* to not return NIL or T.") (:method :around ((stream extended-output-stream) (view drei-view) (cursor drei-cursor)) - (when (visible cursor view) + (when (visible-p cursor) (letf (((stream-default-view stream) view)) (call-next-method))))) @@ -1003,7 +1003,7 @@ (dolist (cursor (cursors drei)) (apply #'erase-output-record cursor stream (when errorp-supplied - errorp)))) + (list errorp))))) ;; XXX: Full redraw for every replay, should probably use the `region' ;; parameter to only invalidate some strokes. @@ -1021,7 +1021,7 @@ (declare (ignore x-offset y-offset region)) (clear-output-record cursor) (with-output-recording-options (stream :record t :draw t) - (when (active cursor) + (when (visible-p cursor) (display-drei-view-cursor stream (view cursor) cursor)))) (defun display-drei-area (drei) --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/21 17:08:28 1.30 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/27 09:36:07 1.31 @@ -281,6 +281,11 @@ 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) @@ -301,6 +306,10 @@ (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))) @@ -325,7 +334,7 @@ the Drei instance." (setf (cursors drei) (nreverse (create-view-cursors (editor-pane drei) (view drei)))) (dolist (cursor (cursors drei)) - (stream-add-output-record (editor-pane drei) cursor)) + (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) @@ -346,7 +355,10 @@ (add-view-cursors drei))) (defmethod (setf view) :after (new-val (drei drei)) - ;; We have some new cursors. + ;; Delete the old cursors, then add the new ones, provided the + ;; setting of the view is successful. + (dolist (cursor (cursors drei)) + (delete-output-record cursor (output-record-parent cursor) nil)) (add-view-cursors drei)) (defmethod esa-current-buffer ((drei drei)) --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/01/23 10:16:25 1.24 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/01/27 09:36:07 1.25 @@ -97,7 +97,8 @@ (defmethod (setf cursor-visibility) (visibility (stream drei-input-editing-mixin)) - (setf (active (drei-instance stream)) visibility)) + (setf (active (drei-instance stream)) visibility + (cursors-visible (drei-instance stream)) visibility)) (defclass drei-unselectable-presentation (presentation) () From thenriksen at common-lisp.net Sun Jan 27 10:23:07 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 27 Jan 2008 05:23:07 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080127102307.DDFB217244@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv6197/Drei Modified Files: drei.lisp Log Message: Only delete cursor output records if they have a parent. --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/27 09:36:07 1.31 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/27 10:23:05 1.32 @@ -358,7 +358,8 @@ ;; Delete the old cursors, then add the new ones, provided the ;; setting of the view is successful. (dolist (cursor (cursors drei)) - (delete-output-record cursor (output-record-parent cursor) nil)) + (when (output-record-parent cursor) + (delete-output-record cursor (output-record-parent cursor) nil))) (add-view-cursors drei)) (defmethod esa-current-buffer ((drei drei)) From thenriksen at common-lisp.net Sun Jan 27 10:46:54 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 27 Jan 2008 05:46:54 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080127104654.373BB1605A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv15585/Drei Modified Files: drei-clim.lisp drei-redisplay.lisp Log Message: Don't redisplay cursor if the associated view has not been displayed yet. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/27 09:36:07 1.33 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/27 10:46:53 1.34 @@ -189,10 +189,12 @@ (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. - (<= (offset (top view)) - (offset (mark cursor)) - (offset (bot view)))) + ;; `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)) --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/27 09:36:07 1.50 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/27 10:46:53 1.51 @@ -920,7 +920,7 @@ (defmethod display-drei-view-cursor :around ((stream extended-output-stream) (view drei-buffer-view) (cursor drei-cursor)) - (when (<= (offset (top view)) (offset (mark cursor)) (offset (bot view))) + (when (visible-p cursor) (clear-output-record cursor) (prog1 (call-next-method) (with-bounding-rectangle* (x1 y1 x2 y2) cursor @@ -1021,8 +1021,7 @@ (declare (ignore x-offset y-offset region)) (clear-output-record cursor) (with-output-recording-options (stream :record t :draw t) - (when (visible-p cursor) - (display-drei-view-cursor stream (view cursor) cursor)))) + (display-drei-view-cursor stream (view cursor) cursor))) (defun display-drei-area (drei) (with-accessors ((stream editor-pane) (view view)) drei From thenriksen at common-lisp.net Sun Jan 27 22:24:07 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 27 Jan 2008 17:24:07 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20080127222407.540A85D23E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv28193/ESA Modified Files: esa.lisp Log Message: Added some amazing hacks to pointer-documentation-panes for the notion of a "background message". This is the beginning of extending pointer-documentation-panes into more generally useful minibuffer-like panes. For now, this just means that the Listener shows arglists and other things for Drei commands. It's still a little flickery, though. --- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/01/20 19:50:21 1.15 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/01/27 22:24:07 1.16 @@ -308,7 +308,8 @@ (funcall continuation minibuffer)))) (defmethod invoke-with-minibuffer-stream ((minibuffer pointer-documentation-pane) continuation) - (funcall continuation minibuffer)) + (clim-extensions:with-output-to-pointer-documentation (stream (pane-frame minibuffer)) + (funcall continuation stream))) (defmethod invoke-with-minibuffer-stream ((minibuffer null) continuation) nil) From thenriksen at common-lisp.net Sun Jan 27 22:24:07 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 27 Jan 2008 17:24:07 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Experimental Message-ID: <20080127222407.BEE745D23E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental In directory clnet:/tmp/cvs-serv28193/Experimental Modified Files: pointer-doc-hack.lisp Log Message: Added some amazing hacks to pointer-documentation-panes for the notion of a "background message". This is the beginning of extending pointer-documentation-panes into more generally useful minibuffer-like panes. For now, this just means that the Listener shows arglists and other things for Drei commands. It's still a little flickery, though. --- /project/mcclim/cvsroot/mcclim/Experimental/pointer-doc-hack.lisp 2006/03/29 10:43:44 1.2 +++ /project/mcclim/cvsroot/mcclim/Experimental/pointer-doc-hack.lisp 2008/01/27 22:24:07 1.3 @@ -218,41 +218,52 @@ (let ((x (device-event-x event)) (y (device-event-y event)) (pstream *pointer-documentation-output*)) - (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)) + (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))) + ;; 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. From thenriksen at common-lisp.net Sun Jan 27 22:24:08 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 27 Jan 2008 17:24:08 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080127222408.E5BDB6211E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv28193 Modified Files: frames.lisp package.lisp panes.lisp Log Message: Added some amazing hacks to pointer-documentation-panes for the notion of a "background message". This is the beginning of extending pointer-documentation-panes into more generally useful minibuffer-like panes. For now, this just means that the Listener shows arglists and other things for Drei commands. It's still a little flickery, though. --- /project/mcclim/cvsroot/mcclim/frames.lisp 2008/01/22 08:51:02 1.129 +++ /project/mcclim/cvsroot/mcclim/frames.lisp 2008/01/27 22:24:07 1.130 @@ -1115,6 +1115,15 @@ (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)) @@ -1127,71 +1136,82 @@ (let ((x (device-event-x event)) (y (device-event-y event)) (pstream *pointer-documentation-output*)) - (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))) + (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)))))) + (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 + frame (setf frame-documentation-state (frame-compute-pointer-documentation-state frame input-context @@ -1206,63 +1226,55 @@ (%event% event)) (declare (special %input-context% %stream% %doc-state% %event&)) (if (and documentation-record - (output-record-parent documentation-record)) + (output-record-parent documentation-record)) (redisplay documentation-record *pointer-documentation-output*) (progn - (window-clear *pointer-documentation-output*) + (window-clear *pointer-documentation-output*) (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%)))))))))) - -#-(and) -(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)) - frame - (let ((new-state (frame-compute-pointer-documentation-state frame - input-context - stream - event))) - (unless (frame-compare-pointer-documentation-state - frame - input-context - stream - frame-documentation-state - new-state) - (window-clear *pointer-documentation-output*) - (frame-print-pointer-documentation frame - input-context - stream - new-state - event) - (setq frame-documentation-state new-state)))))) + (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) + , at body))) ;;; A hook for applications to draw random strings in the ;;; *pointer-documentation-output* without screwing up the real pointer ;;; documentation too badly. -(defgeneric frame-display-pointer-documentation-string - (frame documentation-stream string)) - -(defmethod frame-display-pointer-documentation-string - ((frame standard-application-frame) documentation-stream string) - (when *pointer-documentation-output* - (with-accessors ((frame-documentation-state frame-documentation-state)) - frame - (unless (frame-compare-pointer-documentation-state - frame nil documentation-stream frame-documentation-state string) - (window-clear documentation-stream) - (write-string string documentation-stream) - (setq frame-documentation-state string))))) +(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) --- /project/mcclim/cvsroot/mcclim/package.lisp 2008/01/12 11:04:05 1.64 +++ /project/mcclim/cvsroot/mcclim/package.lisp 2008/01/27 22:24:07 1.65 @@ -1935,6 +1935,8 @@ #: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 --- /project/mcclim/cvsroot/mcclim/panes.lisp 2008/01/01 23:23:07 1.186 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2008/01/27 22:24:07 1.187 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.186 2008/01/01 23:23:07 thenriksen Exp $ +;;; $Id: panes.lisp,v 1.187 2008/01/27 22:24:07 thenriksen Exp $ (in-package :clim-internals) @@ -2732,9 +2732,19 @@ (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 @@ -2748,6 +2758,12 @@ :end-of-line-action :allow :end-of-page-action :allow)) +(defmethod stream-accept :before ((stream pointer-documentation-pane) type + &rest args) + (declare (ignore args)) + (setf (background-message stream) nil) + (redisplay-frame-pane (pane-frame stream) stream :force-p t)) + ;;; CONSTRUCTORS (defun make-clim-stream-pane (&rest options From thenriksen at common-lisp.net Mon Jan 28 08:25:39 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 28 Jan 2008 03:25:39 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080128082539.8777C16169@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv536/Drei Modified Files: drei-redisplay.lisp Log Message: Fixed redisplay bug where added lines might not be marked as dirty. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/27 10:46:53 1.51 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/28 08:25:34 1.52 @@ -700,10 +700,21 @@ (return (values pump-state line-height)))))))) (defun clear-stale-lines (pane view) - "Clear from the last displayed line to the end of `pane'." + "Clear from the last displayed line to the end of `pane' and +mark undisplayed line objects as dirty." (let ((line-dimensions (line-dimensions (last-displayed-line view)))) (clear-rectangle* pane (x1 line-dimensions) (y2 line-dimensions) - (bounding-rectangle-width pane) (bounding-rectangle-height pane)))) + (bounding-rectangle-width pane) (bounding-rectangle-height pane))) + ;; 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) + (setf (stroke-start-offset stroke) nil))))) (defvar *maximum-chunk-size* 100 "The maximum amount of objects put into a stroke by a From thenriksen at common-lisp.net Mon Jan 28 16:53:21 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 28 Jan 2008 11:53:21 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080128165321.9BC3C5E145@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv20878/Drei Modified Files: drei-clim.lisp drei.lisp Log Message: Added :redisplay-minibuffer initarg to Drei instances. This enables programs like Climacs to prevent Drei from blasting the minibuffer. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/27 10:46:53 1.34 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/28 16:53:21 1.35 @@ -226,7 +226,9 @@ :documentation "The pane that previously had keyboard focus")) (:metaclass modual-class) - (:default-initargs :command-executor 'execute-drei-command) + (:default-initargs + :command-executor 'execute-drei-command + :redisplay-minibuffer t) (:documentation "An actual, instantiable Drei gadget with event-based command processing.")) @@ -359,7 +361,9 @@ :documentation "The parent output record of the Drei area instance.")) (:metaclass modual-class) - (:default-initargs :command-executor 'execute-drei-command) + (:default-initargs + :command-executor 'execute-drei-command + :redisplay-minibuffer t) (:documentation "A Drei editable area implemented as an output record.")) @@ -500,7 +504,8 @@ a minibuffer.")) (defmethod display-drei :after ((drei drei)) - (when (and *minibuffer* (not (eq *minibuffer* (editor-pane drei)))) + (when (and *minibuffer* (not (eq *minibuffer* (editor-pane drei))) + (redisplay-minibuffer drei)) ;; 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))) --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/27 10:23:05 1.32 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/28 16:53:21 1.33 @@ -179,7 +179,8 @@ search-table info-table self-insert-table - keyboard-macro-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 @@ -286,6 +287,14 @@ :initarg :cursors-visible :documentation "If true, the cursors of this Drei instance will be visible. If false, they will not.") + (%redisplay-minibuffer :accessor redisplay-minibuffer + :initform nil + :initarg :redisplay-minibuffer + :documentation "If true, the minibuffer +associated with this Drei instance will be redisplayed as the +last part of the Drei redisplay process. If false, it is the task +of the Drei-using application to make sure the minibuffer is +redisplayed as appropriate.") (%isearch-mode :initform nil :accessor isearch-mode) (%isearch-states :initform '() :accessor isearch-states) (%isearch-previous-string :initform nil :accessor isearch-previous-string) From thenriksen at common-lisp.net Mon Jan 28 17:03:31 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 28 Jan 2008 12:03:31 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20080128170331.D9FA071138@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv23946/ESA Modified Files: esa.lisp packages.lisp Log Message: Export some ESA commands. --- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/01/27 22:24:07 1.16 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/01/28 17:03:28 1.17 @@ -733,11 +733,10 @@ (setq command (list command))) (when (member *unsupplied-argument-marker* command :test #'eq) (setq command - (funcall + (funcall *partial-command-parser* - (frame-command-table command-processor) - (frame-standard-input command-processor) - command 0))) + (command-table command-processor) + *standard-input* command 0))) (funcall (command-executor command-processor) command-processor command))))) --- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/01/20 19:50:21 1.13 +++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/01/28 17:03:29 1.14 @@ -80,8 +80,6 @@ #:*extended-command-prompt* #:define-esa-top-level #:esa-top-level #:simple-command-loop #:convert-to-gesture #:gesture-name - #:global-esa-table #:keyboard-macro-table - #:help-table #:invoke-with-help-stream #:with-help-stream #:set-key #:find-applicable-command-table @@ -90,7 +88,23 @@ #:gesture-matches-gesture-name-p #:meta-digit #:proper-gesture-p - #:universal-argument #:meta-minus)) + #:universal-argument #:meta-minus + + ;; General commands + #:global-esa-table + #:com-quit #:com-extended-command + + ;; Help commands + #:help-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 + #:com-start-macro #:com-end-macro + #:com-call-last-macro)) (defpackage :esa-buffer (:use :clim-lisp :clim :esa :esa-utils) @@ -111,7 +125,10 @@ #:frame-write-buffer #:write-buffer #:buffer-writing-error #:buffer #:filepath #:filepath-is-directory - #:esa-io-table)) + #:esa-io-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 From thenriksen at common-lisp.net Tue Jan 29 11:18:37 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 29 Jan 2008 06:18:37 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/Tests Message-ID: <20080129111837.41F1F5004D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv3427/Drei/Tests Modified Files: lisp-syntax-tests.lisp Log Message: Removed unnecessary nconc method combination. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2008/01/19 20:06:01 1.15 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2008/01/29 11:18:37 1.16 @@ -1861,13 +1861,12 @@ (defgeneric find-pathnames (module) (:documentation "Get a list of the pathnames of the files -making up an ASDF module/system/component.") - (:method-combination nconc)) +making up an ASDF module/system/component.")) -(defmethod find-pathnames nconc ((module asdf:module)) +(defmethod find-pathnames ((module asdf:module)) (mapcan #'find-pathnames (asdf:module-components module))) -(defmethod find-pathnames nconc ((module asdf:source-file)) +(defmethod find-pathnames ((module asdf:source-file)) (list (asdf:component-pathname module))) ;; Thank you Mr. Insane 3000! From thenriksen at common-lisp.net Tue Jan 29 11:49:54 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 29 Jan 2008 06:49:54 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim-website Message-ID: <20080129114954.1FF4568283@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim-website In directory clnet:/project/mcclim/public_html Modified Files: index.html Log Message: Added mention of McCLIM manual. The manual PDF is not stored in CVS and must be kept up-to-date manually. --- /project/mcclim/cvsroot/mcclim-website/index.html 2008/01/26 17:27:48 1.1.1.1 +++ /project/mcclim/cvsroot/mcclim-website/index.html 2008/01/29 11:49:53 1.2 @@ -35,6 +35,10 @@ contains quite a bit of information about McCLIM, including a list of applications using it, and many screenshots of these.

+

+ You can access the McCLIM manual + PDF if you want, but it's still a work in progress. +

CVS

Read only access to the CVS tree is available in the @@ -132,7 +136,7 @@

-$Date: 2008/01/26 17:27:48 $ +$Date: 2008/01/29 11:49:53 $ From thenriksen at common-lisp.net Tue Jan 29 14:36:00 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 29 Jan 2008 09:36:00 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080129143600.BEB425535B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv18213/Drei Modified Files: modes.lisp Log Message: Changed the way the list of active modes are stored. Requires recompilation of all modes definitions. --- /project/mcclim/cvsroot/mcclim/Drei/modes.lisp 2008/01/17 11:29:55 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/modes.lisp 2008/01/29 14:36:00 1.3 @@ -70,8 +70,6 @@ (defclass ,name (, at superclasses mode) (, at slot-specs) , at actual-options) - (defmethod enabled-modes append ((modual ,name)) - '(,name)) ,(when global `(push ',name *global-modes*))))) (defmacro define-view-mode (name (&rest superclasses) From thenriksen at common-lisp.net Tue Jan 29 14:36:00 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 29 Jan 2008 09:36:00 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20080129143600.0423A5C182@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv18213/ESA Modified Files: utils.lisp Log Message: Changed the way the list of active modes are stored. Requires recompilation of all modes definitions. --- /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2008/01/11 02:44:14 1.9 +++ /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2008/01/29 14:36:00 1.10 @@ -446,9 +446,8 @@ (defgeneric enabled-modes (modual) (:documentation "Return a list of the names of the modes directly enabled for `modual'.") - (:method-combination append) - (:method append ((modual t)) - '())) + (:method ((modual t)) + '())) (defgeneric mode-enabled-p (modual mode-name) (:documentation "Return true if `mode-name' is enabled for @@ -516,7 +515,11 @@ ;; Avert thine eyes, thy of gentle spirit. (if (null modes) (find-class modual) - (eval `(defclass ,(gensym) (,modual , at modes) () + ;; We're kind and put the active modes into the class name. + (eval `(defclass ,(gensym (format nil "~A~{-~A~}" (string modual) modes)) + (,modual , at modes) + ((%enabled-modes :reader enabled-modes + :initform ',modes)) (:metaclass modual-class))))) (defun find-class-implementing-modes (modual modes) From thenriksen at common-lisp.net Tue Jan 29 19:13:07 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 29 Jan 2008 14:13:07 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080129191307.9A0471603D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv14257/Drei Modified Files: syntax.lisp Log Message: Implemented :inherit-menu keyword argument for MAKE-COMMAND-TABLE and DEFINE-COMMAND-TABLE. --- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/01/15 07:27:14 1.15 +++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/01/29 19:13:06 1.16 @@ -134,7 +134,8 @@ "Fetch extra command tables to inherit from (using `additional-command-tables') as well as the command tables `table' actually directly inherits from." - (append (additional-command-tables *application-frame* table) + (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) @@ -152,7 +153,7 @@ `(progn (make-command-table ',name , at args) (defclass ,name (syntax-command-table) ()) - (defmethod command-table-inherit-from :around ((table ,name)) + (defmethod command-table-inherit-from ((table ,name)) (append (call-next-method) '(,name) (command-table-inherit-from (find-command-table ',name)))))) From thenriksen at common-lisp.net Tue Jan 29 19:13:08 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 29 Jan 2008 14:13:08 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080129191308.2EAD628188@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv14257 Modified Files: NEWS commands.lisp menu.lisp Log Message: Implemented :inherit-menu keyword argument for MAKE-COMMAND-TABLE and DEFINE-COMMAND-TABLE. --- /project/mcclim/cvsroot/mcclim/NEWS 2008/01/26 11:33:02 1.32 +++ /project/mcclim/cvsroot/mcclim/NEWS 2008/01/29 19:13:07 1.33 @@ -18,6 +18,9 @@ ** 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. * Changes in mcclim-0.9.5 relative to 0.9.4: ** Installation: the systems clim-listener, clim-examples, --- /project/mcclim/cvsroot/mcclim/commands.lisp 2008/01/22 08:51:02 1.73 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2008/01/29 19:13:07 1.74 @@ -77,6 +77,13 @@ :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))) @@ -85,6 +92,12 @@ (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)) @@ -93,6 +106,20 @@ (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) @@ -174,13 +201,14 @@ :menu nil)) ; adjusted to allow anonymous command-tables for menu-bars -(defun make-command-table (name &key inherit-from menu (errorp t)) +(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)) @@ -188,7 +216,7 @@ (make-command-table 'user-command-table) -(defmacro define-command-table (name &key inherit-from menu) +(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 @@ -198,6 +226,7 @@ old-table) (make-command-table ',name :inherit-from inherit-from-arg + :inherit-menu ,inherit-menu :menu ',menu :errorp nil)))) @@ -338,11 +367,15 @@ (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))) - (cond (mem (values (car mem) command-table)) - (errorp (error 'command-not-accessible :command-table-name - (command-table-designator-as-name table))) - (t nil)))) + :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)) @@ -415,14 +448,34 @@ after))) (defun map-over-command-table-menu-items (function command-table) - (mapc #'(lambda (item) - (with-slots (menu-name keystroke) item - (funcall function - menu-name - (and (slot-boundp item 'keystroke) keystroke) - item))) - (slot-value (find-command-table command-table) 'menu)) - (values)) + "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))) ;; At this point we should still see the gesture name as supplied by the ;; programmer in 'gesture' --- /project/mcclim/cvsroot/mcclim/menu.lisp 2006/12/23 11:52:27 1.38 +++ /project/mcclim/cvsroot/mcclim/menu.lisp 2008/01/29 19:13:07 1.39 @@ -125,15 +125,25 @@ () (: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 (mapcar #'(lambda (item) - (make-menu-button-from-menu-item - item client :command-table command-table-name :vertical t)) - (slot-value (find-command-table command-table-name) - 'menu))) + (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)))) From thenriksen at common-lisp.net Tue Jan 29 22:27:12 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 29 Jan 2008 17:27:12 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080129222712.32A246911A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv26022 Modified Files: commands.lisp Log Message: Added type specification to inherit-from slot of command tables. It's very easy to accidentally provide a non-list for the inherit-from argument, but it's not correct, and will fail later on. --- /project/mcclim/cvsroot/mcclim/commands.lisp 2008/01/29 19:13:07 1.74 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2008/01/29 22:27:11 1.75 @@ -70,7 +70,8 @@ ((name :initarg :name :reader command-table-name) (inherit-from :initarg :inherit-from :initform '() - :reader command-table-inherit-from) + :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 From thenriksen at common-lisp.net Tue Jan 29 22:59:30 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 29 Jan 2008 17:59:30 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20080129225930.E8EA8A15F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv30581/ESA Modified Files: esa-io.lisp esa.lisp packages.lisp utils.lisp Log Message: Added build-menu function and define-menu-table macro to ESA. Used these to define menu tables. ESA's multigesture-keystroke mechanism clobbers the normal command tables menu, so we can't use that. Also, I think explicitly specifying the contents, order and structure of a menu is a good idea. --- /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2008/01/15 16:24:23 1.8 +++ /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2008/01/29 22:59:30 1.9 @@ -313,3 +313,11 @@ (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) --- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/01/28 17:03:28 1.17 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/01/29 22:59:30 1.18 @@ -1518,6 +1518,14 @@ '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 @@ -1561,6 +1569,11 @@ (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 --- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/01/28 17:03:29 1.14 +++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/01/29 22:59:30 1.15 @@ -23,7 +23,7 @@ ;;; Package definitions for ESA. (defpackage :esa-utils - (:use :clim-lisp :clim-mop) + (:use :clim-lisp :clim-mop :clim) (:export #:with-gensyms #:once-only #:unlisted @@ -45,6 +45,7 @@ #:capitalize #:ensure-array-size #:values-max-min + #:build-menu #:define-menu-table #:observable-mixin #:add-observer #:remove-observer #:observer-notified #:notify-observers @@ -95,14 +96,14 @@ #:com-quit #:com-extended-command ;; Help commands - #:help-table + #: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-table #:keyboard-macro-menu-table #:com-start-macro #:com-end-macro #:com-call-last-macro)) @@ -125,7 +126,7 @@ #:frame-write-buffer #:write-buffer #:buffer-writing-error #:buffer #:filepath #:filepath-is-directory - #:esa-io-table + #: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)) --- /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2008/01/29 14:36:00 1.10 +++ /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2008/01/29 22:59:30 1.11 @@ -261,6 +261,68 @@ `(call-method ,(first around) (,@(rest around) (make-method ,form))) form)))) +(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 + , at commands)) + :inherit-menu t + :errorp nil)) + (defclass observable-mixin () ((%observers :accessor observers :initform '())) From thenriksen at common-lisp.net Tue Jan 29 23:34:36 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 29 Jan 2008 18:34:36 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080129233436.2DC966D072@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv7525/Drei Modified Files: views.lisp Log Message: When a buffer-view is set as the view of a Drei instance, invalidate all redisplay information. This fixes a bug in Climacs where old and erroneous redisplay information could be kept when a view was hidden, and then brought back. --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/24 09:25:17 1.29 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/29 23:34:36 1.30 @@ -584,6 +584,9 @@ (defmethod (setf syntax) :after (new-value (view drei-buffer-view)) (invalidate-all-strokes view :modified t)) +(defmethod (setf view) :after ((view drei-buffer-view) (object drei)) + (invalidate-all-strokes view)) + (defmethod cache-string :around ((view drei-buffer-view)) (let ((string (call-next-method))) (setf (fill-pointer string) 0) From thenriksen at common-lisp.net Wed Jan 30 07:31:36 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 30 Jan 2008 02:31:36 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080130073136.C356512072@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv2479/Drei Modified Files: drei.lisp packages.lisp views.lisp Log Message: Added generic function clear-redisplay-information. --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/28 16:53:21 1.33 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/30 07:31:33 1.34 @@ -369,7 +369,10 @@ (dolist (cursor (cursors drei)) (when (output-record-parent cursor) (delete-output-record cursor (output-record-parent cursor) nil))) - (add-view-cursors drei)) + (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))) --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/24 15:45:33 1.47 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/30 07:31:33 1.48 @@ -237,6 +237,7 @@ #:use-editor-commands-p #:synchronize-view #:create-view-cursors + #:clear-redisplay-information #:clone-view #:make-syntax-for-view --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/29 23:34:36 1.30 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/30 07:31:34 1.31 @@ -485,6 +485,11 @@ (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 @@ -584,9 +589,6 @@ (defmethod (setf syntax) :after (new-value (view drei-buffer-view)) (invalidate-all-strokes view :modified t)) -(defmethod (setf view) :after ((view drei-buffer-view) (object drei)) - (invalidate-all-strokes view)) - (defmethod cache-string :around ((view drei-buffer-view)) (let ((string (call-next-method))) (setf (fill-pointer string) 0) @@ -596,6 +598,9 @@ "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) From thenriksen at common-lisp.net Wed Jan 30 11:48:40 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 30 Jan 2008 06:48:40 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080130114840.813201203D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv27756/Drei Modified Files: core-commands.lisp drei-clim.lisp drei.lisp input-editor.lisp packages.lisp search-commands.lisp syntax.lisp Log Message: Go some way towards fixing the minibuffer debacle. Drei will no longer attempt to create a minibuffer on its own pane. Commands that need the minibuffer, when none is available, will fail somewhat gracefully. Pointer documentation isn't broken yet, even with all the pointer-documentation-pane abuse I'm doing. I'll have to work on that. --- /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2008/01/21 17:08:28 1.15 +++ /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2008/01/30 11:48:40 1.16 @@ -67,6 +67,7 @@ (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") @@ -81,6 +82,7 @@ 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. ") --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/28 16:53:21 1.35 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/30 11:48:40 1.36 @@ -179,7 +179,8 @@ (defmethod stream-default-view ((stream drei-pane)) (view stream)) -(defmethod display-drei ((drei drei-pane)) +(defmethod display-drei ((drei drei-pane) &rest args) + (declare (ignore args)) (redisplay-frame-pane (pane-frame drei) drei)) (defmethod editor-pane ((drei drei-pane)) @@ -227,8 +228,7 @@ keyboard focus")) (:metaclass modual-class) (:default-initargs - :command-executor 'execute-drei-command - :redisplay-minibuffer t) + :command-executor 'execute-drei-command) (:documentation "An actual, instantiable Drei gadget with event-based command processing.")) @@ -285,26 +285,20 @@ (defmethod handle-gesture ((drei drei-gadget-pane) gesture) (let ((*command-processor* drei) (*abort-gestures* *esa-abort-gestures*)) - ;; It is important that the minibuffer of the Drei object is - ;; actually the minibuffer that will be used for output, or it - ;; will not be properly redisplayed by `display-drei'. (accepting-from-user (drei) - (letf (((minibuffer drei) (or (minibuffer drei) *minibuffer* - (unless (eq drei *standard-input*) - *standard-input*)))) - (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) - (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)))))) + (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) + (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))))) ;;; This is the method that functions as the entry point for all Drei ;;; gadget logic. @@ -314,8 +308,7 @@ (let ((gesture (convert-to-gesture event))) (when (proper-gesture-p gesture) (with-bound-drei-special-variables (gadget :prompt (format nil "~A " (gesture-name gesture))) - (let ((*standard-input* (or *minibuffer* *standard-input*))) - (handle-gesture gadget gesture)))))))) + (handle-gesture gadget gesture))))))) (defmethod handle-event :before ((gadget drei-gadget-pane) (event pointer-button-press-event)) @@ -362,8 +355,7 @@ record of the Drei area instance.")) (:metaclass modual-class) (:default-initargs - :command-executor 'execute-drei-command - :redisplay-minibuffer t) + :command-executor 'execute-drei-command) (:documentation "A Drei editable area implemented as an output record.")) @@ -380,7 +372,8 @@ (defmethod esa-current-window ((drei drei-area)) (editor-pane drei)) -(defmethod display-drei ((drei drei-area)) +(defmethod display-drei ((drei drei-area) &rest args) + (declare (ignore args)) (display-drei-area drei)) ;;; Implementation of the displayed-output-record and region protocol @@ -503,9 +496,8 @@ (:documentation "A constellation of a Drei gadget instance and a minibuffer.")) -(defmethod display-drei :after ((drei drei)) - (when (and *minibuffer* (not (eq *minibuffer* (editor-pane drei))) - (redisplay-minibuffer drei)) +(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))) --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/30 07:31:33 1.34 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/30 11:48:40 1.35 @@ -194,6 +194,7 @@ (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))) @@ -287,14 +288,6 @@ :initarg :cursors-visible :documentation "If true, the cursors of this Drei instance will be visible. If false, they will not.") - (%redisplay-minibuffer :accessor redisplay-minibuffer - :initform nil - :initarg :redisplay-minibuffer - :documentation "If true, the minibuffer -associated with this Drei instance will be redisplayed as the -last part of the Drei redisplay process. If false, it is the task -of the Drei-using application to make sure the minibuffer is -redisplayed as appropriate.") (%isearch-mode :initform nil :accessor isearch-mode) (%isearch-states :initform '() :accessor isearch-states) (%isearch-previous-string :initform nil :accessor isearch-previous-string) @@ -388,13 +381,37 @@ (format stream "~A" (type-of (view object))))) ;; Main redisplay entry point. -(defgeneric display-drei (drei) +(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.")) +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))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -419,9 +436,6 @@ (defmethod handle-drei-condition (drei (condition motion-after-end)) (beep) (display-message "End of buffer")) -(defmethod handle-drei-condition (drei (condition no-expression)) - (beep) (display-message "No expression around point")) - (defmethod handle-drei-condition (drei (condition no-such-operation)) (beep) (display-message "Operation unavailable for syntax")) @@ -453,13 +467,27 @@ (handle-drei-condition (drei-instance) c)) (motion-after-end (c) (handle-drei-condition (drei-instance) c)) - (no-expression (c) - (handle-drei-condition (drei-instance) c)) (no-such-operation (c) - (handle-drei-condition (drei-instance) c)) - (buffer-read-only (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) @@ -482,7 +510,7 @@ (*kill-ring* ,(if kill-ring-p kill-ring `(kill-ring (drei-instance)))) (*minibuffer* ,(if minibuffer-p minibuffer - `(or (minibuffer (drei-instance)) *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 @@ -490,7 +518,8 @@ (*previous-command* ,(if previous-command-p previous-command `(previous-command (drei-instance)))) (*extended-command-prompt* ,(if prompt-p prompt - "Extended command: "))) + "Extended command: ")) + (*standard-input* (or *minibuffer* *standard-input*))) , at body)) (defgeneric invoke-performing-drei-operations (drei continuation &key with-undo redisplay) @@ -510,7 +539,7 @@ (pane (redisplay-frame-pane *application-frame* drei)) (t - (display-drei drei)))))) + (display-drei drei :redisplay-minibuffer t)))))) (defmacro performing-drei-operations ((drei &rest args &key with-undo (redisplay t)) @@ -581,9 +610,7 @@ `(invoke-accepting-from-user ,drei #'(lambda () , at body))) ;;; Plain `execute-frame-command' is not good enough for us. Our -;;; event-handler method uses this function to invoke commands, note -;;; that it is also responsible for updating the syntax of the buffer -;;; in the pane. +;;; 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 @@ -592,9 +619,8 @@ recording the operations performed by `command' for undo.")) (defmethod execute-drei-command ((drei drei) command) - (let ((*standard-input* (or *minibuffer* *standard-input*))) - (performing-drei-operations (drei :redisplay nil - :with-undo t) - (handling-drei-conditions - (apply (command-name command) (command-arguments command))) - (setf (previous-command 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))) --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/01/27 09:36:07 1.25 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/01/30 11:48:40 1.26 @@ -73,8 +73,6 @@ :y-position cy :active cursor-visibility :max-width max-width - :minibuffer (or *minibuffer* - *pointer-documentation-output*) :allow-other-keys t args))) ;; XXX Really add it here? @@ -561,19 +559,8 @@ (let* ((drei (drei-instance stream)) (*command-processor* drei) (was-directly-processing (directly-processing-p drei)) - (minibuffer (or (minibuffer drei) *minibuffer*)) (*drei-input-editing-stream* stream)) - (with-bound-drei-special-variables (drei - ;; If the minibuffer is the - ;; stream we are encapsulating - ;; for the - ;; input-editing-stream, we - ;; don't want to use it as a - ;; minibuffer. - :minibuffer (if (eq minibuffer *standard-input*) - *pointer-documentation-output* - minibuffer) - :prompt "M-x ") + (with-bound-drei-special-variables (drei :prompt "M-x ") (update-drei-buffer stream) ;; Commands are permitted to signal immediate rescans, but ;; we may need to do some stuff first. @@ -589,14 +576,13 @@ (abort-gesture (c) (if (member (abort-gesture-event c) *abort-gestures* - :test #'event-matches-gesture-name-p) + :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 (prefix-size (view drei)))) - ;; Will also take care of redisplaying minibuffer. - (display-drei drei) + (display-drei drei :redisplay-minibuffer t) (cond ((null first-mismatch) ;; No change actually took place, even though IP may ;; have moved. @@ -873,7 +859,7 @@ ;; and signal a rescan. (setf (activation-gesture stream) nil) (handle-drei-condition drei e) - (display-drei drei) + (display-drei drei :redisplay-minibuffer t) (immediate-rescan stream)))) (ptype (presentation-type-of object))) (return-from control-loop --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/30 07:31:33 1.48 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/30 11:48:40 1.49 @@ -167,7 +167,7 @@ #: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 #:no-expression + #:no-such-operation #:name-for-info-pane #:display-syntax-name #:syntax-line-indentation @@ -213,6 +213,7 @@ #:user-condition-mixin #:buffer-read-only #:buffer-single-line + #:no-available-minibuffer ;; Views and their facilities. #:drei-view #:modified-p #:no-cursors @@ -289,6 +290,7 @@ #: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 --- /project/mcclim/cvsroot/mcclim/Drei/search-commands.lisp 2008/01/26 12:37:25 1.7 +++ /project/mcclim/cvsroot/mcclim/Drei/search-commands.lisp 2008/01/30 11:48:40 1.8 @@ -309,6 +309,7 @@ (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)))) @@ -343,6 +344,7 @@ 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))) @@ -493,6 +495,7 @@ 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 @@ -502,6 +505,7 @@ (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 --- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/01/29 19:13:06 1.16 +++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/01/30 11:48:40 1.17 @@ -73,14 +73,6 @@ (:documentation "This condition is signaled whenever an attempt is made to execute an operation that is unavailable for the particular syntax" )) -(define-condition no-expression (simple-error) - () - (:report (lambda (condition stream) - (declare (ignore condition)) - (format stream "No expression at point"))) - (:documentation "This condition is signaled whenever an attempt is -made to execute a by-experssion motion command and no expression is available." )) - (defgeneric update-syntax (syntax unchanged-prefix unchanged-suffix &optional begin end) (:documentation "Inform the syntax module that it must update From thenriksen at common-lisp.net Wed Jan 30 11:48:42 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 30 Jan 2008 06:48:42 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080130114842.59C661203D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv27756 Modified Files: frames.lisp panes.lisp Log Message: Go some way towards fixing the minibuffer debacle. Drei will no longer attempt to create a minibuffer on its own pane. Commands that need the minibuffer, when none is available, will fail somewhat gracefully. Pointer documentation isn't broken yet, even with all the pointer-documentation-pane abuse I'm doing. I'll have to work on that. --- /project/mcclim/cvsroot/mcclim/frames.lisp 2008/01/27 22:24:07 1.130 +++ /project/mcclim/cvsroot/mcclim/frames.lisp 2008/01/30 11:48:40 1.131 @@ -1229,7 +1229,6 @@ (output-record-parent documentation-record)) (redisplay documentation-record *pointer-documentation-output*) (progn - (window-clear *pointer-documentation-output*) (setf documentation-record (updating-output (*pointer-documentation-output*) (updating-output (*pointer-documentation-output* --- /project/mcclim/cvsroot/mcclim/panes.lisp 2008/01/27 22:24:07 1.187 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2008/01/30 11:48:40 1.188 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.187 2008/01/27 22:24:07 thenriksen Exp $ +;;; $Id: panes.lisp,v 1.188 2008/01/30 11:48:40 thenriksen Exp $ (in-package :clim-internals) @@ -2761,8 +2761,19 @@ (defmethod stream-accept :before ((stream pointer-documentation-pane) type &rest args) (declare (ignore args)) - (setf (background-message stream) nil) - (redisplay-frame-pane (pane-frame stream) stream :force-p t)) + (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 From thenriksen at common-lisp.net Wed Jan 30 12:46:13 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 30 Jan 2008 07:46:13 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080130124613.C9B2125114@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv9277/Drei Modified Files: drei-redisplay.lisp Log Message: Define the face and drawing-options structs at compile-time. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/28 08:25:34 1.52 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/30 12:46:12 1.53 @@ -91,13 +91,14 @@ ;;; ;;; The standard redisplay implementation for buffer views. -(defstruct face - "A face is a description of how to draw (primarily) text, it +(eval-when (:compile-toplevel :load-toplevel :execute) + (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)) + (ink +foreground-ink+) + (style nil))) (defconstant +default-stroke-drawer-dispatcher+ #'(lambda (stream view stroke cursor-x cursor-y default-drawing-fn draw) @@ -107,10 +108,11 @@ 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+)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (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 From thenriksen at common-lisp.net Wed Jan 30 13:49:31 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 30 Jan 2008 08:49:31 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080130134931.AB347281DA@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv30783/Drei Modified Files: drawing-options.lisp drei-redisplay.lisp Log Message: Changed lots of defconstants to defvars in Drei. This removes the need for make-load-forms. --- /project/mcclim/cvsroot/mcclim/Drei/drawing-options.lisp 2008/01/17 17:01:47 1.5 +++ /project/mcclim/cvsroot/mcclim/Drei/drawing-options.lisp 2008/01/30 13:49:30 1.6 @@ -25,34 +25,34 @@ ;;; Some general styles. -(defconstant +roman-face+ (make-face :style (make-text-style nil :roman nil)) +(defvar +roman-face+ (make-face :style (make-text-style nil :roman nil)) "A face specifying a roman style, but with unspecified family and size.") -(defconstant +italic-face+ (make-face :style (make-text-style nil :italic nil)) +(defvar +italic-face+ (make-face :style (make-text-style nil :italic nil)) "A face specifying an italic style, but with unspecified family and size.") -(defconstant +bold-face+ (make-face :style (make-text-style nil :bold nil)) +(defvar +bold-face+ (make-face :style (make-text-style nil :bold nil)) "A face specifying a boldface style, but with unspecified family and size.") -(defconstant +bold-italic-face+ (make-face :style (make-text-style nil :bold nil)) +(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. -(defconstant +roman-face-drawing-options+ (make-drawing-options :face +roman-face+) +(defvar +roman-face-drawing-options+ (make-drawing-options :face +roman-face+) "Options used for drawing with a roman face.") -(defconstant +italic-face-drawing-options+ (make-drawing-options :face +italic-face+) +(defvar +italic-face-drawing-options+ (make-drawing-options :face +italic-face+) "Options used for drawing with an italic face.") -(defconstant +bold-face-drawing-options+ (make-drawing-options :face +bold-face+) +(defvar +bold-face-drawing-options+ (make-drawing-options :face +bold-face+) "Options used for drawing with boldface.") -(defconstant +bold-italic-face-drawing-options+ (make-drawing-options :face +bold-italic-face+) +(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, --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/30 12:46:12 1.53 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/30 13:49:30 1.54 @@ -91,14 +91,13 @@ ;;; ;;; The standard redisplay implementation for buffer views. -(eval-when (:compile-toplevel :load-toplevel :execute) - (defstruct face - "A face is a description of how to draw (primarily) text, it +(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))) + (ink +foreground-ink+) + (style nil)) (defconstant +default-stroke-drawer-dispatcher+ #'(lambda (stream view stroke cursor-x cursor-y default-drawing-fn draw) @@ -108,11 +107,10 @@ arguments. Used as the default drawing-function of `drawing-options' objects.") -(eval-when (:compile-toplevel :load-toplevel :execute) - (defstruct drawing-options - "A set of options for how to display a stroke." - (face (make-face)) - (function +default-stroke-drawer-dispatcher+))) +(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 @@ -134,7 +132,7 @@ (eq (drawing-options-function o1) +default-stroke-drawer-dispatcher+))))) -(defconstant +default-drawing-options+ (make-drawing-options) +(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 @@ -512,7 +510,7 @@ (vector-push-extend width widths)))) finally (return (values width parts widths)))) -(defconstant +roman-face-style+ (make-text-style nil :roman nil) +(defvar +roman-face-style+ (make-text-style nil :roman nil) "A text style specifying a roman face, but with unspecified family and size.") From thenriksen at common-lisp.net Wed Jan 30 15:56:42 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 30 Jan 2008 10:56:42 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080130155642.CDC191B024@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv27422/Drei Modified Files: drei-clim.lisp Log Message: Clear the cursor whenever it is disabled. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/30 11:48:40 1.36 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/30 15:56:42 1.37 @@ -100,12 +100,13 @@ (declare (ignore initargs)) (stream-add-output-record (output-stream object) object)) -(defmethod active ((cursor drei-cursor)) - "Whether the cursor is active or +(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." - (active (view 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 @@ -116,6 +117,9 @@ (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 @@ -141,7 +145,7 @@ (mark (view cursor))) (defmethod enabled ((cursor mark-cursor)) - *show-mark*) + (and (call-next-method) *show-mark*)) (defgeneric visible-1 (cursor view) (:documentation "Is `cursor', associated with `view', visible? From thenriksen at common-lisp.net Wed Jan 30 15:57:35 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 30 Jan 2008 10:57:35 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080130155735.E1C9A1B02B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv27510/Drei Modified Files: input-editor.lisp Log Message: Removed strange double-call to (call-next-method). --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/01/30 11:48:40 1.26 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/01/30 15:57:35 1.27 @@ -786,8 +786,7 @@ :syntax "Lisp" :keep-syntax t) (redraw-input-buffer stream) - (call-next-method)) - (call-next-method)) + (call-next-method))) (define-presentation-method accept ((type expression) (stream drei-input-editing-mixin) From thenriksen at common-lisp.net Wed Jan 30 15:58:14 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 30 Jan 2008 10:58:14 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080130155814.7F02532041@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv27565 Modified Files: input-editing-drei.lisp input-editing-goatee.lisp input-editing.lisp Log Message: Made the input-editing streams and clim-stream-panes interactive streams. --- /project/mcclim/cvsroot/mcclim/input-editing-drei.lisp 2008/01/19 09:38:20 1.6 +++ /project/mcclim/cvsroot/mcclim/input-editing-drei.lisp 2008/01/30 15:58:14 1.7 @@ -25,15 +25,6 @@ (in-package :clim-internals) -(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 empty-input-mixin () () (:documentation "A mixin class used for detecting empty input")) @@ -50,6 +41,9 @@ 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)) --- /project/mcclim/cvsroot/mcclim/input-editing-goatee.lisp 2006/11/08 01:18:22 1.1 +++ /project/mcclim/cvsroot/mcclim/input-editing-goatee.lisp 2008/01/30 15:58:14 1.2 @@ -37,6 +37,9 @@ (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)) --- /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/01/19 09:38:20 1.57 +++ /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/01/30 15:58:14 1.58 @@ -48,6 +48,17 @@ `*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)) + (:method ((stream clim-stream-pane)) + t))) + ;;; These helper functions take the arguments of ACCEPT so that they ;;; can be used directly by ACCEPT. From thenriksen at common-lisp.net Wed Jan 30 17:08:01 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 30 Jan 2008 12:08:01 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080130170801.5495C4818B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv14733 Modified Files: input-editing-drei.lisp Log Message: Replay used input-editing streams whether they have an input-sensitizer or not. --- /project/mcclim/cvsroot/mcclim/input-editing-drei.lisp 2008/01/30 15:58:14 1.7 +++ /project/mcclim/cvsroot/mcclim/input-editing-drei.lisp 2008/01/30 17:08:01 1.8 @@ -109,14 +109,18 @@ (setf (cursor-visibility stream) nil) (let ((real-stream (encapsulating-stream-stream stream)) (record (drei:drei-instance 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) - (replay record real-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 (nth-value 3 (input-editing-stream-bounding-rectangle stream)))))) From dlichteblau at common-lisp.net Wed Jan 30 18:56:40 2008 From: dlichteblau at common-lisp.net (dlichteblau) Date: Wed, 30 Jan 2008 13:56:40 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20080130185640.00F0816053@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv8153 Modified Files: medium.lisp Log Message: Fixed "Draw images from the upper-left corner in the CLX backend": Use a matching clipping region. Strange sense of deja-vu for me, too. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2008/01/25 07:36:39 1.87 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2008/01/30 18:56:40 1.88 @@ -1211,7 +1211,7 @@ (xlib:with-gcontext (gcontext :clip-mask mask :clip-x x - :clip-y (- y height)) + :clip-y y) (xlib:copy-area pixmap gcontext 0 0 width height da x y))) (t From dlichteblau at common-lisp.net Wed Jan 30 19:44:42 2008 From: dlichteblau at common-lisp.net (dlichteblau) Date: Wed, 30 Jan 2008 14:44:42 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Experimental/freetype Message-ID: <20080130194442.30F9C1B03C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv18929 Modified Files: mcclim-freetype.asd Log Message: restored cffi freetype code --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/mcclim-freetype.asd 2008/01/17 07:57:55 1.9 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/mcclim-freetype.asd 2008/01/30 19:44:42 1.10 @@ -42,7 +42,46 @@ (:file "freetype-fonts-cffi"))) +#+sbcl (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-freetype))) + +;;; Freetype autodetection +#-sbcl +(progn + (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 + (make-pathname :directory (pathname-directory filename))))) + + (defun warn-about-unset-font-path () + (warn "~%~%NOTE:~%~ +* 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/~%~%~%")) + + (defmethod perform :after ((o load-op) (s (eql (asdf:find-system :mcclim-freetype)))) + (unless + (setf (symbol-value (intern "*FREETYPE-FONT-PATH*" :mcclim-freetype)) + (find-bitstream-fonts)) + (warn-about-unset-font-path))) + + (defun find-bitstream-fonts () + (with-input-from-string + (s (with-output-to-string (asdf::*verbose-out*) + (let ((code (asdf:run-shell-command "fc-match -v Bitstream Vera"))) + (unless (zerop code) + (warn "~&fc-match failed with code ~D.~%" code))))) + (parse-fontconfig-output s)))) From thenriksen at common-lisp.net Wed Jan 30 20:43:39 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 30 Jan 2008 15:43:39 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080130204339.B455616037@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv32120/Drei Modified Files: drei-redisplay.lisp Log Message: Fix *really* obscure case where changes to the Drei buffer would not be picked up by redisplay. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/30 13:49:30 1.54 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/30 20:43:39 1.55 @@ -418,10 +418,10 @@ (invalidate-stroke stroke :modified t)) ;; Move to the next changed region, if it is not possible for ;; more stroks to overlap with the current one. - (when (and changed-region - (>= (stroke-end-offset stroke) - (cdr changed-region))) - (pop (changed-regions view))) + (loop while (and (first (changed-regions view)) + (>= (stroke-end-offset stroke) + (cdr (first (changed-regions view))))) + do (pop (changed-regions view))) (incf (line-stroke-count line)) (setf (line-end-offset line) (stroke-end-offset stroke))))) From thenriksen at common-lisp.net Wed Jan 30 21:21:43 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 30 Jan 2008 16:21:43 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080130212143.E741970324@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv8469/Drei Modified Files: drei.lisp input-editor.lisp views.lisp Log Message: WITH-INPUT-EDITING now works really well with Drei. --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/30 11:48:40 1.35 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/30 21:21:43 1.36 @@ -234,8 +234,7 @@ ;;; The basic Drei class. (defclass drei () - ((%view :initform (make-instance 'textual-drei-syntax-view) - :initarg :view + ((%view :initarg :view :accessor view :documentation "The CLIM view that will be used whenever this Drei is being displayed. During redisplay, the @@ -345,16 +344,18 @@ (cursors drei)))) (defmethod initialize-instance :after ((drei drei) &rest args &key - active single-line (editable-p t) - no-cursors) + view active single-line (editable-p t) + no-cursors initial-contents) (declare (ignore args)) - (with-accessors ((buffer buffer) - (point point) (mark mark)) (view drei) - (setf (active (view drei)) active) - (setf (single-line-p (implementation buffer)) single-line) - (setf (read-only-p buffer) (not editable-p)) - (setf (no-cursors (view drei)) no-cursors) - (add-view-cursors drei))) + (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 --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/01/30 15:57:35 1.27 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/01/30 21:21:43 1.28 @@ -53,7 +53,7 @@ (defmethod initialize-instance :after ((obj drei-input-editing-mixin) &rest args - &key stream (initial-contents "") + &key stream (cursor-visibility t) (min-width 0)) (check-type min-width (or (integer 0) (eql t))) @@ -66,9 +66,6 @@ (apply #'make-instance 'drei-area :editor-pane stream - :buffer (make-instance 'drei-buffer - :name "Input-editor buffer" - :initial-contents initial-contents) :x-position cx :y-position cy :active cursor-visibility @@ -76,8 +73,10 @@ :allow-other-keys t args))) ;; XXX Really add it here? - (stream-add-output-record stream (drei-instance obj)) - (display-drei (drei-instance obj))))) + (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)) @@ -155,17 +154,23 @@ ;; we can support fancy accept methods such as the one for ;; `command-or-form' (unless (stream-rescanning-p stream) - (call-next-method) + ;; 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))) + (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) @@ -670,6 +675,9 @@ (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) @@ -679,14 +687,12 @@ ;; 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)) - ;; Since everything inserted with this method is noise strings, we - ;; do not bother to modify the scan pointer or queue rescans. - (display-drei drei))) + 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)) --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/30 07:31:34 1.31 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/30 21:21:43 1.32 @@ -287,7 +287,9 @@ ;;; Readonly (defclass read-only-mixin () - ((read-only-p :initform nil :accessor read-only-p))) + ((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)) @@ -376,13 +378,17 @@ (:default-initargs :implementation (make-instance 'extended-standard-buffer))) (defmethod initialize-instance :after ((buffer drei-buffer) &rest args - &key initial-contents) + &key read-only single-line + initial-contents) (declare (ignore args)) - (with-accessors ((point point)) buffer + (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 point (make-buffer-mark buffer (size buffer) :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))) @@ -520,7 +526,6 @@ (defclass drei-buffer-view (drei-view) ((%buffer :accessor buffer - :initform (make-instance 'drei-buffer) :initarg :buffer :type drei-buffer :accessor buffer @@ -571,11 +576,20 @@ 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) +(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) (buffer buffer)) view - (setf top (make-buffer-mark buffer 0 :left) - bot (make-buffer-mark buffer (size buffer) :right)))) + (with-accessors ((top top) (bot bot)) 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 (make-buffer-mark (buffer view) (size (buffer view)) :right)))) (defmethod (setf top) :after (new-value (view drei-buffer-view)) (invalidate-all-strokes view)) From thenriksen at common-lisp.net Wed Jan 30 21:21:44 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 30 Jan 2008 16:21:44 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080130212144.3B611711C4@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv8469 Modified Files: input-editing-drei.lisp input-editing.lisp panes.lisp Log Message: WITH-INPUT-EDITING now works really well with Drei. --- /project/mcclim/cvsroot/mcclim/input-editing-drei.lisp 2008/01/30 17:08:01 1.8 +++ /project/mcclim/cvsroot/mcclim/input-editing-drei.lisp 2008/01/30 21:21:43 1.9 @@ -154,18 +154,23 @@ initial-contents class) (let ((editing-stream (make-instance class - :stream stream - :initial-contents initial-contents))) + :stream stream))) + (if (stringp initial-contents) + (replace-input editing-stream initial-contents) + (presentation-replace-input editing-stream + (first initial-contents) + (second initial-contents) + (stream-default-view editing-stream))) (unwind-protect (loop - (block rescan - (handler-bind ((rescan-condition - #'(lambda (c) - (declare (ignore c)) - (reset-scan-pointer editing-stream) - (return-from rescan nil)))) - (return-from invoke-with-input-editing - (funcall continuation editing-stream))))) + (block rescan + (handler-bind ((rescan-condition + #'(lambda (c) + (declare (ignore c)) + (reset-scan-pointer editing-stream) + (return-from rescan nil)))) + (return-from invoke-with-input-editing + (funcall continuation editing-stream))))) (finalize editing-stream input-sensitizer)))) (defmethod immediate-rescan ((stream standard-input-editing-stream)) --- /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/01/30 15:58:14 1.58 +++ /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/01/30 21:21:44 1.59 @@ -55,9 +55,7 @@ (fmakunbound 'interactive-stream-p)) (defgeneric interactive-stream-p (stream) (:method (stream) - (cl:interactive-stream-p stream)) - (:method ((stream clim-stream-pane)) - t))) + (cl:interactive-stream-p stream)))) ;;; These helper functions take the arguments of ACCEPT so that they ;;; can be used directly by ACCEPT. --- /project/mcclim/cvsroot/mcclim/panes.lisp 2008/01/30 11:48:40 1.188 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2008/01/30 21:21:44 1.189 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.188 2008/01/30 11:48:40 thenriksen Exp $ +;;; $Id: panes.lisp,v 1.189 2008/01/30 21:21:44 thenriksen Exp $ (in-package :clim-internals) @@ -2528,6 +2528,9 @@ "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) From thenriksen at common-lisp.net Wed Jan 30 21:30:05 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 30 Jan 2008 16:30:05 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080130213005.6679E1B037@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv9307/Drei Modified Files: input-editor.lisp Log Message: Fixed WITH-INPUT-EDITOR-TYPEOUT for Drei. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/01/30 21:21:43 1.28 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/01/30 21:30:02 1.29 @@ -760,9 +760,9 @@ (defmethod invoke-with-input-editor-typeout ((stream drei-input-editing-mixin) (continuation function) &key erase) (declare (ignore erase)) - (let ((drei (drei-instance stream))) - (when (minibuffer drei) - (funcall continuation (minibuffer drei))))) + (with-bound-drei-special-variables ((drei-instance stream)) + (with-minibuffer-stream (minibuffer) + (funcall continuation minibuffer)))) (defmacro with-input-editor-typeout ((&optional (stream t) &rest args &key erase) From thenriksen at common-lisp.net Wed Jan 30 21:41:11 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 30 Jan 2008 16:41:11 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080130214111.D980C71140@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv12517/Drei Modified Files: input-editor.lisp Log Message: Make the accept methods for command-or-form work better with things like Structedit. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/01/30 21:30:02 1.29 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/01/30 21:41:11 1.30 @@ -783,6 +783,28 @@ ;;; ;;; 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 nil) + (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) From thenriksen at common-lisp.net Wed Jan 30 22:11:36 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 30 Jan 2008 17:11:36 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080130221136.105D67114B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv17467/Drei Modified Files: input-editor.lisp Log Message: Oops, keep Lisp syntax highlighting even after the input has been activated. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/01/30 21:41:11 1.30 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/01/30 22:11:35 1.31 @@ -793,7 +793,7 @@ view &key) (with-drei-options ((drei-instance stream) :syntax "Lisp" - :keep-syntax nil) + :keep-syntax t) (call-next-method))) (define-presentation-method accept :around From thenriksen at common-lisp.net Wed Jan 30 22:29:11 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 30 Jan 2008 17:29:11 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080130222911.DB99E7141@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv21204 Modified Files: input-editing-drei.lisp input-editing.lisp Log Message: Try to centralise the with-input-editing logic a bit. Make with-input-editing work for input-editing-streams. --- /project/mcclim/cvsroot/mcclim/input-editing-drei.lisp 2008/01/30 21:21:43 1.9 +++ /project/mcclim/cvsroot/mcclim/input-editing-drei.lisp 2008/01/30 22:29:07 1.10 @@ -124,9 +124,6 @@ (setf (stream-cursor-position real-stream) (values 0 (nth-value 3 (input-editing-stream-bounding-rectangle stream)))))) -(defgeneric invoke-with-input-editing - (stream continuation input-sensitizer initial-contents class)) - (defmethod invoke-with-input-editing :around ((stream extended-output-stream) continuation input-sensitizer @@ -153,24 +150,12 @@ input-sensitizer initial-contents class) - (let ((editing-stream (make-instance class - :stream stream))) - (if (stringp initial-contents) - (replace-input editing-stream initial-contents) - (presentation-replace-input editing-stream - (first initial-contents) - (second initial-contents) - (stream-default-view editing-stream))) - (unwind-protect - (loop - (block rescan - (handler-bind ((rescan-condition - #'(lambda (c) - (declare (ignore c)) - (reset-scan-pointer editing-stream) - (return-from rescan nil)))) - (return-from invoke-with-input-editing - (funcall continuation editing-stream))))) + (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) + (funcall continuation editing-stream)) (finalize editing-stream input-sensitizer)))) (defmethod immediate-rescan ((stream standard-input-editing-stream)) --- /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/01/30 21:21:44 1.59 +++ /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/01/30 22:29:07 1.60 @@ -230,11 +230,37 @@ (return-from input-editing-rescan-loop (funcall continuation editing-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) + (let ((start-scan-pointer (stream-scan-pointer stream))) + (if (stringp initial-contents) + (replace-input stream initial-contents) + (presentation-replace-input stream + (first initial-contents) + (second initial-contents) + (stream-default-view stream))) + (unwind-protect + (loop (block rescan + (handler-bind ((rescan-condition + #'(lambda (c) + (declare (ignore c)) + (reset-scan-pointer stream + start-scan-pointer) + (return-from rescan nil)))) + (return-from invoke-with-input-editing + (funcall continuation stream)))))))) + (defgeneric input-editing-stream-bounding-rectangle (stream) (:documentation "Return the bounding rectangle of `stream' as four values. This function does not appear in the spec but is From thenriksen at common-lisp.net Wed Jan 30 23:22:46 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 30 Jan 2008 18:22:46 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080130232246.22E1630040@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv1354 Modified Files: menu-choose.lisp Log Message: The :PRINTER function to MENU-CHOOSE should be called with the menu item, not the menu item display. --- /project/mcclim/cvsroot/mcclim/menu-choose.lisp 2007/02/05 03:00:54 1.20 +++ /project/mcclim/cvsroot/mcclim/menu-choose.lisp 2008/01/30 23:22:45 1.21 @@ -226,9 +226,7 @@ (if default-item-p default-item (first items)) - :item-printer (if printer - (lambda (item stream) - (funcall printer (menu-item-display item) stream)) + :item-printer (or printer #'print-menu-item) :max-width max-width :max-height max-height From thenriksen at common-lisp.net Wed Jan 30 23:24:06 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 30 Jan 2008 18:24:06 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080130232406.622EB30041@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv1491/Drei Modified Files: lisp-syntax.lisp Log Message: Support :POSSIBILITY-PRINTER for COMPLETE-INPUT. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/22 23:00:04 1.71 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/30 23:24:05 1.72 @@ -2613,8 +2613,9 @@ (with-minibuffer-stream (minibuffer) (let ((*print-escape* nil)) (princ condition minibuffer))) - (setf (offset (point drei)) - (start-offset (form condition)))) + (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 From thenriksen at common-lisp.net Wed Jan 30 23:24:06 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 30 Jan 2008 18:24:06 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080130232406.CD9F27E00D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv1491 Modified Files: input-editing.lisp Log Message: Support :POSSIBILITY-PRINTER for COMPLETE-INPUT. --- /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/01/30 22:29:07 1.60 +++ /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/01/30 23:24:06 1.61 @@ -494,11 +494,16 @@ (defun possibilities-for-menu (possibilities) (loop for p in possibilities - for (display . object) = p - if (listp object) - collect `(,display :value ,object) - else - collect p)) + for (display . object) = p + 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'" + (destructuring-bind (string object) possibility + (with-output-as-presentation (stream object ptype) + (write-string string stream)))) ;;; Helper returns gesture (or nil if gesture shouldn't be part of the input) ;;; and completion mode, if any. @@ -537,9 +542,9 @@ (defparameter *trace-complete-input* nil) (defun complete-input (stream func &key - partial-completers allow-any-input possibility-printer + partial-completers allow-any-input + (possibility-printer #'possibility-printer) (help-displays-possibilities t)) - (declare (ignore possibility-printer)) (let ((so-far (make-array 1 :element-type 'character :adjustable t :fill-pointer 0)) (*accelerator-gestures* (append *help-gestures* @@ -585,8 +590,17 @@ (when (and (> nmatches 0) (eq mode :possibilities)) (multiple-value-bind (menu-object item event) (menu-choose (possibilities-for-menu possibilities) - :label "Possibilities" - :n-columns 1) + :label "Possibilities" + :n-columns 1 + :printer #'(lambda (possibility stream) + ;; We have to get a + ;; presentation type from + ;; somewhere... + (destructuring-bind (string &key value) possibility + (funcall possibility-printer + (list string value) + (presentation-type-of value) + stream)))) (declare (ignore event)) (if item (setf (values input success object nmatches) From thenriksen at common-lisp.net Wed Jan 30 23:39:19 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 30 Jan 2008 18:39:19 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080130233919.D473E5C183@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv3409 Modified Files: input-editing.lisp Log Message: Fixed nested use of with-input-editing. --- /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/01/30 23:24:06 1.61 +++ /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/01/30 23:39:19 1.62 @@ -220,15 +220,17 @@ , at body))) (defun input-editing-rescan-loop (editing-stream continuation) - (loop - (block rescan - (handler-bind ((rescan-condition - #'(lambda (c) - (declare (ignore c)) - (reset-scan-pointer editing-stream) - (return-from rescan nil)))) - (return-from input-editing-rescan-loop - (funcall continuation editing-stream)))))) + (let ((start-scan-pointer (stream-scan-pointer editing-stream))) + (loop + (block rescan + (handler-bind ((rescan-condition + #'(lambda (c) + (reset-scan-pointer editing-stream start-scan-pointer) + ;; Input-editing contexts above may be interested... + (signal c) + (return-from rescan nil)))) + (return-from input-editing-rescan-loop + (funcall continuation editing-stream))))))) (defgeneric invoke-with-input-editing (stream continuation input-sensitizer initial-contents class) @@ -243,23 +245,14 @@ (defmethod invoke-with-input-editing ((stream input-editing-stream) continuation input-sensitizer initial-contents class) - (let ((start-scan-pointer (stream-scan-pointer stream))) + (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))) - (unwind-protect - (loop (block rescan - (handler-bind ((rescan-condition - #'(lambda (c) - (declare (ignore c)) - (reset-scan-pointer stream - start-scan-pointer) - (return-from rescan nil)))) - (return-from invoke-with-input-editing - (funcall continuation stream)))))))) + (stream-default-view stream)))) + (input-editing-rescan-loop stream continuation)) (defgeneric input-editing-stream-bounding-rectangle (stream) (:documentation "Return the bounding rectangle of `stream' as From thenriksen at common-lisp.net Thu Jan 31 08:34:15 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 31 Jan 2008 03:34:15 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/Tests Message-ID: <20080131083415.C9CA81B04C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv22290/Drei/Tests Modified Files: core-tests.lisp Log Message: Put point at offset 0, even if there are initial contents. Made some tests run. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/core-tests.lisp 2008/01/19 20:06:01 1.7 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/core-tests.lisp 2008/01/31 08:34:15 1.8 @@ -27,42 +27,6 @@ (in-suite core-tests) -(test downcase-word - (with-drei-environment () - (downcase-word (point) (current-syntax) 1) - (is (string= (buffer-contents) ""))) - (with-drei-environment (:initial-contents "CLI MA CS CLIMACS") - (let ((m (clone-mark (point) :right))) - (setf (offset m) 0) - (downcase-word m (current-syntax) 3) - (is (string= (buffer-contents) - "cli ma cs CLIMACS")) - (is (= (offset m) 9))))) - -(test upcase-word - (with-drei-environment () - (upcase-word (point) (current-syntax) 1) - (is (string= (buffer-contents) ""))) - (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 "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 possibly-fill-line (with-drei-environment () (possibly-fill-line) @@ -191,6 +155,9 @@ (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") @@ -206,9 +173,16 @@ (buffer-is "drei climacs Drei")) (with-drei-environment (:initial-contents "Drei Climacs Drei") (downcase-word (point) (current-syntax) 3) - (buffer-is "drei climacs drei"))) + (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") @@ -224,9 +198,19 @@ (buffer-is "DREI CLIMACS Drei")) (with-drei-environment (:initial-contents "Drei Climacs Drei") (upcase-word (point) (current-syntax) 3) - (buffer-is "DREI CLIMACS DREI"))) + (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") @@ -242,7 +226,14 @@ (buffer-is "Drei Climacs drei")) (with-drei-environment (:initial-contents "drei climacs drei") (capitalize-word (point) (current-syntax) 3) - (buffer-is "Drei Climacs Drei"))) + (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 From thenriksen at common-lisp.net Thu Jan 31 08:34:15 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 31 Jan 2008 03:34:15 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080131083415.E9A1D1B04D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv22290/Drei Modified Files: views.lisp Log Message: Put point at offset 0, even if there are initial contents. Made some tests run. --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/30 21:21:43 1.32 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/31 08:34:15 1.33 @@ -386,7 +386,7 @@ (when initial-contents (check-type initial-contents array) (insert-buffer-sequence buffer 0 initial-contents)) - (setf point (make-buffer-mark buffer (size buffer) :right)) + (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 From ahefner at common-lisp.net Thu Jan 31 08:46:44 2008 From: ahefner at common-lisp.net (ahefner) Date: Thu, 31 Jan 2008 03:46:44 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20080131084644.28FA839154@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv25429 Modified Files: wholine.lisp Log Message: Detect changed package name. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/wholine.lisp 2008/01/06 01:33:25 1.3 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/wholine.lisp 2008/01/31 08:46:44 1.4 @@ -83,7 +83,7 @@ ;; But :small looks awful using freetype, perhaps because the ;; fonts are, for whatever reason, slightly smaller. ;; Very distressing. - (text-size (if (find-package :mcclim-freetype) :normal :small)) + (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) From thenriksen at common-lisp.net Thu Jan 31 10:47:09 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 31 Jan 2008 05:47:09 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080131104709.1045B3002B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv13034 Modified Files: NEWS presentations.lisp Log Message: Fixed erroneous call to MENU-CHOOSE. Mentioned MENU-CHOOSE change in NEWS. --- /project/mcclim/cvsroot/mcclim/NEWS 2008/01/29 19:13:07 1.33 +++ /project/mcclim/cvsroot/mcclim/NEWS 2008/01/31 10:47:07 1.34 @@ -21,6 +21,8 @@ ** 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. * Changes in mcclim-0.9.5 relative to 0.9.4: ** Installation: the systems clim-listener, clim-examples, --- /project/mcclim/cvsroot/mcclim/presentations.lisp 2007/11/19 22:04:29 1.82 +++ /project/mcclim/cvsroot/mcclim/presentations.lisp 2008/01/31 10:47:08 1.83 @@ -1917,12 +1917,13 @@ :label label :associated-window window :printer #'(lambda (item stream) - (document-presentation-translator - (presentation-translator-menu-item-translator item) - (presentation-translator-menu-item-presentation item) - (presentation-translator-menu-item-context item) - frame nil window x y - :stream 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)) From rschlatte at common-lisp.net Thu Jan 31 11:06:40 2008 From: rschlatte at common-lisp.net (rschlatte) Date: Thu, 31 Jan 2008 06:06:40 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20080131110640.CA73C4B023@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv17422/Apps/Listener Modified Files: dev-commands.lisp util.lisp Log Message: cleanup parent-directory, remove filtermap --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/01/26 05:09:39 1.47 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/01/31 11:06:40 1.48 @@ -555,9 +555,9 @@ (initfunc (clim-mop:slot-definition-initfunction slot)) (initform (clim-mop:slot-definition-initform slot)) (direct-slots (direct-slot-definitions class name)) - (readers (reduce #'append (filtermap direct-slots #'clim-mop:slot-definition-readers))) - (writers (reduce #'append (filtermap direct-slots #'clim-mop:slot-definition-writers))) - (documentation (first (filtermap direct-slots (lambda (x) (documentation x t))))) + (readers (mapcan #'clim-mop:slot-definition-readers direct-slots)) + (writers (mapcan #'clim-mop:slot-definition-writers direct-slots)) + (documentation (first (mapcan (lambda (x) (list (documentation x t))) direct-slots))) (*standard-output* stream)) (macrolet ((with-ink ((var) &body body) @@ -1146,7 +1146,7 @@ (format t " (only files of type ~a)" (pathname-type pathname))))) (when (parent-directory pathname) - (with-output-as-presentation (t (strip-filespec (parent-directory pathname)) 'clim:pathname :single-box t) + (with-output-as-presentation (t (parent-directory pathname) 'clim:pathname :single-box t) (draw-icon t (standard-icon "up-folder.xpm") :extra-spacing 3) (format t "Parent Directory~%"))) --- /project/mcclim/cvsroot/mcclim/Apps/Listener/util.lisp 2007/02/05 03:28:05 1.22 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/util.lisp 2008/01/31 11:06:40 1.23 @@ -20,11 +20,6 @@ ;;; Boston, MA 02111-1307 USA. - -(defun filtermap (list func &optional (filter #'null)) - (declare (type (function (t) t) func)) - (delete-if filter (mapcar func list))) - ;(defmacro multiple-value-prog2 (&body body) `(progn ,(first body) (multiple-value-prog1 ,@(rest body)))) ;; multiple-value-or, ugh. Normal OR drops values except from the last form. @@ -275,14 +270,15 @@ #+scl :query #+scl nil :defaults pathname)) -;; Oops, should I be doing something with relative pathnames here? (defun parent-directory (pathname) "Returns a pathname designating the directory 'up' from PATHNAME" - (let ((dir (pathname-directory (truename (strip-filespec pathname))))) + (let ((dir (pathname-directory (truename pathname)))) (when (and (eq (first dir) :absolute) - (not (zerop (length (rest dir))))) - (make-pathname :directory `(:absolute ,@(nreverse (rest (reverse (rest dir))))) - :defaults pathname)))) + (rest dir)) + ;; merge-pathnames merges :back, but not :up + (strip-filespec + (merge-pathnames (make-pathname :directory '(:relative :back)) + (truename pathname)))))) ;;;; Abbreviating item formatter From thenriksen at common-lisp.net Thu Jan 31 11:19:36 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 31 Jan 2008 06:19:36 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080131111936.B220173238@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv18673/Drei Modified Files: input-editor.lisp Log Message: Only constrain point/mark when we actually have a prompt. You can now delete the leading command in the Listener! --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/01/30 22:11:35 1.31 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/01/31 11:19:35 1.32 @@ -571,10 +571,16 @@ ;; we may need to do some stuff first. (unwind-protect (accepting-from-user (drei) - ;; We narrow the buffer to the input position, so the user won't - ;; be able to erase the original command (when entering command - ;; arguments) or stuff like argument prompts. - (drei-core:with-narrowed-buffer (drei (input-position stream) t t) + ;; 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 (view drei)) index) + 'noise-string) + return (1+ index) + finally (return 0)) + t t) (handler-case (process-gestures-or-command drei) (unbound-gesture-sequence (c) (display-message "~A is unbound" (gesture-name (gestures c)))) From thenriksen at common-lisp.net Thu Jan 31 12:14:05 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 31 Jan 2008 07:14:05 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080131121405.84DB268361@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv796/Drei Modified Files: drei-clim.lisp packages.lisp Log Message: Moved with-output-as-presentation to presentations.lisp, so it can be available when input-editing.lisp is compiled. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/30 15:56:42 1.37 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/31 12:14:05 1.38 @@ -387,14 +387,14 @@ (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)) +(defmethod* (setf output-record-position) ((new-x number) (new-y number) + (record drei-area)) (setf (area-position record) (list new-x 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) +(defmethod* (setf output-record-start-cursor-position) ((new-x number) (new-y number) (record drei-area)) (setf (output-record-position record) (list new-x new-y))) --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/30 11:48:40 1.49 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/31 12:14:05 1.50 @@ -184,7 +184,7 @@ contents.")) (defpackage :drei - (:use :clim-lisp :clim :drei-buffer :drei-base :drei-abbrev + (: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 From thenriksen at common-lisp.net Thu Jan 31 12:14:06 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 31 Jan 2008 07:14:06 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080131121406.4114C6A004@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv796 Modified Files: mcclim.asd presentation-defs.lisp presentations.lisp Log Message: Moved with-output-as-presentation to presentations.lisp, so it can be available when input-editing.lisp is compiled. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/01/10 09:38:07 1.74 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/01/31 12:14:05 1.75 @@ -218,8 +218,8 @@ :depends-on (:clim-basic :goatee-core :clim-postscript) :components ((:file "text-formatting") (:file "defresource") - (:file "input-editing") (:file "presentations") + (:file "input-editing" :depends-on ("presentations")) (:file "pointer-tracking" :depends-on ("input-editing")) (:file "graph-formatting") (:file "frames" :depends-on ("commands" "presentations" "presentation-defs" --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2007/11/19 22:14:05 1.73 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2008/01/31 12:14:05 1.74 @@ -392,40 +392,6 @@ (type-key parameters options object type stream view &key &allow-other-keys)) -(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 () - , at decls - , at 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) - , at key-args) - (let ((*allow-sensitive-inferiors* - ,allow-sensitive-inferiors)) - (,continuation))) - (,continuation))))))) - - (defun present (object &optional (type (presentation-type-of object)) &key (stream *standard-output*) --- /project/mcclim/cvsroot/mcclim/presentations.lisp 2008/01/31 10:47:08 1.83 +++ /project/mcclim/cvsroot/mcclim/presentations.lisp 2008/01/31 12:14:05 1.84 @@ -52,6 +52,39 @@ (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 () + , at decls + , at 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) + , at 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")) From thenriksen at common-lisp.net Thu Jan 31 16:50:08 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 31 Jan 2008 11:50:08 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080131165008.193EC1B02E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv6137/Drei Modified Files: drei-clim.lisp input-editor.lisp Log Message: Added new and cooler with-input-editor-typeout implementation for Drei. Still not used for anything inside McCLIM, but I hope to change input completion to use it instead of menu-choose for some cases. The biggest problem, I think, is that Goatee doesn't support with-input-editor-typeout. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/31 12:14:05 1.38 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/31 16:50:07 1.39 @@ -389,14 +389,20 @@ (defmethod* (setf output-record-position) ((new-x number) (new-y number) (record drei-area)) - (setf (area-position record) (list new-x new-y))) + (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) (list new-x new-y))) + (setf (output-record-position record) (values new-x new-y))) (defmethod output-record-hit-detection-rectangle* ((record drei-area)) (bounding-rectangle* record)) --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/01/31 11:19:35 1.32 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/01/31 16:50:07 1.33 @@ -46,7 +46,13 @@ :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.")) +replaced by the contents of this array, if non-NIL.") + (%typeout-record :accessor typeout-record + :initform nil + :documentation "The output record (if any) +that is the typeout information for this Drei-based +input-editing-stream. `With-input-editor-typeout' manages this +output record.")) (:documentation "An mixin that helps in implementing Drei-based input-editing streams. This class should not be directly instantiated.")) @@ -763,12 +769,39 @@ (:documentation "Call `continuation' with a single argument, a stream to do input-editor-typeout on.")) -(defmethod invoke-with-input-editor-typeout ((stream drei-input-editing-mixin) +(defmethod invoke-with-input-editor-typeout ((editing-stream drei-input-editing-mixin) (continuation function) &key erase) - (declare (ignore erase)) - (with-bound-drei-special-variables ((drei-instance stream)) - (with-minibuffer-stream (minibuffer) - (funcall continuation minibuffer)))) + (let* ((encapsulated-stream (encapsulating-stream-stream editing-stream)) + (new-typeout-record (with-output-to-output-record (encapsulated-stream) + (funcall continuation encapsulated-stream))) + (editor-record (drei-instance editing-stream))) + (with-accessors ((stream-typeout-record typeout-record)) editing-stream + (with-sheet-medium (medium encapsulated-stream) + (with-bounding-rectangle* (x1 y1 x2 y2) editor-record + ;; Clear the input-editor display. + (draw-rectangle* medium x1 y1 x2 y2 :ink +background-ink+) + (setf (output-record-position new-typeout-record) + (output-record-position (or stream-typeout-record editor-record)) + (output-record-position editor-record) + (values x1 (+ y1 (- (bounding-rectangle-height new-typeout-record) + (if stream-typeout-record + (bounding-rectangle-height stream-typeout-record) + 0))))) + (when erase + (with-bounding-rectangle* (x1 y1 x2 y2) new-typeout-record + (draw-rectangle* medium x1 y1 x2 y2 :ink +background-ink+))) + ;; Reuse the old stream-typeout-record, if any. + (cond (stream-typeout-record + ;; Blank the old one. + (with-bounding-rectangle* (x1 y1 x2 y2) stream-typeout-record + (draw-rectangle* medium x1 y1 (1+ x2) y2 :ink +background-ink+)) + (clear-output-record stream-typeout-record) + (add-output-record new-typeout-record stream-typeout-record)) + (t + (stream-add-output-record encapsulated-stream new-typeout-record) + (setf stream-typeout-record new-typeout-record))) + ;; Now, let there be light! + (replay new-typeout-record encapsulated-stream)))))) (defmacro with-input-editor-typeout ((&optional (stream t) &rest args &key erase) @@ -778,12 +811,12 @@ to an `extended-output-stream' while `body' is being evaluated." (declare (ignore erase)) (check-type stream symbol) - (let ((stream (if (eq stream t) *standard-input* stream))) - `(apply #'invoke-with-input-editor-typeout - ,stream - #'(lambda (,stream) - , at body) - ,args))) + (let ((stream (if (eq stream t) '*standard-output* stream))) + `(invoke-with-input-editor-typeout + ,stream + #'(lambda (,stream) + , at body) + , at args))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From thenriksen at common-lisp.net Thu Jan 31 18:44:37 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 31 Jan 2008 13:44:37 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080131184437.58B404619C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv31269/Drei Modified Files: lisp-syntax.lisp Log Message: Handle some more incomplete lexemes at end-of-buffer in Lisp syntax. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/30 23:24:05 1.72 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/31 18:44:36 1.73 @@ -403,8 +403,9 @@ ((#\O #\o) 8) ((#\X #\x) 16)))) (fo) - (when (char= (object-after scan) - #\-) + (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) From thenriksen at common-lisp.net Thu Jan 31 19:17:57 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 31 Jan 2008 14:17:57 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080131191757.100124C002@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv6356/Drei Modified Files: input-editor.lisp Log Message: Moved some input-editing functions around. The typeout area is now cleared at the end of an input-editing session. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/01/31 16:50:07 1.33 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/01/31 19:17:56 1.34 @@ -756,21 +756,9 @@ ;;; ;;; `With-input-editor-typeout' ;;; -;;; The CLIM spec is very vague about what this function is supposed -;;; to do, but the Franz users guide suggests that it is to be used to -;;; display information to the user while editing, sort of what we -;;; normally use a minibuffer for. Perhaps the output should be put in -;;; an output record above or below the editing area, but for now, we -;;; just put it in the minibuffer. That also means the `:erase' -;;; keyword argument is meaningless. We do add some extra limitations, -;;; though (check the docstring) - -(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.")) -(defmethod invoke-with-input-editor-typeout ((editing-stream drei-input-editing-mixin) - (continuation function) &key erase) +(defmethod climi::invoke-with-input-editor-typeout ((editing-stream drei-input-editing-mixin) + (continuation function) &key erase) (let* ((encapsulated-stream (encapsulating-stream-stream editing-stream)) (new-typeout-record (with-output-to-output-record (encapsulated-stream) (funcall continuation encapsulated-stream))) @@ -801,22 +789,7 @@ (stream-add-output-record encapsulated-stream new-typeout-record) (setf stream-typeout-record new-typeout-record))) ;; Now, let there be light! - (replay new-typeout-record encapsulated-stream)))))) - -(defmacro with-input-editor-typeout ((&optional (stream t) &rest args - &key erase) - &body body) - "`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) - , at body) - , at args))) + (replay stream-typeout-record encapsulated-stream)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From thenriksen at common-lisp.net Thu Jan 31 19:17:57 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 31 Jan 2008 14:17:57 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Goatee Message-ID: <20080131191757.4FC354C002@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Goatee In directory clnet:/tmp/cvs-serv6356/Goatee Modified Files: editing-stream.lisp Log Message: Moved some input-editing functions around. The typeout area is now cleared at the end of an input-editing session. --- /project/mcclim/cvsroot/mcclim/Goatee/editing-stream.lisp 2006/12/01 23:02:59 1.24 +++ /project/mcclim/cvsroot/mcclim/Goatee/editing-stream.lisp 2008/01/31 19:17:57 1.25 @@ -211,6 +211,7 @@ (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))) From thenriksen at common-lisp.net Thu Jan 31 19:17:57 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 31 Jan 2008 14:17:57 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080131191757.C652B4C005@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv6356 Modified Files: input-editing-drei.lisp input-editing.lisp Log Message: Moved some input-editing functions around. The typeout area is now cleared at the end of an input-editing session. --- /project/mcclim/cvsroot/mcclim/input-editing-drei.lisp 2008/01/30 22:29:07 1.10 +++ /project/mcclim/cvsroot/mcclim/input-editing-drei.lisp 2008/01/31 19:17:57 1.11 @@ -100,12 +100,9 @@ (define-condition rescan-condition (condition) ()) -(defgeneric finalize (editing-stream input-sensitizer) - (:documentation "Do any cleanup on an editing stream, like turning off the - cursor, etc.")) - (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))) @@ -124,24 +121,6 @@ (setf (stream-cursor-position real-stream) (values 0 (nth-value 3 (input-editing-stream-bounding-rectangle stream)))))) -(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))) - ;; 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. --- /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/01/30 23:39:19 1.62 +++ /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/01/31 19:17:57 1.63 @@ -2,7 +2,7 @@ ;;; (c) copyright 2001 by ;;; Tim Moore (moore at bricoworks.com) -;;; (c) copyright 2006 by +;;; (c) copyright 2006-2008 by ;;; Troels Henriksen (athas at sigkill.dk) ;;; This library is free software; you can redistribute it and/or @@ -219,18 +219,47 @@ (stream-scan-pointer ,stream-var)))) , at body))) +(defmacro with-input-editor-typeout ((&optional (stream t) &rest args + &key erase) + &body body) + "`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) + , at body) + , at args))) + +(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)))) + (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) - (reset-scan-pointer editing-stream start-scan-pointer) - ;; Input-editing contexts above may be interested... - (signal c) - (return-from rescan nil)))) - (return-from input-editing-rescan-loop - (funcall continuation editing-stream))))))) + (loop (block rescan + (handler-bind ((rescan-condition + #'(lambda (c) + (reset-scan-pointer editing-stream start-scan-pointer) + ;; Input-editing contexts above may be interested... + (signal c) + (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) @@ -254,6 +283,28 @@ (stream-default-view stream)))) (input-editing-rescan-loop stream continuation)) +(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 invoke-with-input-editor-typeout (stream continuation &key erase) + (:documentation "Call `continuation' with a single argument, a +stream to do input-editor-typeout on.")) + (defgeneric input-editing-stream-bounding-rectangle (stream) (:documentation "Return the bounding rectangle of `stream' as four values. This function does not appear in the spec but is