mcclim-cvs May 2008

mcclim-cvs@common-lisp.net

3 participants
40 discussions

[mcclim-cvs] CVS mcclim/Looks
by ahefner 06 May '08

06 May '08

Update of /project/mcclim/cvsroot/mcclim/Looks In directory clnet:/tmp/cvs-serv28102 Modified Files: pixie.lisp Log Message: Applied patch from Clinton Ebadi to call value-changed callback of slider. --- /project/mcclim/cvsroot/mcclim/Looks/pixie.lisp 2008/05/06 20:47:30 1.22 +++ /project/mcclim/cvsroot/mcclim/Looks/pixie.lisp 2008/05/06 20:49:02 1.23 @@ -268,6 +268,13 @@ (defmethod handle-event ((pane pixie-slider-pane) (event pointer-button-release-event)) (with-slots (armed dragging value bounce-value repeating was-repeating) pane (setf was-repeating repeating) + (when armed + (setf armed t + (gadget-value pane :invoke-callback t) + (convert-position-to-value pane + (if (eq (gadget-orientation pane) :vertical) + (pointer-event-y event) + (pointer-event-x event))))) (when dragging (unless (eq dragging :inside) (setf armed nil

1 0

[mcclim-cvs] CVS mcclim/Looks
by ahefner 06 May '08

06 May '08

Update of /project/mcclim/cvsroot/mcclim/Looks In directory clnet:/tmp/cvs-serv27864 Modified Files: pixie.lisp Log Message: Text style trickery - with truetype fonts, for whatever reason, :small feels much smaller. --- /project/mcclim/cvsroot/mcclim/Looks/pixie.lisp 2007/03/20 01:51:22 1.21 +++ /project/mcclim/cvsroot/mcclim/Looks/pixie.lisp 2008/05/06 20:47:30 1.22 @@ -1170,7 +1170,11 @@ (:default-initargs :default-view +pixie-tab-bar-view+ :background +gray83+ - :text-style (make-text-style :sans-serif :roman :small))) + :text-style (make-text-style :sans-serif + :roman + (if (find-package :mcclim-truetype) + :normal + :small)))) (defmethod compose-space ((pane pixie-tab-bar-pane) &key width height) (declare (ignore width height))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 03 May '08

03 May '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv1637/Drei Modified Files: lisp-syntax.lisp packages.lisp Log Message: Some generalisations in Lisp syntax. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/03/02 15:55:28 1.76 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/05/03 09:12:25 1.77 @@ -1420,18 +1420,23 @@ `mark-or-offset' is returned." (form-toplevel syntax (expression-at-mark syntax mark-or-offset))) -(defun list-at-mark (syntax mark-or-offset) - "Return the list form that `mark-or-offset' is inside, or NIL -if no such form exists." +(defun form-of-type-at-mark (syntax mark-or-offset test) + "Return the form that `mark-or-offset' is inside and for which +`test' returns true, or NIL if no such form exists." (as-offsets ((offset mark-or-offset)) (update-parse syntax) (let ((form-around (form-around syntax offset))) (when form-around - (if (and (form-list-p form-around) + (if (and (funcall test form-around) (> offset (start-offset form-around))) form-around (find-list-parent form-around)))))) +(defun list-at-mark (syntax mark-or-offset) + "Return the list form that `mark-or-offset' is inside, or NIL +if no such form exists." + (form-of-type-at-mark syntax mark-or-offset #'form-list-p)) + (defun symbol-at-mark (syntax mark-or-offset &optional (form-fetcher 'expression-at-mark)) "Return a symbol token at `mark-or-offset'. This function will @@ -2044,41 +2049,67 @@ nil (form-around-in-children syntax (children stack-top) offset)))))) +(defun find-parent-of-type (form test) + "Find a parent of `form' for which the function `test' is true +and return it. If a such a parent cannot be found, return nil." + (let ((parent (parent form))) + (cond ((null parent) + nil) + ((funcall test parent) + parent) + (t (find-parent-of-type parent test))))) + +(defun find-parent-of-type-offset (form test fn) + "Find a parent of `form' for which the function `test' is true +and return `fn' applied to this parent form. `Fn' should be a +function that returns an offset when applied to a +form (eg. `start-offset' or `end-offset'). If such a parent +cannot be found, return nil" + (let ((parent (find-parent-of-type form test))) + (when parent + (funcall fn parent)))) + +(defun find-child-of-type (form test) + "Find the first child of `form' for which the function `test' +is true and return it. If such a child cannot be found, return +nil." + (find-if #'(lambda (child) + (cond ((funcall test child) child) + ((formp child) (find-child-of-type child test)))) + (children form))) + +(defun find-child-of-type-offset (form test fn) + "Find the first child of `form' for which the function `test' is true and return `fn' applied to this child. +`Fn' should be a function that returns an offset when applied to +a form (eg. `start-offset' or `end-offset'). If such a child +cannot be found, return nil." + (let ((child (find-child-of-type form test))) + (when child + (funcall fn child)))) + (defun find-list-parent (form) "Find a list parent of `form' and return it. If a list parent cannot be found, return nil." - (let ((parent (parent form))) - (typecase parent - (list-form parent) - ((or form* null) nil) - (t (find-list-parent parent))))) + (find-parent-of-type form #'form-list-p)) (defun find-list-parent-offset (form fn) "Find a list parent of `form' and return `fn' applied to this parent token. `Fn' should be a function that returns an offset when applied to a token (eg. `start-offset' or `end-offset'). If a list parent cannot be found, return nil" - (let ((list-parent (find-list-parent form))) - (when list-parent - (funcall fn list-parent)))) + (find-parent-of-type-offset form #'form-list-p fn)) (defun find-list-child (form) "Find the first list child of `form' and return it. If a list child cannot be found, return nil." - (find-if #'(lambda (child) - (typecase child - (list-form child) - (form (find-list-child child)))) - (children form))) + (find-child-of-type form #'form-list-p)) (defun find-list-child-offset (form fn) "Find a list child of `form' and return `fn' applied to this child. `Fn' should be a function that returns an offset when applied to a form (eg. `start-offset' or `end-offset'). If a list child cannot be found, return nil." - (let ((list-child (find-list-child form))) - (when list-child - (funcall fn list-child)))) + (find-child-of-type-offset form #'form-list-p fn)) (defmethod backward-one-expression (mark (syntax lisp-syntax)) (update-parse syntax 0 (offset mark)) --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/02/15 13:16:17 1.53 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/05/03 09:12:25 1.54 @@ -562,6 +562,7 @@ #:find-list-parent #:expression-at-mark #:definition-at-mark + #:form-of-type-at-mark #:list-at-mark #:symbol-at-mark #:fully-quoted-form

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 03 May '08

03 May '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv27957/Drei Modified Files: lisp-syntax-swine.lisp Log Message: Minor fixes to complete-symbol-at-mark-with-fn. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/02/18 10:45:26 1.18 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/05/03 08:48:03 1.19 @@ -841,8 +841,8 @@ be displayed. If no symbol can be found at `mark', return NIL. If there is no symbol at `mark' and `complete-blank' is true (the default), all symbols available in the current package will be -shown. If `complete-blank' is true, nothing will be shown and the -function will return NIL." +shown. If `complete-blank' is false, nothing will be shown and +the function will return NIL." (let* ((token (form-around syntax (offset mark))) (useful-token (and (not (null token)) (form-token-p token) @@ -870,7 +870,8 @@ syntax mark (or (when (or useful-token (accept 'boolean - :prompt "You are asking for a list of all exported symbols, proceed?")) + :prompt "You are asking for a list of all exported symbols, proceed?") + (return-from complete-symbol-at-mark-with-fn nil)) (frame-manager-menu-choose (find-frame-manager) (mapcar

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 03 May '08

03 May '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv13626/Drei Modified Files: drei-redisplay.lisp views.lisp Log Message: Moved defvar to remove warnings. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/04/15 09:19:43 1.70 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/05/03 07:47:17 1.71 @@ -745,11 +745,6 @@ (when (> old-height (- y2 y1)) (clear-rectangle* pane x1 y2 (+ x1 old-width) (+ y1 old-height))))) -(defvar *maximum-chunk-size* 100 - "The maximum amount of objects put into a stroke by a -`drei-buffer-view'. Actual strokes may be smaller if a #\Newline -character is encountered.") - (defun object-drawer () "Return a closure capable of functioning as a stroke drawer. It expects its stroke to cover a single-object non-character buffer --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/03/07 15:23:14 1.44 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/05/03 07:47:17 1.45 @@ -719,6 +719,11 @@ "Return the length of the `buffer-line' object `line'." (- (end-offset line) (start-offset line))) +(defvar *maximum-chunk-size* 100 + "The maximum amount of objects put into a single chunk by a +`drei-buffer-view'. Actual chunks may be smaller if a #\Newline +character is encountered.") + (defun get-chunk (buffer line-start-offset chunk-start-offset line-end-offset) "Return a chunk in the form of a cons cell. The chunk will start at `chunk-start-offset' and extend no further than

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 01 May '08

01 May '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv3732 Modified Files: dead-keys.lisp mcclim.asd stream-input.lisp Log Message: Fix compile dependencies. --- /project/mcclim/cvsroot/mcclim/dead-keys.lisp 2008/05/01 07:48:45 1.3 +++ /project/mcclim/cvsroot/mcclim/dead-keys.lisp 2008/05/01 21:45:23 1.4 @@ -23,6 +23,10 @@ (in-package :clim-internals) +(defvar *dead-key-table* (make-hash-table :test 'equal) + "A hash table mapping keyboard event names and characters to +either a similar hash table or characters.") + (defun set-dead-key-combination (character gestures table) "Set `gestures' to result in `character' in the hash table `table' (see `*dead-key-table*' for the format of the hash --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/04/30 21:27:48 1.82 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/05/01 21:45:23 1.83 @@ -140,6 +140,7 @@ (:file "coordinates" :depends-on ("decls" "protocol-classes" "Lisp-Dep")) (:file "setf-star" :depends-on ("decls" "Lisp-Dep")) (:file "transforms" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "coordinates" "utils")) + (:file "dead-keys" :depends-on ("decls")) (:file "regions" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "coordinates" "utils" "transforms" "setf-star" "design")) (:file "sheets" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "utils" "transforms" "regions")) (:file "pixmap" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "sheets" "transforms" "regions")) @@ -163,8 +164,7 @@ (:file "encapsulate" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "sheets" "graphics" "utils" "medium" "input" "stream-output" "recording")) (:file "stream-input" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "input" "ports" "sheets" "events" - "encapsulate" "transforms" "utils")) - (:file "dead-keys" :depends-on ("stream-input")) + "encapsulate" "transforms" "utils" "dead-keys")) (:file "text-selection" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "X11-colors" "medium" "output" "transforms" "sheets" "stream-output" "ports" "recording" "regions" --- /project/mcclim/cvsroot/mcclim/stream-input.lisp 2008/05/01 07:48:45 1.53 +++ /project/mcclim/cvsroot/mcclim/stream-input.lisp 2008/05/01 21:45:23 1.54 @@ -122,10 +122,6 @@ do (handle-event (event-sheet event) event)) nil) -(defvar *dead-key-table* (make-hash-table :test 'equal) - "A hash table mapping keyboard event names and characters to -either a similar hash table or characters.") - (defclass dead-key-merging-mixin () ((state :initform *dead-key-table*) (last-deadie-gesture) ; For avoiding name clash with standard-extended-input-stream

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 01 May '08

01 May '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv9480 Modified Files: dead-keys.lisp stream-input.lisp Log Message: Removed some code duplication in dead key handling. --- /project/mcclim/cvsroot/mcclim/dead-keys.lisp 2008/05/01 06:48:23 1.2 +++ /project/mcclim/cvsroot/mcclim/dead-keys.lisp 2008/05/01 07:48:45 1.3 @@ -117,13 +117,12 @@ (defmacro merging-dead-keys ((gesture state) &body body) "Accumulate dead keys and subsequent characters. `Gesture' should be a symbol bound to either a gesture or an input -event. When it has been determined that a sequence of `gesture's -either does or doesn't result in a full gesture, `body' will be -evaluated with `gesture' bound to that gesture. `State' must be a -place, initially NIL, that will contain the state of dead-key -handling, enabling asynchronous use of the macro." +event. `Body' will be evaluated either with the `gesture' binding +unchanged, or with `gesture' bound to the result of merging +preceding dead keys. `State' must be a place, initially NIL, that +will contain the state of dead-key handling, enabling +asynchronous use of the macro." `(flet ((invoke-body (,gesture) - (setf ,state *dead-key-table*) ,@body)) (when (null ,state) (setf ,state *dead-key-table*)) @@ -141,7 +140,10 @@ (characterp ,gesture)) (setf ,state *dead-key-table*)))) (character + (setf ,state *dead-key-table*) (invoke-body value)) (hash-table - (setf ,state value)))) - (invoke-body ,gesture)))) + (setf ,state value) + (invoke-body value)))) + (progn (setf ,state *dead-key-table*) + (invoke-body ,gesture))))) --- /project/mcclim/cvsroot/mcclim/stream-input.lisp 2008/04/30 21:27:48 1.52 +++ /project/mcclim/cvsroot/mcclim/stream-input.lisp 2008/05/01 07:48:45 1.53 @@ -146,37 +146,23 @@ (handler-case (loop with start-time = (get-internal-real-time) with end-time = start-time - for gesture = (call-next-method stream - :timeout (when timeout - (- timeout (/ (- end-time start-time) - internal-time-units-per-second))) - :peek-p peek-p - :input-wait-test input-wait-test - :input-wait-handler input-wait-handler - :pointer-button-press-handler - pointer-button-press-handler) - do (setf end-time (get-internal-real-time) - last-deadie-gesture gesture - last-state state) - do (if (typep gesture '(or keyboard-event character)) - (let ((value (gethash (if (characterp gesture) - gesture - (keyboard-event-key-name gesture)) - state))) - (etypecase value - (null - (cond ((eq state *dead-key-table*) - (return gesture)) - ((or (and (typep gesture 'keyboard-event) - (keyboard-event-character gesture)) - (characterp gesture)) - (setf state *dead-key-table*)))) - (character - (setf state *dead-key-table*) - (return value)) - (hash-table - (return (setf state value))))) - (return gesture))) + do (multiple-value-bind (gesture reason) + (call-next-method stream + :timeout (when timeout + (- timeout (/ (- end-time start-time) + internal-time-units-per-second))) + :peek-p peek-p + :input-wait-test input-wait-test + :input-wait-handler input-wait-handler + :pointer-button-press-handler + pointer-button-press-handler) + (when (null gesture) + (return (values nil reason))) + (setf end-time (get-internal-real-time) + last-deadie-gesture gesture + last-state state) + (merging-dead-keys (gesture state) + (return gesture)))) ;; Policy decision: an abort cancels the current composition. (abort-gesture (c) (setf state *dead-key-table*)

1 0

[mcclim-cvs] CVS mcclim/ESA
by thenriksen 01 May '08

01 May '08

Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv25657/ESA Modified Files: esa.lisp packages.lisp Log Message: Wrap up the last dead-key stuff for Drei gadgets. --- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/04/30 21:27:46 1.22 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/05/01 06:48:22 1.23 @@ -501,6 +501,18 @@ (setf (accumulated-gestures command-processor) nil) (signal 'abort-gesture :event gesture))) +(defclass dead-key-merging-command-processor (command-processor) + ((%dead-key-state :accessor dead-key-state + :initform nil + :documentation "The state of dead key +handling as per `merging-dead-keys'.")) + (:documentation "Helper class useful for asynchronous command +processors, merges incoming dead keys with the following key.")) + +(defmethod process-gesture :around ((command-processor dead-key-merging-command-processor) gesture) + (merging-dead-keys (gesture (dead-key-state command-processor)) + (call-next-method command-processor gesture))) + (defclass command-loop-command-processor (command-processor) ((%command-table :reader command-table :initarg :command-table --- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/04/29 20:52:05 1.19 +++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/05/01 06:48:22 1.20 @@ -65,7 +65,7 @@ #:add-default-modes #:remove-default-modes)) (defpackage :esa - (:use :clim-lisp :clim :esa-utils) + (:use :clim-lisp :clim :esa-utils :clim-extensions) (:export #:*esa-instance* #:buffers #:esa-current-buffer #:current-buffer #:windows #:esa-current-window #:current-window @@ -79,6 +79,7 @@ #:unbound-gesture-sequence #:gestures #:command-processor #:instant-macro-execution-mixin #:asynchronous-command-processor #:command-loop-command-processor + #:dead-key-merging-command-processor #:overriding-handler #:directly-processing-p #:process-gesture #:process-gestures-or-command #:command-for-unbound-gestures #:*extended-command-prompt* @@ -89,7 +90,6 @@ #:find-applicable-command-table #:esa-command-parser #:esa-partial-command-parser - #:handling-dead-keys #:gesture-matches-gesture-name-p #:meta-digit #:proper-gesture-p

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 01 May '08

01 May '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv25657 Modified Files: dead-keys.lisp package.lisp Log Message: Wrap up the last dead-key stuff for Drei gadgets. --- /project/mcclim/cvsroot/mcclim/dead-keys.lisp 2008/04/30 21:27:48 1.1 +++ /project/mcclim/cvsroot/mcclim/dead-keys.lisp 2008/05/01 06:48:23 1.2 @@ -113,3 +113,35 @@ (define-dead-key-combination (code-char 251) (:dead-circumflex #\u)) (define-dead-key-combination (code-char 94) (:dead-circumflex #\space)) (define-dead-key-combination (code-char 94) (:dead-circumflex :dead-circumflex)) + +(defmacro merging-dead-keys ((gesture state) &body body) + "Accumulate dead keys and subsequent characters. `Gesture' +should be a symbol bound to either a gesture or an input +event. When it has been determined that a sequence of `gesture's +either does or doesn't result in a full gesture, `body' will be +evaluated with `gesture' bound to that gesture. `State' must be a +place, initially NIL, that will contain the state of dead-key +handling, enabling asynchronous use of the macro." + `(flet ((invoke-body (,gesture) + (setf ,state *dead-key-table*) + ,@body)) + (when (null ,state) + (setf ,state *dead-key-table*)) + (if (typep ,gesture '(or keyboard-event character)) + (let ((value (gethash (if (characterp ,gesture) + ,gesture + (keyboard-event-key-name ,gesture)) + ,state))) + (etypecase value + (null + (cond ((eq ,state *dead-key-table*) + (invoke-body ,gesture)) + ((or (and (typep ,gesture 'keyboard-event) + (keyboard-event-character ,gesture)) + (characterp ,gesture)) + (setf ,state *dead-key-table*)))) + (character + (invoke-body value)) + (hash-table + (setf ,state value)))) + (invoke-body ,gesture)))) --- /project/mcclim/cvsroot/mcclim/package.lisp 2008/04/14 16:46:38 1.68 +++ /project/mcclim/cvsroot/mcclim/package.lisp 2008/05/01 06:48:23 1.69 @@ -1945,6 +1945,7 @@ #:frame-display-pointer-documentation-string #:list-pane-items #:output-record-baseline + #:merging-dead-keys #:draw-output-border-over #:draw-output-border-under

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 01 May '08

01 May '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv25657/Drei Modified Files: drei-clim.lisp Log Message: Wrap up the last dead-key stuff for Drei gadgets. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/04/30 21:27:46 1.44 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/05/01 06:48:21 1.45 @@ -229,7 +229,8 @@ ;;; updating is done after a command has been executed, and only then ;;; (or by commands at their own discretion). (defclass drei-gadget-pane (drei-pane value-gadget action-gadget - asynchronous-command-processor) + asynchronous-command-processor + dead-key-merging-command-processor) ((%currently-processing :initform nil :accessor currently-processing-p) (%previous-focus :accessor previous-focus :initform nil @@ -296,12 +297,11 @@ (*abort-gestures* *esa-abort-gestures*) (*standard-input* drei)) (accepting-from-user (drei) - (handling-dead-keys (gesture) - (handler-case (process-gesture drei gesture) - (unbound-gesture-sequence (c) - (display-message "~A is unbound" (gesture-name (gestures c)))) - (abort-gesture () - (display-message "Aborted")))) + (handler-case (process-gesture drei gesture) + (unbound-gesture-sequence (c) + (display-message "~A is unbound" (gesture-name (gestures c)))) + (abort-gesture () + (display-message "Aborted"))) (display-drei drei :redisplay-minibuffer t) (when (modified-p (view drei)) (when (gadget-value-changed-callback drei)

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 May 2008