mcclim-cvs

mcclim-cvs@common-lisp.net

1697 discussions

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 07 Jan '08

07 Jan '08

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(a)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.")

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 07 Jan '08

07 Jan '08

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."))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 07 Jan '08

07 Jan '08

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)

1 0

[mcclim-cvs] CVS mcclim/ESA
by thenriksen 07 Jan '08

07 Jan '08

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 '()))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 07 Jan '08

07 Jan '08

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)

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 07 Jan '08

07 Jan '08

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 ,@args)))) - (:options `#'(lambda (syntax parser-symbol) - (declare (ignore syntax parser-symbol)) + (:face `(let ((options (make-drawing-options :face (make-face ,@args)))) + #'(lambda (view parser-symbol) + (declare (ignore view parser-symbol)) + options))) + (:options `#'(lambda (view parser-symbol) + (declare (ignore view parser-symbol)) (make-drawing-options ,@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

1 0

[mcclim-cvs] CVS mcclim/Extensions/Images
by thenriksen 07 Jan '08

07 Jan '08

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))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 07 Jan '08

07 Jan '08

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)

1 0

[mcclim-cvs] CVS mcclim/Extensions/Images
by thenriksen 07 Jan '08

07 Jan '08

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))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 07 Jan '08

07 Jan '08

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

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs