January 2008 - mcclim-cvs@common-lisp.net

[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

[mcclim-cvs] CVS mcclim/Extensions/Images
by dlichteblau 06 Jan '08

06 Jan '08

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

1 0

[mcclim-cvs] CVS mcclim
by dlichteblau 06 Jan '08

06 Jan '08

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 ,@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.

1 0

[mcclim-cvs] CVS mcclim/Extensions
by dlichteblau 06 Jan '08

06 Jan '08

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

1 0

[mcclim-cvs] CVS mcclim/Apps/Listener
by thenriksen 06 Jan '08

06 Jan '08

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

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 06 Jan '08

06 Jan '08

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

1 0

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

06 Jan '08

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

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 06 Jan '08

06 Jan '08

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 ,@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 ,@depends-on)))) + +(support-formats ("gif" :skippy) ("xpm")) + ;;; The actual McCLIM system that people should to use in their ASDF ;;; package dependency lists. (defsystem :mcclim

1 0

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

06 Jan '08

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(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. (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(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. (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 (,@args) ,@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(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. (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(a)rz.uni-karlsruhe.de) ;;; (c) copyright 2006 by ;;; Andy Hefner (ahefner(a)gmail.com) ;;; (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. (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* <variable_name>[] = { ;; | <Values> ;; | <Colors> ;; | <Pixels> ;; | <Extensions> ;; | }; ;; | ;; | The words are separated by a white space which can be composed of ;; | space and tabulation characters. The <Values> 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 <Pixels> section. ;; | ;; | <width> <height> <ncolors> <cpp> [<x_hotspot> <y_hotspot>] [XPMEXT] ;; | ;; | The Colors section contains as many strings as there are colors, and ;; | each string is as follows: ;; | ;; | <chars> {<key> <color>}+ ;; | ;; | Where <chars> is the <chars_per_pixel> length string (not surrounded ;; | by anything) representing the pixels, <color> is the specified color, ;; | and <key> 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 <Pixels> section is composed by <height> strings of <width> * ;; | <chars_per_pixel> characters, where every <chars_per_pixel> length ;; | string must be one of the previously defined groups in the <Colors> ;; | section. ;; | ;; | Then follows the <Extensions> section which must be labeled, if not ;; | empty, in the <Values> section as previously described. This section ;; | may be composed by several <Extension> subsections which may be of two ;; | types: ;; | ;; | . one stand alone string composed as follows: ;; | ;; | XPMEXT <extension-name> <extension-data> ;; | ;; | . or a block composed by several strings: ;; | ;; | XPMEXT <extension-name> ;; | <related extension-data composed of several strings> ;; | ;; | Finally, if not empty, this section must end by the following string: ;; | ;; | XPMENDEXT ;; | ;; | Extensions can be used to store any type of data one might want to ;; | store along with a pixmap, as long as they are properly encoded so ;; | they do not conflict with the general syntax. To avoid possible ;; | conflicts with extension names in shared files, they should be ;; | prefixed by the name of the company. This would ensure uniqueness. ;; | (deftype xpm-data-array () `(simple-array (unsigned-byte 8) 1)) (deftype array-index () #-sbcl '(integer 0 #.array-dimension-limit) #+sbcl 'sb-int:index) (deftype xpm-pixcode () `(unsigned-byte 24)) ; Bogus upper limit for speed.. =/ (defmacro xpm-over-array ((arrayform elt0 idx0 elt1 idx1 start) &body body) (let ((arraysym (gensym)) (lengthsym (gensym))) `(let* ((,arraysym ,arrayform) (,lengthsym (length ,arraysym))) (declare (type xpm-data-array ,arraysym) (optimize (speed 3))) (loop for ,idx0 of-type array-index from ,start below (1- ,lengthsym) as ,idx1 of-type array-index = (1+ ,idx0) as ,elt0 = (aref ,arraysym ,idx0) as ,elt1 = (aref ,arraysym ,idx1) do (progn ,@body))))) (declaim (inline xpm-whitespace-p) (ftype (function ((unsigned-byte 8)) t) xpm-whitespace-p)) (defun xpm-white-space-p (code) (declare (type (unsigned-byte 8) code) (optimize (speed 3))) (or (= code 32) ; #\Space (= code 9) ; #\Tab (= code 10))) ; #\Newline (defun xpm-token-terminator-p (code) (declare (type (unsigned-byte 8) code)) (or (xpm-white-space-p code) (= code 34))) ; #\" (defun xpm-token-bounds (data start) (xpm-over-array (data b0 start b1 i1 start) (when (not (xpm-white-space-p b0)) (xpm-over-array (data b0 end b1 i1 start) (when (xpm-token-terminator-p b0) (return-from xpm-token-bounds (values start end)))) (error "Unbounded token"))) (error "Missing token")) (defun xpm-extract-color-token (data start end) (declare (type xpm-data-array data) (type array-index start end) (optimize (speed 3))) (let ((x 0)) (declare (type xpm-pixcode x)) ; Bah, this didn't help. (loop for i from start below end do (setf x (+ (ash x 8) (elt data i)))) x)) (defun xpm-parse-color (data cpp index) (declare (type xpm-data-array data) (type (integer 1 4) cpp) ; ??? =p (type array-index index) (optimize (speed 3) (safety 0))) (let* ((color-token-end (the array-index (+ index cpp))) (code (xpm-extract-color-token data index color-token-end)) (string-end (1- (xpm-exit-string data color-token-end))) (color (xpm-parse-color-spec data color-token-end string-end))) (declare (type array-index color-token-end string-end) (type xpm-pixcode code)) (unless color (error "Color ~S does not parse." (map 'string #'code-char (subseq data color-token-end string-end)))) (values code color (1+ string-end)))) (declaim (inline xpm-key-p)) (defun xpm-key-p (x) (or (= x 109) (= x 115) (= x 103) (= x 99))) (defun xpm-parse-color-spec (data start end) ;; Gilbert says: ;; > Lossage! ;; > There exist files which say e.g. "c light yellow". ;; > How am I supposed to parse that? ;; > ;; > It seems that the C code just parse everything until one of keys. ;; > That is we do the same although it is quite stupid. ;(declare (optimize (debug 3) (safety 3))) (declare (optimize (speed 3) (space 0) (safety 0)) (type xpm-data-array data) (type array-index start end)) (let ((original-start start) key last-was-key color-token-start color-token-end) (declare (type (or null array-index) color-token-start color-token-end) (type (or null (unsigned-byte 8)) key)) (flet ((find-token (start end) (let* ((p1 (position-if-not #'xpm-white-space-p data :start start :end end)) (p2 (and p1 (or (position-if #'xpm-white-space-p data :start p1 :end end) end)))) (values p1 p2))) (quux (key color-token-start color-token-end) (let ((ink (xpm-parse-single-color key data color-token-start color-token-end))) (when ink (return-from xpm-parse-color-spec ink)))) (stringize () (map 'string #'code-char (subseq data original-start end)))) (loop (multiple-value-bind (p1 p2) (find-token start end) (unless p1 (when last-was-key (error "Premature end of color line (no color present after key): ~S." (stringize))) [951 lines skipped]

1 0

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

06 Jan '08

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

1 0

[mcclim-cvs] CVS mcclim/Backends/CLX
by ahefner 06 Jan '08

06 Jan '08

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

1 0

[mcclim-cvs] CVS mcclim/Experimental/freetype
by ahefner 06 Jan '08

06 Jan '08

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.

1 0

[mcclim-cvs] CVS mcclim/Apps/Listener
by ahefner 06 Jan '08

06 Jan '08

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)

1 0

[mcclim-cvs] CVS mcclim/Experimental/freetype
by ahefner 06 Jan '08

06 Jan '08

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

1 0

[mcclim-cvs] CVS mcclim/Experimental/freetype
by ahefner 05 Jan '08

05 Jan '08

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]

1 0

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

05 Jan '08

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

1 0

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

05 Jan '08

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

1 0

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

05 Jan '08

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

1 0

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

05 Jan '08

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

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs January 2008