- mcclim-cvs@common-lisp.net - mailman3.common-lisp.net

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

17 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv28700/Drei Modified Files: core-commands.lisp drei.lisp input-editor.lisp lisp-syntax-commands.lisp modes.lisp packages.lisp search-commands.lisp targets.lisp Log Message: Changed *drei-instance* to be a function (drei-instance). Change of active window in Climacs will work better now. --- /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2007/12/27 13:39:25 1.12 +++ /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2008/01/17 11:29:55 1.13 @@ -39,7 +39,7 @@ will replace the object after the point. When overwrite is off (the default), objects are inserted at point. In both cases point is positioned after the new object." - (with-slots (overwrite-mode) *drei-instance* + (with-slots (overwrite-mode) (current-view) (setf overwrite-mode (not overwrite-mode)))) (set-key 'com-overwrite-mode @@ -212,13 +212,13 @@ "Replace runs of spaces with tabs in region where possible. Uses TAB-SPACE-COUNT of the STREAM-DEFAULT-VIEW of the pane." (tabify-region (mark) (point) - (tab-space-count (view *drei-instance*)))) + (tab-space-count (current-view)))) (define-command (com-untabify-region :name t :command-table editing-table) () "Replace tabs with equivalent runs of spaces in the region. Uses TAB-SPACE-COUNT of the STREAM-DEFAULT-VIEW of the pane." (untabify-region (mark) (point) - (tab-space-count (view *drei-instance*)))) + (tab-space-count (current-view)))) (define-command (com-indent-line :name t :command-table indent-table) () (indent-current-line (current-view) (point))) @@ -531,7 +531,7 @@ inserting each in turn at point as an expansion." (with-accessors ((original-prefix original-prefix) (prefix-start-offset prefix-start-offset) - (dabbrev-expansion-mark dabbrev-expansion-mark)) *drei-instance* + (dabbrev-expansion-mark dabbrev-expansion-mark)) (current-view) (flet ((move () (cond ((beginning-of-buffer-p dabbrev-expansion-mark) (setf (offset dabbrev-expansion-mark) (offset (point))) @@ -620,8 +620,8 @@ (define-command (com-visible-region :name t :command-table marking-table) () "Toggle the visibility of the region in the current pane." - (setf (region-visible-p *drei-instance*) - (not (region-visible-p *drei-instance*)))) + (setf (region-visible-p (current-view)) + (not (region-visible-p (current-view))))) (define-command (com-move-past-close-and-reindent :name t :command-table editing-table) () --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/16 21:30:04 1.27 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/17 11:29:55 1.28 @@ -63,16 +63,26 @@ ;;; ;;; Convenience stuff. -(defvar *drei-instance* nil - "The currently running Drei instance.") +(defgeneric drei-instance-of (object) + (:documentation "Return the Drei instance of `object'. For an +editor frame, this would be the active editor instance. If +`object' itself is a Drei instance, this function should just +return `object'.")) + +(defun drei-instance (&optional (object *esa-instance*)) + "Return the currently running Drei instance. This function +calls `drei-instance-of' on its argument." + (drei-instance-of object)) -(defun current-view (&optional (object *drei-instance*)) +(defun (setf drei-instance) (new-instance &optional (object *esa-instance*)) + (setf (drei-instance-of object) new-instance)) + +(defun current-view (&optional (object (drei-instance))) "Return the view of the provided object. If no object is -provided, the currently running Drei instance (`*drei-instance*') -will be used." +provided, the currently running Drei instance will be used." (view object)) -(defun (setf current-view) (new-view &optional (object *drei-instance*)) +(defun (setf current-view) (new-view &optional (object (drei-instance))) (setf (view object) new-view)) (defun point (&optional (object (current-view))) @@ -183,14 +193,14 @@ "Prompt for a command name and arguments, then run it." (let ((item (handler-case (accept - `(command :command-table ,(command-table *drei-instance*)) + `(command :command-table ,(command-table (drei-instance))) ;; this gets erased immediately anyway :prompt "" :prompt-mode :raw) ((or command-not-accessible command-not-present) () (beep) (display-message "No such command") (return-from com-drei-extended-command nil))))) - (execute-drei-command *drei-instance* item))) + (execute-drei-command (drei-instance) item))) (set-key 'com-drei-extended-command 'exclusive-gadget-table @@ -207,11 +217,11 @@ "This method allows users of Drei to extend syntaxes with new, app-specific commands, as long as they inherit from a Drei class and specialise a method for it." - (additional-command-tables *drei-instance* command-table)) + (additional-command-tables (drei-instance) command-table)) (defmethod command-table-inherit-from ((table drei-command-table)) (append (view-command-tables (current-view)) - (additional-command-tables *drei-instance* table) + (additional-command-tables (drei-instance) table) (when (use-editor-commands-p (current-view)) '(editor-table)))) @@ -343,6 +353,9 @@ (defmethod esa-current-window ((drei drei)) drei) +(defmethod drei-instance-of ((object drei)) + object) + (defmethod print-object ((object drei) stream) (print-unreadable-object (object stream :type t :identity t) (format stream "~A" (type-of (view object))))) @@ -404,21 +417,21 @@ ;; at, for example, the buffer level, after all. `(handler-case (progn ,@body) (user-condition-mixin (c) - (handle-drei-condition *drei-instance* c)) + (handle-drei-condition (drei-instance) c)) (offset-before-beginning (c) - (handle-drei-condition *drei-instance* c)) + (handle-drei-condition (drei-instance) c)) (offset-after-end (c) - (handle-drei-condition *drei-instance* c)) + (handle-drei-condition (drei-instance) c)) (motion-before-beginning (c) - (handle-drei-condition *drei-instance* c)) + (handle-drei-condition (drei-instance) c)) (motion-after-end (c) - (handle-drei-condition *drei-instance* c)) + (handle-drei-condition (drei-instance) c)) (no-expression (c) - (handle-drei-condition *drei-instance* c)) + (handle-drei-condition (drei-instance) c)) (no-such-operation (c) - (handle-drei-condition *drei-instance* c)) + (handle-drei-condition (drei-instance) c)) (buffer-read-only (c) - (handle-drei-condition *drei-instance* c)))) + (handle-drei-condition (drei-instance) c)))) (defmacro with-bound-drei-special-variables ((drei-instance &key (kill-ring nil kill-ring-p) @@ -429,7 +442,7 @@ (prompt nil prompt-p)) &body body) "Evaluate `body' with a set of Drei special -variables (`*drei-instance*', `*kill-ring*', `*minibuffer*', +variables (`(drei-instance)', `*kill-ring*', `*minibuffer*', `*command-parser*', `*partial-command-parser*', `*previous-command*', `*extended-command-prompt*') bound to their proper values, taken from `drei-instance'. The keyword arguments @@ -438,18 +451,17 @@ value in `drei-instance'. This macro binds all of the usual Drei special variables, but also some CLIM special variables needed for ESA-style command parsing." - `(let* ((*drei-instance* ,drei-instance) - (*esa-instance* *drei-instance*) + `(let* ((*esa-instance* ,drei-instance) (*kill-ring* ,(if kill-ring-p kill-ring - `(kill-ring *drei-instance*))) + `(kill-ring (drei-instance)))) (*minibuffer* ,(if minibuffer-p minibuffer - `(or (minibuffer *drei-instance*) *minibuffer*))) + `(or (minibuffer (drei-instance)) *minibuffer*))) (*command-parser* ,(if command-parser-p command-parser ''esa-command-parser)) (*partial-command-parser* ,(if partial-command-parser-p partial-command-parser ''esa-partial-command-parser)) (*previous-command* ,(if previous-command-p previous-command - `(previous-command *drei-instance*))) + `(previous-command (drei-instance)))) (*extended-command-prompt* ,(if prompt-p prompt "Extended command: "))) ,@body)) --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2007/12/13 07:57:15 1.21 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/01/17 11:29:55 1.22 @@ -33,7 +33,7 @@ ;; `drei-input-editing-mixin' class does not have a scan pointer. We ;; assume that the subclass defines a scan pointer. (defclass drei-input-editing-mixin () - ((%drei-instance :accessor drei-instance + ((%drei-instance :accessor drei-instance-of :initarg :drei-instance) (%input-position :accessor input-position :initform 0) --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2008/01/14 09:14:48 1.15 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2008/01/17 11:29:55 1.16 @@ -65,7 +65,7 @@ #'(lambda (mark) (proper-line-indentation (current-view) mark)) fill-column - (tab-space-count (view *drei-instance*)) + (tab-space-count (current-view)) (current-syntax) t))))) --- /project/mcclim/cvsroot/mcclim/Drei/modes.lisp 2007/12/28 10:08:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/modes.lisp 2008/01/17 11:29:55 1.2 @@ -137,6 +137,6 @@ `(define-command (,command-name :name ,name :command-table ,command-table) () ,(concatenate 'string "Toggle " string-form " mode.") - (if (mode-enabled-p *drei-instance* ',mode-name) - (disable-mode *drei-instance* ',mode-name) - (enable-mode *drei-instance* ',mode-name)))) + (if (mode-enabled-p (drei-instance) ',mode-name) + (disable-mode (drei-instance) ',mode-name) + (enable-mode (drei-instance) ',mode-name)))) --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/13 22:22:05 1.41 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/17 11:29:55 1.42 @@ -302,9 +302,7 @@ #:mark #:mark-of #:current-syntax #:current-view - - ;; Info variables. - #:*drei-instance* + #:drei-instance #:drei-instance-of ;; Configuration. #:*foreground-color* --- /project/mcclim/cvsroot/mcclim/Drei/search-commands.lisp 2007/12/08 08:53:49 1.5 +++ /project/mcclim/cvsroot/mcclim/Drei/search-commands.lisp 2008/01/17 11:29:55 1.6 @@ -61,7 +61,7 @@ ((string 'string :prompt "String Search")) "Prompt for a string and search forward for it. If found, leaves point after string. If not, leaves point where it is." - (simple-search-forward *drei-instance* + (simple-search-forward (drei-instance) #'(lambda (mark) (search-forward mark string :test (case-relevant-test string))))) @@ -70,7 +70,7 @@ ((string 'string :prompt "Reverse String Search")) "Prompt for a string and search backward for it. If found, leaves point before string. If not, leaves point where it is." - (simple-search-backward *drei-instance* + (simple-search-backward (drei-instance) #'(lambda (mark) (search-backward mark string :test (case-relevant-test string))))) @@ -83,7 +83,7 @@ ((word 'string :prompt "Search word")) "Prompt for a whitespace delimited word and search forward for it. If found, leaves point after the word. If not, leaves point where it is." - (simple-search-forward *drei-instance* + (simple-search-forward (drei-instance) #'(lambda (mark) (search-word-forward mark word)))) @@ -91,7 +91,7 @@ ((word 'string :prompt "Search word")) "Prompt for a whitespace delimited word and search backward for it. If found, leaves point before the word. If not, leaves point where it is." - (simple-search-backward *drei-instance* + (simple-search-backward (drei-instance) #'(lambda (mark) (search-backward mark word)))) @@ -166,7 +166,7 @@ (define-command (com-isearch-forward :name t :command-table search-table) () (display-message "Isearch: ") - (isearch-command-loop *drei-instance* t)) + (isearch-command-loop (drei-instance) t)) (set-key 'com-isearch-forward 'search-table @@ -174,14 +174,14 @@ (define-command (com-isearch-backward :name t :command-table search-table) () (display-message "Isearch backward: ") - (isearch-command-loop *drei-instance* nil)) + (isearch-command-loop (drei-instance) nil)) (set-key 'com-isearch-backward 'search-table '((#\r :control))) (defun isearch-append-char (char) - (let* ((states (isearch-states *drei-instance*)) + (let* ((states (isearch-states (drei-instance))) (string (concatenate 'string (search-string (first states)) (string char))) @@ -189,7 +189,7 @@ (forwardp (search-forward-p (first states)))) (unless (or forwardp (end-of-buffer-p mark)) (incf (offset mark))) - (isearch-from-mark *drei-instance* mark string forwardp))) + (isearch-from-mark (drei-instance) mark string forwardp))) (define-command (com-isearch-append-char :name t :command-table isearch-drei-table) () (isearch-append-char *current-gesture*)) @@ -198,7 +198,7 @@ (isearch-append-char #\Newline)) (defun isearch-append-text (movement-function) - (let* ((states (isearch-states *drei-instance*)) + (let* ((states (isearch-states (drei-instance))) (start (clone-mark (point))) (mark (clone-mark (search-mark (first states)))) (forwardp (search-forward-p (first states)))) @@ -212,7 +212,7 @@ point-offset)))) (unless (or forwardp (end-of-buffer-p mark)) (incf (offset mark) (- point-offset start-offset))) - (isearch-from-mark *drei-instance* mark string forwardp)))) + (isearch-from-mark (drei-instance) mark string forwardp)))) (define-command (com-isearch-append-word :name t :command-table isearch-drei-table) () (isearch-append-text #'(lambda (mark) (forward-word mark (current-syntax))))) @@ -221,7 +221,7 @@ (isearch-append-text #'end-of-line)) (define-command (com-isearch-append-kill :name t :command-table isearch-drei-table) () - (let* ((states (isearch-states *drei-instance*)) + (let* ((states (isearch-states (drei-instance))) (yank (handler-case (kill-ring-yank *kill-ring*) (empty-kill-ring () ""))) @@ -232,19 +232,19 @@ (forwardp (search-forward-p (first states)))) (unless (or forwardp (end-of-buffer-p mark)) (incf (offset mark) (length yank))) - (isearch-from-mark *drei-instance* mark string forwardp))) + (isearch-from-mark (drei-instance) mark string forwardp))) (define-command (com-isearch-delete-char :name t :command-table isearch-drei-table) () - (cond ((null (second (isearch-states *drei-instance*))) + (cond ((null (second (isearch-states (drei-instance)))) (display-message "Isearch: ") (beep)) (t - (pop (isearch-states *drei-instance*)) - (loop until (endp (rest (isearch-states *drei-instance*))) - until (search-success-p (first (isearch-states *drei-instance*))) - do (pop (isearch-states *drei-instance*))) - (let ((state (first (isearch-states *drei-instance*)))) - (setf (offset (point *drei-instance*)) + (pop (isearch-states (drei-instance))) + (loop until (endp (rest (isearch-states (drei-instance)))) + until (search-success-p (first (isearch-states (drei-instance)))) + do (pop (isearch-states (drei-instance)))) + (let ((state (first (isearch-states (drei-instance))))) + (setf (offset (point (drei-instance))) (if (search-forward-p state) (+ (offset (search-mark state)) (length (search-string state))) @@ -255,26 +255,26 @@ (display-string (search-string state))))))) (define-command (com-isearch-search-forward :name t :command-table isearch-drei-table) () - (let* ((states (isearch-states *drei-instance*)) + (let* ((states (isearch-states (drei-instance))) (string (if (null (second states)) - (isearch-previous-string *drei-instance*) + (isearch-previous-string (drei-instance)) (search-string (first states)))) (mark (clone-mark (point)))) - (isearch-from-mark *drei-instance* mark string t))) + (isearch-from-mark (drei-instance) mark string t))) (define-command (com-isearch-search-backward :name t :command-table isearch-drei-table) () - (let* ((states (isearch-states *drei-instance*)) + (let* ((states (isearch-states (drei-instance))) (string (if (null (second states)) - (isearch-previous-string *drei-instance*) + (isearch-previous-string (drei-instance)) (search-string (first states)))) (mark (clone-mark (point)))) - (isearch-from-mark *drei-instance* mark string nil))) + (isearch-from-mark (drei-instance) mark string nil))) (define-command (com-isearch-exit :name t :command-table isearch-drei-table) () - (let* ((states (isearch-states *drei-instance*)) + (let* ((states (isearch-states (drei-instance))) (string (search-string (first states))) (search-forward-p (search-forward-p (first states)))) - (setf (isearch-mode *drei-instance*) nil) + (setf (isearch-mode (drei-instance)) nil) (when (string= string "") (execute-frame-command *application-frame* (funcall @@ -343,7 +343,7 @@ t)))) (define-command (com-query-replace :name t :command-table search-table) () - (let* ((drei *drei-instance*) + (let* ((drei (drei-instance)) (old-state (query-replace-state drei)) (old-string1 (when old-state (string1 old-state))) (old-string2 (when old-state (string2 old-state))) @@ -394,7 +394,7 @@ '((#\% :shift :meta))) (define-command (com-query-replace-replace :name t :command-table query-replace-drei-table) () - (let ((state (query-replace-state *drei-instance*))) + (let ((state (query-replace-state (drei-instance)))) (with-accessors ((string1 string1) (string2 string2) (occurrences occurrences) @@ -410,13 +410,13 @@ (if (query-replace-find-next-match state) (display-message "Replace ~A with ~A:" string1 string2) - (setf (query-replace-mode *drei-instance*) nil)))))) + (setf (query-replace-mode (drei-instance)) nil)))))) (define-command (com-query-replace-replace-and-quit :name t :command-table query-replace-drei-table) () - (let ((state (query-replace-state *drei-instance*))) + (let ((state (query-replace-state (drei-instance)))) (with-accessors ((string1 string1) (string2 string2) (occurrences occurrences) @@ -429,13 +429,13 @@ string2 (no-upper-p string1)) (incf occurrences) - (setf (query-replace-mode *drei-instance*) nil))))) + (setf (query-replace-mode (drei-instance)) nil))))) (define-command (com-query-replace-replace-all :name t :command-table query-replace-drei-table) () - (let ((state (query-replace-state *drei-instance*))) + (let ((state (query-replace-state (drei-instance)))) (with-accessors ((string1 string1) (string2 string2) (occurrences occurrences) @@ -449,19 +449,19 @@ (no-upper-p string1)) (incf occurrences) while (query-replace-find-next-match state) - finally (setf (query-replace-mode *drei-instance*) nil)))))) + finally (setf (query-replace-mode (drei-instance)) nil)))))) (define-command (com-query-replace-skip :name t :command-table query-replace-drei-table) () - (let ((state (query-replace-state *drei-instance*))) + (let ((state (query-replace-state (drei-instance)))) (with-accessors ((string1 string1) (string2 string2)) state (if (query-replace-find-next-match state) (display-message "Replace ~A with ~A:" string1 string2) - (setf (query-replace-mode *drei-instance*) nil))))) + (setf (query-replace-mode (drei-instance)) nil))))) (define-command (com-query-replace-exit :name t :command-table query-replace-drei-table) () - (setf (query-replace-mode *drei-instance*) nil)) + (setf (query-replace-mode (drei-instance)) nil)) (defun query-replace-set-key (gesture command) (add-command-to-command-table command 'query-replace-drei-table @@ -497,7 +497,7 @@ :delimiter-gestures nil :activation-gestures '(:newline :return)))) - (simple-search-forward *drei-instance* + (simple-search-forward (drei-instance) #'(lambda (mark) (re-search-forward mark (normalise-minibuffer-regex string)))))) @@ -506,7 +506,7 @@ :delimiter-gestures nil :activation-gestures '(:newline :return)))) - (simple-search-backward *drei-instance* + (simple-search-backward (drei-instance) #'(lambda (mark) (re-search-backward mark (normalise-minibuffer-regex string)))))) --- /project/mcclim/cvsroot/mcclim/Drei/targets.lisp 2007/12/08 08:53:49 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/targets.lisp 2008/01/17 11:29:55 1.3 @@ -27,7 +27,7 @@ (in-package :drei-core) (defclass target-specification () - ((%drei :reader drei-instance + ((%drei :reader drei-instance-of :initarg :drei-instance :initform (error "A Drei instance must be provided for a target specification"))) (:documentation "The base class for target specifications,

1 0

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

17 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv10002 Modified Files: freetype-fonts.lisp Log Message: Simple implementation of ttf device fonts by their proper name (as opposed to filename), using fc-match. 'make-fontconfig-font-name' creates such a font name, given a name, size, and list of options in the syntax of fontconfig. --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/17 07:57:55 1.19 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/17 09:54:21 1.20 @@ -411,15 +411,38 @@ (defstruct freetype-device-font-name (font-file (error "missing argument")) - (size (error "missing argument"))) + (size (error "missing argument"))) -(defmethod clim-clx::text-style-to-X-font :around +(defstruct fontconfig-font-name + (string (error "missing argument")) + (size (error "missing argument")) + (options nil) + (device-name nil)) + +(defmethod clim-clx::text-style-to-X-font :around ((port clim-clx::clx-port) (text-style climi::device-font-text-style)) (let ((display (slot-value port 'clim-clx::display)) (font-name (climi::device-font-name text-style))) - (make-free-type-face display - (freetype-device-font-name-font-file font-name) - (freetype-device-font-name-size font-name)))) + (typecase font-name + (freetype-device-font-name + (make-free-type-face display + (namestring (freetype-device-font-name-font-file font-name)) + (freetype-device-font-name-size font-name))) + (fontconfig-font-name + (clim-clx::text-style-to-X-font + port + (or (fontconfig-font-name-device-name font-name) + (setf (fontconfig-font-name-device-name font-name) + (make-device-font-text-style + port + (make-freetype-device-font-name + :font-file (find-bitstream-font + (format nil "~A-~A~{:~A~}" + (namestring (fontconfig-font-name-string font-name)) + (fontconfig-font-name-size font-name) + (fontconfig-font-name-options font-name))) + :size (fontconfig-font-name-size font-name)))))))))) + (defmethod text-style-mapping :around ((port clim-clx::clx-port) (text-style climi::device-font-text-style)

1 0

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

17 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv14215 Modified Files: freetype-fonts.lisp mcclim-freetype.asd Added Files: fontconfig.lisp Log Message: Now that everything is working fairly reliably, break it all by changing how the font path is configured. Call fc-match for each possible family/face combination, and build the map from that, allowing fontconfig to do what it is designed for. In this way, systems using DejaVu instead of Vera work automatically, and changing the default font choices require just changing one font name rather than four filenames. Via the magic of merge-pathnames, the old approach of a relative mapping and *freetype-font-path* still works. --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/15 09:06:52 1.18 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/17 07:57:55 1.19 @@ -6,6 +6,7 @@ ;;; License: LGPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2003 by Gilbert Baumann +;;; (c) copyright 2008 by Andy Hefner ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -177,7 +178,6 @@ (glyph-info glyph-id dx dy left right top))))) ;;;;;;; mcclim interface - (defclass freetype-face () ((display :initarg :display :reader freetype-face-display) (font :initarg :font :reader freetype-face-name) @@ -367,7 +367,7 @@ :very-large 18 :huge 24)) -(defparameter *families/faces* +(defparameter *vera-families/faces* '(((:fix :roman) . "VeraMono.ttf") ((:fix :italic) . "VeraMoIt.ttf") ((:fix (:bold :italic)) . "VeraMoBI.ttf") @@ -386,8 +386,7 @@ ;;; Here are alternate mappings for the DejaVu family of fonts, which ;;; are a derivative of Vera with improved unicode coverage. -#+NIL -(defparameter *families/faces* +(defparameter *dejavu-families/faces* '(((:FIX :ROMAN) . "DejaVuSansMono.ttf") ((:FIX :ITALIC) . "DejaVuSansMono-Oblique.ttf") ((:FIX (:BOLD :ITALIC)) . "DejaVuSansMono-BoldOblique.ttf") @@ -404,8 +403,9 @@ ((:SANS-SERIF (:ITALIC :BOLD)) . "DejaVuSans-BoldOblique.ttf") ((:SANS-SERIF :BOLD) . "DejaVuSans-Bold.ttf"))) +(defvar *families/faces* *vera-families/faces*) -(defvar *freetype-font-path*) +(defparameter *freetype-font-path* #p"/usr/share/fonts/truetype/ttf-dejavu/") (fmakunbound 'clim-clx::text-style-to-x-font) --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/mcclim-freetype.asd 2008/01/01 18:44:39 1.8 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/mcclim-freetype.asd 2008/01/17 07:57:55 1.9 @@ -34,46 +34,15 @@ #+sbcl ((:file "freetype-package") (:uncompiled-cl-source-file "freetype-ffi") - (:file "freetype-fonts")) + (:file "freetype-fonts") + (:file "fontconfig")) #-sbcl ((:file "freetype-package-cffi") (:uncompiled-cl-source-file "freetype-cffi") (:file "freetype-fonts-cffi"))) -;;; Freetype autodetection - -(defun parse-fontconfig-output (s) - (let* ((match-string (concatenate 'string (string #\Tab) "file:")) - (matching-line - (loop for l = (read-line s nil nil) - while l - if (= (mismatch l match-string) (length match-string)) - do (return l))) - (filename (when matching-line - (probe-file - (subseq matching-line - (1+ (position #\" matching-line :from-end nil :test #'char=)) - (position #\" matching-line :from-end t :test #'char=)))))) - (when filename - (make-pathname :directory (pathname-directory filename))))) - -(defun warn-about-unset-font-path () - (warn "~%~%NOTE:~%~ -* Remember to set mcclim-freetype:*freetype-font-path* to the - location of the Bitstream Vera family of fonts on disk. If you - don't have them, get them from http://www.gnome.org/fonts/~%~%~%")) - (defmethod perform :after ((o load-op) (s (eql (asdf:find-system :mcclim-freetype)))) - (unless - (setf (symbol-value (intern "*FREETYPE-FONT-PATH*" :mcclim-freetype)) - (find-bitstream-fonts)) - (warn-about-unset-font-path))) + "Detect fonts using fc-match" + (funcall (find-symbol (symbol-name '#:autoconfigure-fonts) :mcclim-freetype))) -(defun find-bitstream-fonts () - (with-input-from-string - (s (with-output-to-string (asdf::*verbose-out*) - (let ((code (asdf:run-shell-command "fc-match -v Bitstream Vera"))) - (unless (zerop code) - (warn "~&fc-match failed with code ~D.~%" code))))) - (parse-fontconfig-output s))) --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/fontconfig.lisp 2008/01/17 07:57:55 NONE +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/fontconfig.lisp 2008/01/17 07:57:55 1.1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: MCCLIM-FREETYPE; -*- ;;; --------------------------------------------------------------------------- ;;; Title: Experimental FreeType support ;;; Created: 2003-05-25 16:32 ;;; Author: Gilbert Baumann <unk6(a)rz.uni-karlsruhe.de> ;;; License: LGPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2008 by Andy Hefner ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :MCCLIM-FREETYPE) (defparameter *family-names* '((:serif . "Serif") (:sans-serif . "Sans") (:fix . "Mono"))) (defparameter *fontconfig-faces* '((:roman . "") (:bold . "bold") (:italic . "oblique") ((:bold :italic) . "bold:oblique"))) (defun parse-fontconfig-output (s) (let* ((match-string (concatenate 'string (string #\Tab) "file:")) (matching-line (loop for l = (read-line s nil nil) while l if (= (mismatch l match-string) (length match-string)) do (return l))) (filename (when matching-line (probe-file (subseq matching-line (1+ (position #\" matching-line :from-end nil :test #'char=)) (position #\" matching-line :from-end t :test #'char=)))))) (when filename (parse-namestring filename)))) (defun warn-about-unset-font-path () (cerror "Proceed" "~%~%NOTE:~%~ * McCLIM was unable to configure itself automatically using fontconfig. Therefore you must configure it manually. Remember to set mcclim-freetype:*freetype-font-path* to the location of the Bitstream Vera family of fonts on disk. If you don't have them, get them from http://www.gnome.org/fonts/~%")) (defun find-bitstream-font (font-fc-name) (with-input-from-string (s (with-output-to-string (asdf::*verbose-out*) (let ((code (asdf:run-shell-command "fc-match -v \"~A\"" font-fc-name))) (unless (zerop code) (warn "~&fc-match failed with code ~D.~%" code))))) (parse-fontconfig-output s))) (defun fontconfig-name (family face) (format nil "~A:~A" family face)) (defun build-font/family-map (&optional (families *family-names*)) (loop for family in families nconcing (loop for face in *fontconfig-faces* as filename = (find-bitstream-font (fontconfig-name (cdr family) (cdr face))) when (null filename) do (return-from build-font/family-map nil) collect (cons (list (car family) (car face)) filename)))) (defun autoconfigure-fonts () (let ((map (build-font/family-map))) (if map (setf *families/faces* map) (warn-about-unset-font-path))))

1 0

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

17 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv12535 Modified Files: medium.lisp Log Message: Precompile indexed -> RGBA converter function for the most common pixel formats (that is, the ones my computers use), to avoid the delay while they're compiled the first time draw-pattern* is called. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2008/01/11 05:55:52 1.84 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2008/01/17 07:23:48 1.85 @@ -321,7 +321,7 @@ (:msbfirst #'identity)) (loop for i from 0 below num-bytes collect i))))) -(defun generate-indexed-converter-expr (rgb-masks num-bytes byte-order) +(defun generate-indexed-converter-expr (rgb-masks byte-order num-bytes) `(lambda (image-array converted-data mask-data width height inks) (declare (optimize (speed 3) (safety 0) @@ -409,13 +409,27 @@ (defparameter *pixel-converter-cache* (make-hash-table :test 'equal)) -(defun get-indexed-converter (visual-info byte-order bytes-per-pixel) - (let* ((rgb-masks (list (xlib:visual-info-red-mask visual-info) - (xlib:visual-info-green-mask visual-info) - (xlib:visual-info-blue-mask visual-info))) - (key (list rgb-masks byte-order bytes-per-pixel))) +(defun ensure-indexed-converter (rgb-masks byte-order bytes-per-pixel) + (let ((key (list rgb-masks byte-order bytes-per-pixel))) (symbol-macrolet ((fn (gethash key *pixel-converter-cache*))) - (or fn (setf fn (compile nil (generate-indexed-converter-expr rgb-masks bytes-per-pixel byte-order))))))) + (or fn (setf fn (compile nil (generate-indexed-converter-expr rgb-masks byte-order bytes-per-pixel))))))) + +(defun visual-get-indexed-converter (visual-info byte-order bytes-per-pixel) + (let ((rgb-masks (list (xlib:visual-info-red-mask visual-info) + (xlib:visual-info-green-mask visual-info) + (xlib:visual-info-blue-mask visual-info)))) + (ensure-indexed-converter rgb-masks byte-order bytes-per-pixel))) + +(defparameter *typical-pixel-formats* + '(((#xFF0000 #xFF00 #xFF) :LSBFIRST 4) + ((#xFF0000 #xFF00 #xFF) :MSBFIRST 4)) + "This is a table of the most likely pixel formats. Converters for +these should be compiled in advance. Compiling the indexed->rgba +converter in advance will eliminate the pause observable the first +time an indexed pattern is drawn.") + +(dolist (format *typical-pixel-formats*) + (apply 'ensure-indexed-converter format)) (defun fill-pixmap-indexed (visual-info depth byte-order array pm pm-gc mask mask-gc w h inks) (assert (= (array-total-size array) (* w h))) @@ -432,7 +446,8 @@ (if (and bytes-per-pixel (member byte-order '(:lsbfirst :msbfirst)) - (setf pixel-converter (get-indexed-converter visual-info byte-order bytes-per-pixel))) + (setf pixel-converter (visual-get-indexed-converter + visual-info byte-order bytes-per-pixel))) ;; Fast path - Image upload (let ((converted-data (make-array (* bytes-per-pixel (array-total-size array)) :element-type 'xlib:card8))) ;; Fill the pixel arrays

1 0

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

17 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv10674 Modified Files: port.lisp Log Message: Add a restart around the magic clx server path generator to use the local display. Somewhat redundant, but the restart provided by assert is not the friendliest interface, and what value it wants is not 100% obvious. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2008/01/14 04:53:11 1.131 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2008/01/17 07:11:15 1.132 @@ -167,7 +167,7 @@ (selection-timestamp :initform nil :accessor selection-timestamp) (font-families :accessor font-families))) -(defun automagic-clx-server-path () +(defun automagic-clx-server-path () (let ((name (get-environment-variable "DISPLAY"))) (assert name (name) "Environment variable DISPLAY is not set") @@ -198,6 +198,12 @@ :screen-id (or screen 0) :protocol protocol)))) +(defun helpfully-automagic-clx-server-path () + (restart-case (automagic-clx-server-path) + (use-localhost () + :report "Use local unix display" + (parse-clx-server-path '(:clx :host "" :protocol :unix))))) + (defun parse-clx-server-path (path) (pop path) (if path @@ -206,7 +212,7 @@ :display-id (getf path :display-id 0) :screen-id (getf path :screen-id 0) :protocol (getf path :protocol :internet)) - (automagic-clx-server-path))) + (helpfully-automagic-clx-server-path))) (setf (get :x11 :port-type) 'clx-port) (setf (get :x11 :server-path-parser) 'parse-clx-server-path)

1 0

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

16 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv12491/Drei Modified Files: drei-clim.lisp Log Message: Accept all numbers, not just integers. McCLIM is very happy about fractional pixels, after all. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/16 17:11:52 1.30 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/16 22:50:06 1.31 @@ -345,8 +345,8 @@ (defmethod initialize-instance :after ((area drei-area) &key x-position y-position) - (check-type x-position integer) - (check-type y-position integer) + (check-type x-position number) + (check-type y-position number) (setf (input-editor-position area) (list x-position y-position) (extend-pane-bottom (view area)) t) (tree-recompute-extent area))

1 0

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

16 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv10409/Drei Modified Files: drei-redisplay.lisp Log Message: Clean and fix some more Drei input-editor related redisplay stuff. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/16 18:32:33 1.40 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/16 22:40:14 1.41 @@ -954,7 +954,12 @@ (descent (text-style-descent style pane)) (height (+ ascent descent))) (multiple-value-bind (x1 y1 x2 y2) - (call-next-method) + (drei-bounding-rectangle* drei) + (when (= x1 y1 x2 y2 0) + ;; It hasn't been displayed yet, so stuff the position into + ;; it... + (setf x1 (first (input-editor-position drei)) + y1 (second (input-editor-position drei)))) (values x1 y1 (max x2 (+ x1 style-width) (cond ((numberp min-width) @@ -965,6 +970,10 @@ (t 0))) (max y2 (+ y1 height))))))) +(defmethod bounding-rectangle ((drei drei-area)) + (with-bounding-rectangle* (x1 y1 x2 y2) drei + (make-rectangle* x1 y1 x2 y2))) + ;; XXX: Full redraw for every replay, should probably use the `region' ;; parameter to only invalidate some strokes. (defmethod replay-output-record ((drei drei-area) (stream extended-output-stream) &optional @@ -986,7 +995,12 @@ (defun display-drei-area (drei) (with-accessors ((stream editor-pane) (view view)) drei + (clear-output-record drei) (replay drei stream) + (with-bounding-rectangle* (x1 y1 x2 y2) drei + (letf (((stream-current-output-record stream) drei)) + ;; XXX: This sets the size of the output record. + (draw-rectangle* stream x1 y1 x2 y2 :ink +transparent-ink+))) (when (point-cursor drei) (with-bounding-rectangle* (x1 y1 x2 y2) (point-cursor drei) (when (pane-viewport stream) @@ -1120,10 +1134,9 @@ (if (adjust-pane drei-pane) (display-drei-pane frame drei-pane) ;; Point must be on top of all other cursors. - (progn - (dolist (cursor (cursors drei-pane)) - (display-drei-view-cursor drei-pane view cursor)) - (fix-pane-viewport drei-pane (view drei-pane))))))) + (dolist (cursor (cursors drei-pane) + (fix-pane-viewport drei-pane (view drei-pane))) + (replay cursor drei-pane)))))) (defgeneric full-redisplay (pane) (:documentation "Queue a full redisplay for `pane'."))

1 0

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

16 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv29581/Drei Modified Files: drei.lisp Log Message: Added simple print-object method for Drei instances. --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/13 10:33:09 1.26 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/16 21:30:04 1.27 @@ -343,6 +343,10 @@ (defmethod esa-current-window ((drei drei)) drei) +(defmethod print-object ((object drei) stream) + (print-unreadable-object (object stream :type t :identity t) + (format stream "~A" (type-of (view object))))) + ;; Main redisplay entry point. (defgeneric display-drei (drei) (:documentation "`Drei' must be an object of type `drei' and

1 0

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

16 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv29806/Drei Modified Files: drei-redisplay.lisp Log Message: Output recording must be enabled when drawing cursors, or auto-scrolling won't work. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/16 15:19:30 1.39 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/16 18:32:33 1.40 @@ -980,7 +980,7 @@ (x-offset 0) (y-offset 0) (region +everywhere+)) (declare (ignore x-offset y-offset region)) (clear-output-record cursor) - (with-output-recording-options (stream :record nil :draw t) + (with-output-recording-options (stream :record t :draw t) (when (active cursor) (display-drei-view-cursor stream (view cursor) cursor))))

1 0

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

16 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv11063/Drei Modified Files: drei-clim.lisp Log Message: Respect the :x-position and :y-position initargs for Drei areas. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/15 18:43:28 1.29 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/16 17:11:52 1.30 @@ -344,9 +344,10 @@ record.")) (defmethod initialize-instance :after ((area drei-area) - &key) - (setf (input-editor-position area) - (multiple-value-list (output-record-position area)) + &key x-position y-position) + (check-type x-position integer) + (check-type y-position integer) + (setf (input-editor-position area) (list x-position y-position) (extend-pane-bottom (view area)) t) (tree-recompute-extent area))

1 0