October 2005 - gsharp-cvs@common-lisp.net

[gsharp-cvs] CVS update: gsharp/gui.lisp gsharp/score-pane.lisp
by rstrandh＠common-lisp.net 27 Oct '05

27 Oct '05

Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv6209 Modified Files: gui.lisp score-pane.lisp Log Message: Removed Gsharp-specific code for double buffering. Replaced it by general mechanism now available in McCLIM. This should also fix the pixmap-focus bug, though I can't test that because I never could reproduce the problem. Date: Thu Oct 27 03:28:08 2005 Author: rstrandh Index: gsharp/gui.lisp diff -u gsharp/gui.lisp:1.23 gsharp/gui.lisp:1.24 --- gsharp/gui.lisp:1.23 Mon Aug 8 01:18:02 2005 +++ gsharp/gui.lisp Thu Oct 27 03:28:08 2005 @@ -26,7 +26,8 @@ (score (let ((win (make-pane 'score-pane:score-pane :width 400 :height 500 :name "score" - :display-time :no-clear + ;; :incremental-redisplay t + :double-buffering t :display-function 'display-score :command-table 'total-melody-table))) (setf (windows *application-frame*) (list win)) Index: gsharp/score-pane.lisp diff -u gsharp/score-pane.lisp:1.12 gsharp/score-pane.lisp:1.13 --- gsharp/score-pane.lisp:1.12 Mon Aug 15 23:45:01 2005 +++ gsharp/score-pane.lisp Thu Oct 27 03:28:08 2005 @@ -608,20 +608,11 @@ ,@body)) (defmacro with-score-pane (pane &body body) - (let ((pixmap (gensym)) - (mirror (gensym))) - `(let* ((*pane* ,pane) - (*lighter-gray-progressions* (lighter-gray-progressions pane)) - (*darker-gray-progressions* (darker-gray-progressions pane)) - (,pixmap (allocate-pixmap *pane* 800 900)) - (,mirror (sheet-direct-mirror *pane*))) - (draw-rectangle* ,pixmap 0 0 800 900 :filled t :ink +white+) - (setf (sheet-direct-mirror *pane*) (climi::pixmap-mirror ,pixmap)) - (clear-output-record (stream-output-history *pane*)) - ,@body - (setf (sheet-direct-mirror *pane*) ,mirror) - (copy-from-pixmap ,pixmap 0 0 800 900 *pane* 0 0) - (deallocate-pixmap ,pixmap)))) + `(let* ((*pane* ,pane) + (*lighter-gray-progressions* (lighter-gray-progressions pane)) + (*darker-gray-progressions* (darker-gray-progressions pane))) + (clear-output-record (stream-output-history *pane*)) + ,@body)) (defmacro with-vertical-score-position ((pane yref) &body body) `(with-translation (,pane 0 ,yref)

1 0

[gsharp-cvs] CVS update: gsharp/packages.lisp
by crhodes＠common-lisp.net 13 Oct '05

13 Oct '05

Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv16387 Modified Files: packages.lisp Log Message: Really make gsharp and climacs coexist Date: Thu Oct 13 11:05:04 2005 Author: crhodes Index: gsharp/packages.lisp diff -u gsharp/packages.lisp:1.10 gsharp/packages.lisp:1.11 --- gsharp/packages.lisp:1.10 Mon Jul 25 13:14:38 2005 +++ gsharp/packages.lisp Thu Oct 13 11:05:04 2005 @@ -135,6 +135,7 @@ #:*numeric-argument-p* #:*current-gesture* #:esa-top-level #:simple-command-loop #:global-esa-table #:keyboard-macro-table + #:help-table #:set-key)) (defpackage :score-pane

1 0

[gsharp-cvs] CVS update: gsharp/esa.lisp
by crhodes＠common-lisp.net 01 Oct '05

01 Oct '05

Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv1751 Modified Files: esa.lisp Log Message: Merge climacs' version of esa Date: Sat Oct 1 11:37:32 2005 Author: crhodes Index: gsharp/esa.lisp diff -u gsharp/esa.lisp:1.4 gsharp/esa.lisp:1.5 --- gsharp/esa.lisp:1.4 Mon Aug 8 02:22:07 2005 +++ gsharp/esa.lisp Sat Oct 1 11:37:32 2005 @@ -301,7 +301,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; comand table manipulation +;;; command table manipulation (defun ensure-subtable (table gesture) (let* ((event (make-instance @@ -319,15 +319,20 @@ (command-menu-item-value (find-keystroke-item event table :errorp nil)))) - (defun set-key (command table gestures) - (if (null (cdr gestures)) - (add-command-to-command-table - command table :keystroke (car gestures) :errorp nil) - (set-key command - (ensure-subtable table (car gestures)) - (cdr gestures)))) - + (unless (consp command) + (setf command (list command))) + (let ((gesture (car gestures))) + (cond ((null (cdr gestures)) + (add-command-to-command-table + command table :keystroke gesture :errorp nil) + (when (and (listp gesture) + (find :meta gesture)) + (set-key command table (list (list :escape) (remove :meta gesture))))) + (t (set-key command + (ensure-subtable table gesture) + (cdr gestures)))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; standard key bindings @@ -357,6 +362,209 @@ (set-key 'com-extended-command 'global-esa-table '((#\x :meta))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Help + +(defun read-gestures-for-help (command-table) + (loop for gestures = (list (esa-read-gesture)) + then (nconc gestures (list (esa-read-gesture))) + for item = (find-gestures-with-inheritance gestures command-table) + unless item + do (return (values nil gestures)) + when (eq (command-menu-item-type item) :command) + do (return (values (command-menu-item-value item) + gestures)))) + +(defun describe-key-briefly (pane) + (let ((command-table (command-table pane))) + (multiple-value-bind (command gestures) + (read-gestures-for-help command-table) + (when (consp command) + (setf command (car command))) + (display-message "~{~A ~}~:[is not bound~;runs the command ~:*~A~]" + (mapcar #'gesture-name gestures) + (or (command-line-name-for-command + command command-table :errorp nil) + command))))) + +(defgeneric gesture-name (gesture)) + +(defmethod gesture-name ((char character)) + (or (char-name char) + char)) + +(defun translate-name-and-modifiers (key-name modifiers) + (with-output-to-string (s) + (loop for (modifier name) on (list + ;(+alt-key+ "A-") + +hyper-key+ "H-" + +super-key+ "s-" + +meta-key+ "M-" + +control-key+ "C-") + by #'cddr + when (plusp (logand modifier modifiers)) + do (princ name s)) + (princ (if (typep key-name 'character) + (or (char-name key-name) + key-name) + key-name) s))) + +(defmethod gesture-name ((ev keyboard-event)) + (let ((key-name (keyboard-event-key-name ev)) + (modifiers (event-modifier-state ev))) + (translate-name-and-modifiers key-name modifiers))) + +(defmethod gesture-name ((gesture list)) + (cond ((eq (car gesture) :keyboard) + (translate-name-and-modifiers (second gesture) (third gesture))) + ;; punt on this for now + (t nil))) + +(defun find-keystrokes-for-command (command command-table) + (let ((keystrokes '())) + (labels ((helper (command command-table prefix) + (map-over-command-table-keystrokes + #'(lambda (menu-name keystroke item) + (declare (ignore menu-name)) + (cond ((and (eq (command-menu-item-type item) :command) + (eq (car (command-menu-item-value item)) command)) + (push (cons keystroke prefix) keystrokes)) + ((eq (command-menu-item-type item) :menu) + (helper command (command-menu-item-value item) (cons keystroke prefix))) + (t nil))) + command-table))) + (helper command command-table nil) + keystrokes))) + +(defun find-keystrokes-for-command-with-inheritance (command start-table) + (let ((keystrokes '())) + (labels ((helper (table) + (let ((keys (find-keystrokes-for-command command table))) + (when keys (push keys keystrokes)) + (dolist (subtable (command-table-inherit-from + (find-command-table table))) + (helper subtable))))) + (helper start-table)) + keystrokes)) + +(defun find-all-keystrokes-and-commands (command-table) + (let ((results '())) + (labels ((helper (command-table prefix) + (map-over-command-table-keystrokes + #'(lambda (menu-name keystroke item) + (declare (ignore menu-name)) + (cond ((eq (command-menu-item-type item) :command) + (push (cons (cons keystroke prefix) + (command-menu-item-value item)) + results)) + ((eq (command-menu-item-type item) :menu) + (helper (command-menu-item-value item) (cons keystroke prefix))) + (t nil))) + command-table))) + (helper command-table nil) + results))) + +(defun find-all-keystrokes-and-commands-with-inheritance (start-table) + (let ((results '())) + (labels ((helper (table) + (let ((res (find-all-keystrokes-and-commands table))) + (when res (setf results (nconc res results))) + (dolist (subtable (command-table-inherit-from + (find-command-table table))) + (helper subtable))))) + (helper start-table)) + results)) + +(defun sort-by-name (list) + (sort list #'string< :key (lambda (item) (symbol-name (second item))))) + +(defun sort-by-keystrokes (list) + (sort list (lambda (a b) + (cond ((and (characterp a) + (characterp b)) + (char< a b)) + ((characterp a) + t) + ((characterp b) + nil) + (t (string< (symbol-name a) + (symbol-name b))))) + :key (lambda (item) (second (first (first item)))))) + +(defun describe-bindings (stream command-table + &optional (sort-function #'sort-by-name)) + (formatting-table (stream) + (loop for (keys command) + in (funcall sort-function + (find-all-keystrokes-and-commands-with-inheritance + command-table)) + do (formatting-row (stream) + (formatting-cell (stream :align-x :right) + (with-text-style (stream '(:sans-serif nil nil)) + (format stream "~A" + (or (command-line-name-for-command command + command-table + :errorp nil) + command)))) + (formatting-cell (stream) + (with-drawing-options (stream :ink +dark-blue+ + :text-style '(:fix nil nil)) + (format stream "~&~{~A~^ ~}" + (mapcar #'gesture-name (reverse keys)))))) + count command into length + finally (change-space-requirements stream + :height (* length (stream-line-height stream))) + (scroll-extent stream 0 0)))) + +;;; help commands + +(define-command-table help-table) + +(define-command (com-describe-key-briefly :name t :command-table help-table) () + (display-message "Describe key briefly:") + (redisplay-frame-panes *application-frame*) + (describe-key-briefly (car (windows *application-frame*)))) + +(set-key 'com-describe-key-briefly 'help-table '((#\h :control) (#\c))) + +(define-command (com-where-is :name t :command-table help-table) () + (let* ((command-table (command-table (car (windows *application-frame*)))) + (command + (handler-case + (accept + `(command-name :command-table + ,command-table) + :prompt "Where is command") + (error () (progn (beep) + (display-message "No such command") + (return-from com-where-is nil))))) + (keystrokes (find-keystrokes-for-command-with-inheritance command command-table))) + (display-message "~A is ~:[not on any key~;~:*on ~{~A~^, ~}~]" + (command-line-name-for-command command command-table) + (mapcar (lambda (keys) + (format nil "~{~A~^ ~}" + (mapcar #'gesture-name (reverse keys)))) + (car keystrokes))))) + +(set-key 'com-where-is 'help-table '((#\h :control) (#\w))) + +(define-command (com-describe-bindings :name t :command-table help-table) + ((sort-by-keystrokes 'boolean :prompt "Sort by keystrokes?")) + (let* ((window (car (windows *application-frame*))) + (stream (open-window-stream + :label (format nil "Help: Describe Bindings") + :input-buffer (climi::frame-event-queue *application-frame*) + :width 400)) + (command-table (command-table window))) + (describe-bindings stream command-table + (if sort-by-keystrokes + #'sort-by-keystrokes + #'sort-by-name)))) + +(set-key `(com-describe-bindings ,*numeric-argument-p*) 'help-table '((#\h :control) (#\b))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Keyboard macros @@ -420,7 +628,7 @@ esa-frame-mixin) () (:panes - (win (let* ((my-pane + (window (let* ((my-pane (make-pane 'example-pane :width 900 :height 400 :display-function 'display-my-pane @@ -434,12 +642,12 @@ (scrolling () my-pane) my-info-pane))) - (int (make-pane 'example-minibuffer-pane :width 900))) + (minibuffer (make-pane 'example-minibuffer-pane :width 900))) (:layouts (default (vertically (:scroll-bars nil) - win - int))) + window + minibuffer))) (:top-level (esa-top-level))) (defun display-my-pane (frame pane)

1 0