gsharp-cvs

gsharp-cvs@common-lisp.net

396 discussions

[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

[gsharp-cvs] CVS update: gsharp/drawing.lisp
by crhodes＠common-lisp.net 02 Sep '05

02 Sep '05

Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv6246 Modified Files: drawing.lisp Log Message: Draw lyrics in serif font, because, well, why not? Date: Fri Sep 2 18:10:03 2005 Author: crhodes Index: gsharp/drawing.lisp diff -u gsharp/drawing.lisp:1.10 gsharp/drawing.lisp:1.11 --- gsharp/drawing.lisp:1.10 Fri Sep 2 11:01:25 2005 +++ gsharp/drawing.lisp Fri Sep 2 18:10:03 2005 @@ -643,5 +643,6 @@ (defmethod draw-element (pane (element lyrics-element) x &optional (flags t)) (declare (ignore flags)) (score-pane:with-vertical-score-position (pane (staff-yoffset (staff element))) - (draw-text* pane (map 'string 'code-char (text element)) - x 0 :align-x :center))) + (with-text-family (pane :serif) + (draw-text* pane (map 'string 'code-char (text element)) + x 0 :align-x :center))))

1 0

[gsharp-cvs] CVS update: gsharp/drawing.lisp
by crhodes＠common-lisp.net 02 Sep '05

02 Sep '05

Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv7745 Modified Files: drawing.lisp Log Message: Behave a bit better by calling DRAW-TEXT with a string, not a sequence of codepoints. (The previous code worked with the regular CLX backend but not with the freetype backend; however, the clim spec says DRAW-TEXT takes a character-or-string) Date: Fri Sep 2 11:01:26 2005 Author: crhodes Index: gsharp/drawing.lisp diff -u gsharp/drawing.lisp:1.9 gsharp/drawing.lisp:1.10 --- gsharp/drawing.lisp:1.9 Mon Aug 1 01:36:56 2005 +++ gsharp/drawing.lisp Fri Sep 2 11:01:25 2005 @@ -643,4 +643,5 @@ (defmethod draw-element (pane (element lyrics-element) x &optional (flags t)) (declare (ignore flags)) (score-pane:with-vertical-score-position (pane (staff-yoffset (staff element))) - (draw-text* pane (text element) x 0 :align-x :center))) + (draw-text* pane (map 'string 'code-char (text element)) + x 0 :align-x :center)))

1 0

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

15 Aug '05

Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv30499 Modified Files: score-pane.lisp Log Message: fixed the problem with horizontal beams Date: Mon Aug 15 23:45:01 2005 Author: rstrandh Index: gsharp/score-pane.lisp diff -u gsharp/score-pane.lisp:1.11 gsharp/score-pane.lisp:1.12 --- gsharp/score-pane.lisp:1.11 Sun Aug 14 20:00:45 2005 +++ gsharp/score-pane.lisp Mon Aug 15 23:45:01 2005 @@ -588,7 +588,7 @@ (medium (sheet-medium pane))) (assert (< slope 1)) (if (= y1 y2) - (draw-horizontal-beam medium xx1 y1 xx2 thickness) + (draw-horizontal-beam pane xx1 y1 xx2 thickness) (draw-sloped-beam medium xx1 y1 xx2 y2 thickness (/ slope))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

1 0

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

14 Aug '05

Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv15400 Modified Files: score-pane.lisp Log Message: Fixes to beam drawing. (thanks to Christophe Rhodes) Date: Sun Aug 14 20:00:45 2005 Author: rstrandh Index: gsharp/score-pane.lisp diff -u gsharp/score-pane.lisp:1.10 gsharp/score-pane.lisp:1.11 --- gsharp/score-pane.lisp:1.10 Mon Aug 8 01:18:02 2005 +++ gsharp/score-pane.lisp Sun Aug 14 20:00:45 2005 @@ -420,7 +420,8 @@ ;;; beam drawing (defclass beam-output-record (score-output-record) - ((thickness :initarg :thickness))) + ((light-glyph-p :initarg :light-glyph-p) + (thickness :initarg :thickness))) (defun draw-horizontal-beam (medium x1 y1 x2 thickness) (let ((y2 (- y1 thickness))) @@ -518,9 +519,9 @@ (x-offset 0) (y-offset 0)) (declare (ignore x-offset y-offset region)) (with-bounding-rectangle* (x1 y1 x2 y2) record - (with-slots (thickness ink) record + (with-slots (thickness ink light-glyph-p) record (let ((medium (sheet-medium stream))) - (let ((*light-glyph* (not (eq ink +black+)))) + (let ((*light-glyph* light-glyph-p)) (with-drawing-options (medium :ink ink) (let ((*lighter-gray-progressions* (lighter-gray-progressions stream)) (*darker-gray-progressions* (darker-gray-progressions stream))) @@ -535,9 +536,9 @@ (x-offset 0) (y-offset 0)) (declare (ignore x-offset y-offset region)) (with-bounding-rectangle* (x1 y1 x2 y2) record - (with-slots (thickness ink) record + (with-slots (thickness ink light-glyph-p) record (let ((medium (sheet-medium stream))) - (let ((*light-glyph* (not (eq ink +black+)))) + (let ((*light-glyph* light-glyph-p)) (with-drawing-options (medium :ink ink) (let ((*lighter-gray-progressions* (lighter-gray-progressions stream)) (*darker-gray-progressions* (darker-gray-progressions stream))) @@ -555,6 +556,7 @@ (stream-add-output-record *pane* (make-instance 'downward-beam-output-record :x1 xx1 :y1 yy1 :x2 xx2 :y2 yy2 + :light-glyph-p *light-glyph* :thickness thickness :ink (medium-ink medium)))))) (when (stream-drawing-p *pane*) (draw-downward-beam medium x1 y1 y2 thickness inverse-slope))) @@ -566,7 +568,8 @@ (transform-position transformation x2 y2) (stream-add-output-record *pane* (make-instance 'upward-beam-output-record - :x1 xx1 :y1 yy1 :x2 xx2 :y2 yy2 + :x1 xx1 :y1 yy2 :x2 xx2 :y2 yy1 + :light-glyph-p *light-glyph* :thickness thickness :ink (medium-ink medium)))))) (when (stream-drawing-p *pane*) (draw-upward-beam medium x1 y1 y2 thickness inverse-slope))))))

1 0

[gsharp-cvs] CVS update: gsharp/esa.lisp
by rstrandh＠common-lisp.net 08 Aug '05

08 Aug '05

Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv10388 Modified Files: esa.lisp Log Message: Copy improvements to esa.lisp made by Dave Murray for Climacs. Date: Mon Aug 8 02:22:08 2005 Author: rstrandh Index: gsharp/esa.lisp diff -u gsharp/esa.lisp:1.3 gsharp/esa.lisp:1.4 --- gsharp/esa.lisp:1.3 Tue Aug 2 04:15:57 2005 +++ gsharp/esa.lisp Mon Aug 8 02:22:07 2005 @@ -143,39 +143,65 @@ (t (unread-gesture gesture :stream stream)))) +(define-gesture-name universal-argument :keyboard (#\u :control)) + +(define-gesture-name meta-minus :keyboard (#\- :meta)) + (defun read-numeric-argument (&key (stream *standard-input*)) + "Reads gestures returning two values: prefix-arg and whether prefix given. +Accepts: EITHER C-u, optionally followed by other C-u's, optionally followed +by a minus sign, optionally followed by decimal digits; +OR An optional M-minus, optionally followed by M-decimal-digits. +You cannot mix C-u and M-digits. +C-u gives a numarg of 4. Additional C-u's multiply by 4 (e.g. C-u C-u C-u = 64). +After C-u you can enter decimal digits, possibly preceded by a minus (but not +a plus) sign. C-u 3 4 = 34, C-u - 3 4 = -34. Note that C-u 3 - prints 3 '-'s. +M-1 M-2 = 12. M-- M-1 M-2 = -12. As a special case, C-u - and M-- = -1. +In the absence of a prefix arg returns 1 (and nil)." (let ((gesture (esa-read-gesture))) (cond ((event-matches-gesture-name-p - gesture - `(:keyboard #\u ,(make-modifier-state :control))) + gesture 'universal-argument) (let ((numarg 4)) (loop for gesture = (esa-read-gesture) while (event-matches-gesture-name-p - gesture - `(:keyboard #\u ,(make-modifier-state :control))) + gesture 'universal-argument) do (setf numarg (* 4 numarg)) finally (esa-unread-gesture gesture stream)) - (let ((gesture (esa-read-gesture))) + (let ((gesture (esa-read-gesture)) + (sign +1)) + (when (and (characterp gesture) + (char= gesture #\-)) + (setf gesture (esa-read-gesture) + sign -1)) (cond ((and (characterp gesture) (digit-char-p gesture 10)) - (setf numarg (- (char-code gesture) (char-code #\0))) + (setf numarg (digit-char-p gesture 10)) (loop for gesture = (esa-read-gesture) while (and (characterp gesture) (digit-char-p gesture 10)) do (setf numarg (+ (* 10 numarg) - (- (char-code gesture) (char-code #\0)))) + (digit-char-p gesture 10))) finally (esa-unread-gesture gesture stream) - (return (values numarg t)))) + (return (values (* numarg sign) t)))) (t (esa-unread-gesture gesture stream) - (values numarg t)))))) - ((meta-digit gesture) - (let ((numarg (meta-digit gesture))) + (values (if (minusp sign) -1 numarg) t)))))) + ((or (meta-digit gesture) + (event-matches-gesture-name-p + gesture 'meta-minus)) + (let ((numarg 0) + (sign +1)) + (cond ((meta-digit gesture) + (setf numarg (meta-digit gesture))) + (t (setf sign -1))) (loop for gesture = (esa-read-gesture) while (meta-digit gesture) do (setf numarg (+ (* 10 numarg) (meta-digit gesture))) finally (esa-unread-gesture gesture stream) - (return (values numarg t))))) + (return (values (if (and (= sign -1) (= numarg 0)) + -1 + (* sign numarg)) + t))))) (t (esa-unread-gesture gesture stream) (values 1 nil)))))

1 0

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

07 Aug '05

Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv6535 Modified Files: gui.lisp score-pane.lisp Log Message: More modifications to allow incremental redisplay. There is still a problem with beam drawing which has to be converted to use the correct superclass. Date: Mon Aug 8 01:18:03 2005 Author: rstrandh Index: gsharp/gui.lisp diff -u gsharp/gui.lisp:1.22 gsharp/gui.lisp:1.23 --- gsharp/gui.lisp:1.22 Tue Aug 2 02:34:41 2005 +++ gsharp/gui.lisp Mon Aug 8 01:18:02 2005 @@ -26,7 +26,7 @@ (score (let ((win (make-pane 'score-pane:score-pane :width 400 :height 500 :name "score" -;; :display-time :no-clear + :display-time :no-clear :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.9 gsharp/score-pane.lisp:1.10 --- gsharp/score-pane.lisp:1.9 Tue Aug 2 02:34:41 2005 +++ gsharp/score-pane.lisp Mon Aug 8 01:18:02 2005 @@ -50,12 +50,7 @@ ;;; ;;; output recording -;;; we should not have to inherit from standard-boudning-rectangle, -;;; but the implementation of incremental redisplay in McCLIM assumes -;;; that this is the case for all output records participating in -;;; incremental redisplay. - -(defclass score-output-record (displayed-output-record standard-bounding-rectangle) +(defclass score-output-record (displayed-output-record) ((parent :initarg :parent :initform nil :accessor output-record-parent) (x :initarg :x1 :initarg :x-position) (y :initarg :y1 :initarg :y-position) @@ -108,34 +103,45 @@ (with-bounding-rectangle* (x1 y1 x2 y2) record (region-intersects-region-p region (make-rectangle* x1 y1 x2 y2)))) -;;;;;;;;;;;;;;;;;; pixmap output record - -(defclass pixmap-output-record (score-output-record) - ((pixmap :initarg :pixmap))) - -(defmethod replay-output-record ((record pixmap-output-record) stream - &optional (region +everywhere+) - (x-offset 0) (y-offset 0)) - (declare (ignore x-offset y-offset region)) - (multiple-value-bind (x y) (output-record-position record) - (with-slots (pixmap) record - (let ((medium (sheet-medium stream))) - (copy-from-pixmap pixmap 0 0 (pixmap-width pixmap) (pixmap-height pixmap) - medium x y))))) +;;;;;;;;;;;;;;;;;; pixmap drawing -(defun make-pixmap-record (class medium x1 y1 x2 y2 pixmap) - (multiple-value-bind (x1 y1) - (transform-position (medium-transformation medium) x1 y1) - (multiple-value-bind (x2 y2) - (transform-position (medium-transformation medium) x2 y2) - (make-instance class :x1 x1 :x2 x2 :y1 y1 :y2 y2 :pixmap pixmap)))) - -(defun add-new-pixmap-record (class stream pixmap x y) - (let ((width (pixmap-width pixmap)) - (height (pixmap-height pixmap))) - (stream-add-output-record - stream (make-pixmap-record class (sheet-medium stream) - x y (+ x width) (+ y height) pixmap)))) +(climi::def-grecording draw-pixmap (() pixmap pm-x pm-y) () + (climi::with-transformed-position ((medium-transformation medium) pm-x pm-y) + (setf (slot-value climi::graphic 'pm-x) pm-x + (slot-value climi::graphic 'pm-y) pm-y) + (values pm-x pm-y (+ pm-x (pixmap-width pixmap)) (+ pm-y (pixmap-height pixmap))))) + +(climi::def-graphic-op draw-pixmap (pixmap pm-x pm-y)) + +(defmethod medium-draw-pixmap* ((medium clim:medium) pixmap pm-x pm-y) + (copy-from-pixmap pixmap 0 0 (pixmap-width pixmap) (pixmap-height pixmap) + medium pm-x pm-y)) + +(climi::defmethod* (setf output-record-position) :around + (nx ny (record draw-pixmap-output-record)) + (climi::with-standard-rectangle* (:x1 x1 :y1 y1) + record + (with-slots (pm-x pm-y) + record + (let ((dx (- nx x1)) + (dy (- ny y1))) + (multiple-value-prog1 + (call-next-method) + (incf pm-x dx) + (incf pm-y dy)))))) + +(climi::defrecord-predicate draw-pixmap-output-record (pm-x pm-y) + (and (climi::if-supplied (pm-x coordinate) + (climi::coordinate= (slot-value climi::record 'pm-x) pm-x)) + (climi::if-supplied (pm-y coordinate) + (climi::coordinate= (slot-value climi::record 'pm-y) pm-y)))) + +(defun draw-pixmap* (sheet pixmap x y + &rest args + &key clipping-region transformation) + (declare (ignore clipping-region transformation)) + (climi::with-medium-options (sheet args) + (medium-draw-pixmap* medium pixmap x y))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -153,10 +159,7 @@ (multiple-value-bind (dx dy) (glyph-offsets *font* (+ glyph-no extra)) (let ((x1 (+ x dx)) (y1 (+ (staff-step staff-step) dy))) - (when (stream-recording-p pane) - (add-new-pixmap-record 'pixmap-output-record pane pixmap x1 y1)) - (when (stream-drawing-p pane) - (copy-from-pixmap pixmap 0 0 width height pane x1 y1)))))) + (draw-pixmap* pane pixmap x1 y1))))) (defun draw-stack (pane glyph-lower glyph-upper glyph-two x staff-step how-many) (draw-antialiased-glyph pane glyph-lower x staff-step) @@ -179,36 +182,18 @@ ;;;;;;;;;;;;;;;;;; helper macro -(defmacro define-pixmap-recording ((record-name medium-draw-name draw-name args) &body body) - `(progn - (defclass ,record-name (pixmap-output-record) ()) - - (defgeneric ,medium-draw-name (medium pixmap x y)) - - (defmethod ,medium-draw-name ((medium medium) pixmap x y) - (copy-from-pixmap pixmap 0 0 (pixmap-width pixmap) (pixmap-height pixmap) - medium x y)) - - (defmethod ,medium-draw-name ((sheet sheet) pixmap x y) - (,medium-draw-name (sheet-medium sheet) pixmap x y)) - - (defmethod ,medium-draw-name :around ((pane score-pane) pixmap x y) - (when (stream-recording-p pane) - (add-new-pixmap-record ',record-name pane pixmap x y)) - (when (stream-drawing-p pane) - (,medium-draw-name (sheet-medium pane) pixmap x y))) - - (defun ,draw-name (pane ,@args x staff-step) - (let* ((extra (if *light-glyph* 1 0)) - (glyph-no ,@body) - (matrix (glyph *font* (+ glyph-no extra))) - (pixmap (pane-pixmap pane matrix))) - (multiple-value-bind (dx dy) (glyph-offsets *font* (+ glyph-no extra)) - (,medium-draw-name pane pixmap (+ x dx) (- dy (staff-step staff-step)))))))) +(defmacro define-pixmap-recording ((draw-name args) &body body) + `(defun ,draw-name (pane ,@args x staff-step) + (let* ((extra (if *light-glyph* 1 0)) + (glyph-no ,@body) + (matrix (glyph *font* (+ glyph-no extra))) + (pixmap (pane-pixmap pane matrix))) + (multiple-value-bind (dx dy) (glyph-offsets *font* (+ glyph-no extra)) + (draw-pixmap* pane pixmap (+ x dx) (- dy (staff-step staff-step))))))) ;;;;;;;;;;;;;;;;;; notehead -(define-pixmap-recording (notehead-output-record medium-draw-notehead draw-notehead (name)) +(define-pixmap-recording (draw-notehead (name)) (ecase name (:whole +glyph-whole+) (:half +glyph-half+) @@ -223,7 +208,7 @@ ;;;;;;;;;;;;;;;;;; accidental -(define-pixmap-recording (accidental-output-record medium-draw-accidental draw-accidental (name)) +(define-pixmap-recording (draw-accidental (name)) (ecase name (:natural +glyph-natural+) (:flat +glyph-flat+) @@ -233,7 +218,7 @@ ;;;;;;;;;;;;;;;;;; clef -(define-pixmap-recording (clef-output-record medium-draw-clef draw-clef (name)) +(define-pixmap-recording (draw-clef (name)) (ecase name (:treble +glyph-g-clef+) (:bass +glyph-f-clef+) @@ -248,7 +233,7 @@ ;;;;;;;;;;;;;;;;;; rest -(define-pixmap-recording (rest-output-record medium-draw-rest draw-rest (duration)) +(define-pixmap-recording (draw-rest (duration)) (ecase duration (1 +glyph-whole-rest+) (1/2 +glyph-half-rest+) @@ -261,7 +246,7 @@ ;;;;;;;;;;;;;;;;;; flags down -(define-pixmap-recording (flags-down-output-record medium-draw-flags-down draw-flags-down (nb)) +(define-pixmap-recording (draw-flags-down (nb)) (ecase nb (1 +glyph-flags-down-one+) (2 +glyph-flags-down-two+) @@ -271,7 +256,7 @@ ;;;;;;;;;;;;;;;;;; flags up -(define-pixmap-recording (flags-up-output-record medium-draw-flags-up draw-flags-up (nb)) +(define-pixmap-recording (draw-flags-up (nb)) (ecase nb (1 +glyph-flags-up-one+) (2 +glyph-flags-up-two+) @@ -281,7 +266,7 @@ ;;;;;;;;;;;;;;;;;; dot -(define-pixmap-recording (dot-output-record medium-draw-dot draw-dot ()) +(define-pixmap-recording (draw-dot ()) +glyph-dot+) ;;;;;;;;;;;;;;;;;; staff line @@ -505,30 +490,30 @@ (- x2 x1) 1 medium x1 (- y thickness)))) -(defun draw-upward-beam-segment (medium x1 y x2 thickness) +(defun draw-downward-beam-segment (medium x1 y x2 thickness) (draw-segment medium x1 (1+ y) x2 thickness *darker-gray-progressions* *lighter-gray-progressions*)) -(defun draw-downward-beam-segment (medium x1 y x2 thickness) +(defun draw-upward-beam-segment (medium x1 y x2 thickness) (draw-segment medium x1 y x2 thickness *lighter-gray-progressions* *darker-gray-progressions*)) -(defun draw-upward-beam (medium x1 y1 y2 thickness inverse-slope) +(defun draw-downward-beam (medium x1 y1 y2 thickness inverse-slope) (loop for y from y1 below y2 for x from x1 by inverse-slope do - (draw-upward-beam-segment medium (round x) y + (draw-downward-beam-segment medium (round x) y (round (+ x inverse-slope)) thickness))) -(defun draw-downward-beam (medium x1 y1 y2 thickness inverse-slope) +(defun draw-upward-beam (medium x1 y1 y2 thickness inverse-slope) (loop for y from y1 above y2 for x from x1 by inverse-slope do - (draw-downward-beam-segment medium (round x) y + (draw-upward-beam-segment medium (round x) y (round (+ x inverse-slope)) thickness))) -(defclass upward-beam-output-record (beam-output-record) +(defclass downward-beam-output-record (beam-output-record) ()) -(defmethod replay-output-record ((record upward-beam-output-record) (stream score-pane) +(defmethod replay-output-record ((record downward-beam-output-record) (stream score-pane) &optional (region +everywhere+) (x-offset 0) (y-offset 0)) (declare (ignore x-offset y-offset region)) @@ -539,13 +524,13 @@ (with-drawing-options (medium :ink ink) (let ((*lighter-gray-progressions* (lighter-gray-progressions stream)) (*darker-gray-progressions* (darker-gray-progressions stream))) - (draw-upward-beam medium x1 y1 y2 thickness + (draw-downward-beam medium x1 y1 y2 thickness (/ (- x2 x1) (- y2 y1)))))))))) -(defclass downward-beam-output-record (beam-output-record) +(defclass upward-beam-output-record (beam-output-record) ()) -(defmethod replay-output-record ((record downward-beam-output-record) (stream score-pane) +(defmethod replay-output-record ((record upward-beam-output-record) (stream score-pane) &optional (region +everywhere+) (x-offset 0) (y-offset 0)) (declare (ignore x-offset y-offset region)) @@ -556,7 +541,7 @@ (with-drawing-options (medium :ink ink) (let ((*lighter-gray-progressions* (lighter-gray-progressions stream)) (*darker-gray-progressions* (darker-gray-progressions stream))) - (draw-downward-beam medium x1 y2 y1 thickness + (draw-upward-beam medium x1 y2 y1 thickness (/ (- x2 x1) (- y2 y1)))))))))) (defun draw-sloped-beam (medium x1 y1 x2 y2 thickness inverse-slope) @@ -568,11 +553,11 @@ (multiple-value-bind (xx2 yy2) (transform-position transformation x2 y2) (stream-add-output-record - *pane* (make-instance 'upward-beam-output-record + *pane* (make-instance 'downward-beam-output-record :x1 xx1 :y1 yy1 :x2 xx2 :y2 yy2 :thickness thickness :ink (medium-ink medium)))))) (when (stream-drawing-p *pane*) - (draw-upward-beam medium x1 y1 y2 thickness inverse-slope))) + (draw-downward-beam medium x1 y1 y2 thickness inverse-slope))) (t (when (stream-recording-p *pane*) (multiple-value-bind (xx1 yy1) @@ -580,11 +565,11 @@ (multiple-value-bind (xx2 yy2) (transform-position transformation x2 y2) (stream-add-output-record - *pane* (make-instance 'downward-beam-output-record + *pane* (make-instance 'upward-beam-output-record :x1 xx1 :y1 yy1 :x2 xx2 :y2 yy2 :thickness thickness :ink (medium-ink medium)))))) (when (stream-drawing-p *pane*) - (draw-downward-beam medium x1 y1 y2 thickness inverse-slope)))))) + (draw-upward-beam medium x1 y1 y2 thickness inverse-slope)))))) ;;; an offset of -1 means hang, 0 means straddle and 1 means sit (defun draw-beam (pane x1 staff-step-1 offset1 x2 staff-step-2 offset2) @@ -627,14 +612,12 @@ (*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*)) -;; (with-translation (pane 0 900) -;; (with-scaling (pane 1 -1) - ,@body ;;)) -;; (setf (sheet-direct-mirror *pane*) ,mirror) -;; (copy-from-pixmap ,pixmap 0 0 800 900 *pane* 0 0) + (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)))) (defmacro with-vertical-score-position ((pane yref) &body body)

1 0

[gsharp-cvs] CVS update: gsharp/esa.lisp
by rstrandh＠common-lisp.net 02 Aug '05

02 Aug '05

Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv26130 Modified Files: esa.lisp Log Message: More bug fixes for numeric arguments (thanks to Dave Murray) Date: Tue Aug 2 04:15:57 2005 Author: rstrandh Index: gsharp/esa.lisp diff -u gsharp/esa.lisp:1.2 gsharp/esa.lisp:1.3 --- gsharp/esa.lisp:1.2 Tue Aug 2 02:34:41 2005 +++ gsharp/esa.lisp Tue Aug 2 04:15:57 2005 @@ -105,10 +105,12 @@ (defparameter *current-gesture* nil) +(defparameter *meta-digit-table* + (loop for i from 0 to 9 + collect (list :keyboard (digit-char i) (make-modifier-state :meta)))) + (defun meta-digit (gesture) - (position gesture - '((#\0 :meta) (#\1 :meta) (#\2 :meta) (#\3 :meta) (#\4 :meta) - (#\5 :meta) (#\6 :meta) (#\7 :meta) (#\8 :meta) (#\9 :meta)) + (position gesture *meta-digit-table* :test #'event-matches-gesture-name-p)) (defun esa-read-gesture ()

1 0

[gsharp-cvs] CVS update: gsharp/esa.lisp gsharp/gui.lisp gsharp/modes.lisp gsharp/score-pane.lisp
by rstrandh＠common-lisp.net 02 Aug '05

02 Aug '05

Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv20069 Modified Files: esa.lisp gui.lisp modes.lisp score-pane.lisp Log Message: Fixed a bug in esa.lisp that made numeric arguments not work. Error messages are now displayed in the minibuffer. Some commands like forward-element, backward-element, and delete-element now accept numeric arguments. Prepared for incremental redisplay by changing inheritance of pixmap records. This is nontrivial, though, and will require some more thinking about. The best thing would be to fix McCLIM, but that looks nontrivial as well. Date: Tue Aug 2 02:34:42 2005 Author: rstrandh Index: gsharp/esa.lisp diff -u gsharp/esa.lisp:1.1 gsharp/esa.lisp:1.2 --- gsharp/esa.lisp:1.1 Mon Jul 25 11:53:28 2005 +++ gsharp/esa.lisp Tue Aug 2 02:34:41 2005 @@ -145,12 +145,12 @@ (let ((gesture (esa-read-gesture))) (cond ((event-matches-gesture-name-p gesture - '(:keyboard #\u (make-modifier-state :control))) + `(:keyboard #\u ,(make-modifier-state :control))) (let ((numarg 4)) (loop for gesture = (esa-read-gesture) while (event-matches-gesture-name-p gesture - '(:keyboard #\u (make-modifier-state :control))) + `(:keyboard #\u ,(make-modifier-state :control))) do (setf numarg (* 4 numarg)) finally (esa-unread-gesture gesture stream)) (let ((gesture (esa-read-gesture))) Index: gsharp/gui.lisp diff -u gsharp/gui.lisp:1.21 gsharp/gui.lisp:1.22 --- gsharp/gui.lisp:1.21 Mon Aug 1 01:36:56 2005 +++ gsharp/gui.lisp Tue Aug 2 02:34:41 2005 @@ -58,7 +58,7 @@ (defmethod execute-frame-command :around ((frame gsharp) command) (handler-case (call-next-method) - (gsharp-condition (condition) (message "~a~%" condition)))) + (gsharp-condition (condition) (beep) (display-message "~a" condition)))) (defmethod display-state ((frame gsharp) pane) (let ((state (input-state *application-frame*))) @@ -895,10 +895,11 @@ ;;; ;;; motion by element -(define-gsharp-command com-forward-element () - (forward-element (cursor *application-frame*))) +(define-gsharp-command com-forward-element ((count 'integer :prompt "Number of Elements")) + (loop repeat count + do (forward-element (cursor *application-frame*)))) -(define-gsharp-command com-backward-element () +(define-gsharp-command com-backward-element ((count 'integer :prompt "Number of Elements")) (backward-element (cursor *application-frame*))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -925,15 +926,17 @@ (insert-element element cursor) (forward-element cursor)))) -(define-gsharp-command com-delete-element () +(define-gsharp-command com-delete-element ((count 'integer :prompt "Number of Elements")) (let ((cursor (cursor *application-frame*))) - ;;; this will signal a condition if in last bar and - ;;; interrupt the execution of the command - (forward-element cursor) - (backward-element cursor) - (if (end-of-bar-p cursor) - (fuse-bar-with-next cursor) - (delete-element cursor)))) + (loop repeat count + do (progn + ;; this will signal a condition if in last bar and + ;; interrupt the execution of the command + (forward-element cursor) + (backward-element cursor) + (if (end-of-bar-p cursor) + (fuse-bar-with-next cursor) + (delete-element cursor)))))) (define-gsharp-command com-erase-element () (let ((cursor (cursor *application-frame*))) Index: gsharp/modes.lisp diff -u gsharp/modes.lisp:1.5 gsharp/modes.lisp:1.6 --- gsharp/modes.lisp:1.5 Mon Jul 25 13:14:37 2005 +++ gsharp/modes.lisp Tue Aug 2 02:34:41 2005 @@ -3,9 +3,9 @@ (define-command-table global-gsharp-table :inherit-from (global-esa-table keyboard-macro-table)) -(set-key 'com-forward-element 'global-gsharp-table '((#\f :control))) -(set-key 'com-backward-element 'global-gsharp-table '((#\b :control))) -(set-key 'com-delete-element 'global-gsharp-table '((#\d :control))) +(set-key `(com-forward-element ,*numeric-argument-marker*) 'global-gsharp-table '((#\f :control))) +(set-key `(com-backward-element ,*numeric-argument-marker*) 'global-gsharp-table '((#\b :control))) +(set-key `(com-delete-element ,*numeric-argument-marker*) 'global-gsharp-table '((#\d :control))) (set-key 'com-insert-measure-bar 'global-gsharp-table '(#\|)) (set-key 'com-more-dots 'global-gsharp-table '((#\.))) (set-key 'com-more-lbeams 'global-gsharp-table '((#\[))) Index: gsharp/score-pane.lisp diff -u gsharp/score-pane.lisp:1.8 gsharp/score-pane.lisp:1.9 --- gsharp/score-pane.lisp:1.8 Mon Aug 1 01:36:56 2005 +++ gsharp/score-pane.lisp Tue Aug 2 02:34:41 2005 @@ -50,7 +50,12 @@ ;;; ;;; output recording -(defclass score-output-record (displayed-output-record) +;;; we should not have to inherit from standard-boudning-rectangle, +;;; but the implementation of incremental redisplay in McCLIM assumes +;;; that this is the case for all output records participating in +;;; incremental redisplay. + +(defclass score-output-record (displayed-output-record standard-bounding-rectangle) ((parent :initarg :parent :initform nil :accessor output-record-parent) (x :initarg :x1 :initarg :x-position) (y :initarg :y1 :initarg :y-position)

1 0

← Newer
1
...
29
30
31
32
33
34
35
...
40
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

gsharp-cvs