From rstrandh at common-lisp.net Mon Jul 25 09:52:15 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Mon, 25 Jul 2005 11:52:15 +0200 (CEST) Subject: [gsharp-cvs] CVS update: gsharp/gui.lisp gsharp/modes.lisp gsharp/packages.lisp gsharp/score-pane.lisp gsharp/system.lisp Message-ID: <20050725095215.EA0E388165@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv18111 Modified Files: gui.lisp modes.lisp packages.lisp score-pane.lisp system.lisp Log Message: Climacs is now an ESA (Emacs-style application) using the new package that was abstracted out of Climacs. Date: Mon Jul 25 11:52:14 2005 Author: rstrandh Index: gsharp/gui.lisp diff -u gsharp/gui.lisp:1.18 gsharp/gui.lisp:1.19 --- gsharp/gui.lisp:1.18 Sun Aug 15 17:49:41 2004 +++ gsharp/gui.lisp Mon Jul 25 11:52:14 2005 @@ -9,81 +9,56 @@ (defvar *gsharp-frame* nil) -(defparameter *kbd-macro-recording-p* nil) -(defparameter *kbd-macro-funs* '()) - -(defparameter *accumulated-keys* '()) (defparameter *modes* (list *melody-layer-mode-table* *global-mode-table*)) -(defparameter *last-character* nil) -(defmethod dispatch-event :around ((pane score-pane:score-pane) (event key-press-event)) - (when (or (keyboard-event-character event) (keyboard-event-key-name event)) - (let ((key (list (or (keyboard-event-character event) (keyboard-event-key-name event)) - (event-modifier-state event)))) - (setf *accumulated-keys* (append *accumulated-keys* (list key))) - (setf *last-character* (char-to-unicode (car key))) - (let (dico) - (cond ((and (setf dico (find t *modes* - :key (lambda (x) - (multiple-value-bind (value exists-p prefix-p) - (dico-object x *accumulated-keys*) - (declare (ignore value prefix-p)) - exists-p)))) - (or (functionp (dico-object dico *accumulated-keys*)) - (fboundp (dico-object dico *accumulated-keys*)))) - (let ((command (dico-object dico *accumulated-keys*))) - (when *kbd-macro-recording-p* (push command *kbd-macro-funs*)) - (handler-case (funcall command) - (gsharp-condition (condition) (format *error-output* "~a~%" condition)))) - (setf *accumulated-keys* '())) - ((setf dico (find-if (lambda (x) - (multiple-value-bind (value exists-p prefix-p) - (dico-object x *accumulated-keys*) - (declare (ignore value exists-p)) - prefix-p)) - *modes*)) - nil) - (t (format *error-output* "no command for ~a~%" *accumulated-keys*) - (setf *accumulated-keys* '()) - (when *kbd-macro-recording-p* (setf *kbd-macro-funs* '() - *kbd-macro-recording-p* nil))))) - (redisplay-frame-panes *gsharp-frame*)))) +(defclass gsharp-minibuffer-pane (minibuffer-pane) + () + (:default-initargs + :height 20 :max-height 20 :min-height 20)) + +(define-command-table total-melody-table + :inherit-from (melody-table global-gsharp-table)) -(define-application-frame gsharp () +(define-application-frame gsharp (standard-application-frame + esa-frame-mixin) ((buffer :initarg :buffer :accessor buffer) (cursor :initarg :cursor :accessor cursor) (input-state :initarg :input-state :accessor input-state)) (:menu-bar menubar-command-table :height 25) (:pointer-documentation t) (:panes - (score (make-pane 'score-pane:score-pane - :width 700 :height 900 - :name "score" - :display-time :no-clear - :display-function 'display-score)) + (score (let ((win (make-pane 'score-pane:score-pane + :width 400 :height 500 + :name "score" + :display-time :no-clear + :display-function 'display-score + :command-table 'total-melody-table))) + (setf (windows *application-frame*) (list win)) + win)) (state (make-pane 'score-pane:score-pane :width 50 :height 200 :name "state" :display-function 'display-state)) (element (make-pane 'score-pane:score-pane - :width 50 :height 700 + :width 50 :height 300 :min-height 100 :max-height 20000 :name "element" :display-function 'display-element)) - (interactor :interactor :height 100 :min-height 50 :max-height 200)) + (interactor (make-pane 'gsharp-minibuffer-pane :width 900))) (:layouts (default (vertically () (horizontally () - (scrolling (:width 750 :height 900 + (scrolling (:width 750 :height 500 :min-height 400 :max-height 20000) score) (vertically () (scrolling (:width 80 :height 200) state) - (scrolling (:width 80 :height 700 - :min-height 400 :max-height 20000) + (scrolling (:width 80 :height 300 + :min-height 300 :max-height 20000) element))) - interactor)))) + interactor))) + (:top-level (esa-top-level))) (defmethod execute-frame-command :around ((frame gsharp) command) (handler-case (call-next-method) @@ -632,7 +607,7 @@ #-(or cmu sbcl) (error "write compatibility layer for RUN-PROGRAM"))) -(defun run-gsharp () +(defun run-gsharp (&key (width 900) (height 600)) (let* ((buffer (make-initialized-buffer)) (staff (car (staves buffer))) (input-state (make-input-state)) @@ -640,7 +615,8 @@ (let ((*gsharp-frame* (make-application-frame 'gsharp :buffer buffer :input-state input-state - :cursor cursor))) + :cursor cursor + :width width :height height))) (setf (staves (car (layers (car (segments buffer))))) (list staff)) (run-frame-top-level *gsharp-frame*)))) @@ -1213,21 +1189,6 @@ ((eq (aref keysig 4) :natural) (setf (aref keysig 4) :flat)) ((eq (aref keysig 0) :natural) (setf (aref keysig 0) :flat)) ((eq (aref keysig 3) :natural) (setf (aref keysig 3) :flat))))) - -;;; macro processing -(define-gsharp-command com-start-kbd-macro () - (message "defining keyboad macro~%") - (setf *kbd-macro-recording-p* t - *kbd-macro-funs* '())) - -(define-gsharp-command com-end-kbd-macro () - (message "keyboad macro defined~%") - (setf *kbd-macro-recording-p* nil - *kbd-macro-funs* (nreverse (cdr *kbd-macro-funs*)))) - -(define-gsharp-command com-call-last-kbd-macro () - (handler-case (mapc #'funcall *kbd-macro-funs*) - (gsharp-condition (condition) (format *error-output* "~a~%" condition)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Index: gsharp/modes.lisp diff -u gsharp/modes.lisp:1.3 gsharp/modes.lisp:1.4 --- gsharp/modes.lisp:1.3 Sun Aug 1 17:14:33 2004 +++ gsharp/modes.lisp Mon Jul 25 11:52:14 2005 @@ -1,86 +1,72 @@ (in-package :gsharp) -(defun transform-gesture (gesture) - (list (car gesture) (apply #'make-modifier-state (cdr gesture)))) +(define-command-table global-gsharp-table + :inherit-from (global-esa-table keyboard-macro-table)) -(defun add-keyseq (gestures command table) - (setf (dico-object table (mapcar #'transform-gesture gestures)) - command)) - - -;;; global mode table -(defparameter *global-mode-table* (make-sequence-dico :test #'equal)) - -(add-keyseq '((#\f :control)) 'com-forward-element *global-mode-table*) -(add-keyseq '((#\b :control)) 'com-backward-element *global-mode-table*) -(add-keyseq '((#\d :control)) 'com-delete-element *global-mode-table*) -(add-keyseq '((#\| :shift)) 'com-insert-measure-bar *global-mode-table*) -(add-keyseq '((#\.)) 'com-more-dots *global-mode-table*) -(add-keyseq '((#\[)) 'com-more-lbeams *global-mode-table*) -(add-keyseq '((#\])) 'com-more-rbeams *global-mode-table*) -(add-keyseq '((#\l :meta)) 'com-left *global-mode-table*) -(add-keyseq '((#\r :meta)) 'com-right *global-mode-table*) -(add-keyseq '((#\x :control) (#\( :shift)) 'com-start-kbd-macro *global-mode-table*) -(add-keyseq '((#\x :control) (#\()) 'com-start-kbd-macro *global-mode-table*) -(add-keyseq '((#\x :control) (#\) :shift)) 'com-end-kbd-macro *global-mode-table*) -(add-keyseq '((#\x :control) (#\))) 'com-end-kbd-macro *global-mode-table*) -(add-keyseq '((#\x :control) (#\e)) 'com-call-last-kbd-macro *global-mode-table*) -(add-keyseq '((#\r :control)) 'com-rotate-notehead *global-mode-table*) - -;;; melody mode table -(defparameter *melody-layer-mode-table* (make-sequence-dico :test #'equal)) - -(add-keyseq '((#\L :shift)) 'com-lower *melody-layer-mode-table*) -(add-keyseq '((#\H :shift)) 'com-higher *melody-layer-mode-table*) -(add-keyseq '((#\c)) 'com-insert-note-c *melody-layer-mode-table*) -(add-keyseq '((#\d)) 'com-insert-note-d *melody-layer-mode-table*) -(add-keyseq '((#\e)) 'com-insert-note-e *melody-layer-mode-table*) -(add-keyseq '((#\f)) 'com-insert-note-f *melody-layer-mode-table*) -(add-keyseq '((#\g)) 'com-insert-note-g *melody-layer-mode-table*) -(add-keyseq '((#\a)) 'com-insert-note-a *melody-layer-mode-table*) -(add-keyseq '((#\b)) 'com-insert-note-b *melody-layer-mode-table*) -(add-keyseq '((#\,)) 'com-insert-rest *melody-layer-mode-table*) -(add-keyseq '((#\Space)) 'com-insert-empty-cluster *melody-layer-mode-table*) -(add-keyseq '((#\C :shift)) 'com-add-note-c *melody-layer-mode-table*) -(add-keyseq '((#\D :shift)) 'com-add-note-d *melody-layer-mode-table*) -(add-keyseq '((#\E :shift)) 'com-add-note-e *melody-layer-mode-table*) -(add-keyseq '((#\F :shift)) 'com-add-note-f *melody-layer-mode-table*) -(add-keyseq '((#\G :shift)) 'com-add-note-g *melody-layer-mode-table*) -(add-keyseq '((#\A :shift)) 'com-add-note-a *melody-layer-mode-table*) -(add-keyseq '((#\B :shift)) 'com-add-note-b *melody-layer-mode-table*) -(add-keyseq '((#\p)) 'com-current-increment *melody-layer-mode-table*) -(add-keyseq '((#\n)) 'com-current-decrement *Melody-Layer-mode-table*) -(add-keyseq '((#\i) (#\.)) 'com-istate-more-dots *melody-layer-mode-table*) -(add-keyseq '((#\i) (#\[)) 'com-istate-more-lbeams *melody-layer-mode-table*) -(add-keyseq '((#\i) (#\])) 'com-istate-more-rbeams *melody-layer-mode-table*) -(add-keyseq '((#\i) (#\h)) 'com-istate-rotate-notehead *melody-layer-mode-table*) -(add-keyseq '((#\i) (#\s)) 'com-istate-rotate-stem-direction *melody-layer-mode-table*) -(add-keyseq '((#\i) (#\x) (#\.)) 'com-istate-fewer-dots *melody-layer-mode-table*) -(add-keyseq '((#\i) (#\x) (#\[)) 'com-istate-fewer-lbeams *melody-layer-mode-table*) -(add-keyseq '((#\i) (#\x) (#\])) 'com-istate-fewer-rbeams *melody-layer-mode-table*) -(add-keyseq '((#\x) (#\.)) 'com-fewer-dots *melody-layer-mode-table*) -(add-keyseq '((#\x) (#\[)) 'com-fewer-lbeams *melody-layer-mode-table*) -(add-keyseq '((#\x) (#\])) 'com-fewer-rbeams *melody-layer-mode-table*) -(add-keyseq '((#\h :control)) 'com-erase-element *melody-layer-mode-table*) -(add-keyseq '((#\h :meta)) 'com-rotate-notehead *melody-layer-mode-table*) -(add-keyseq '((#\s :meta)) 'com-rotate-stem-direction *melody-layer-mode-table*) -(add-keyseq '((#\#)) 'com-sharper *melody-layer-mode-table*) -(add-keyseq '((#\# :shift)) 'com-sharper *melody-layer-mode-table*) -(add-keyseq '((#\@ :shift)) 'com-flatter *melody-layer-mode-table*) -(add-keyseq '((#\# :meta)) 'com-more-sharps *melody-layer-mode-table*) -(add-keyseq '((#\# :meta :shift)) 'com-more-sharps *melody-layer-mode-table*) -(add-keyseq '((#\@ :meta :shift)) 'com-more-flats *melody-layer-mode-table*) -(add-keyseq '((#\u :meta)) 'com-up *melody-layer-mode-table*) -(add-keyseq '((#\d :meta)) 'com-down *melody-layer-mode-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-insert-measure-bar 'global-gsharp-table '(#\|)) +(set-key 'com-more-dots 'global-gsharp-table '((#\.))) +(set-key 'com-more-lbeams 'global-gsharp-table '((#\[))) +(set-key 'com-more-rbeams 'global-gsharp-table '((#\]))) +(set-key 'com-left 'global-gsharp-table '((#\l :meta))) +(set-key 'com-right 'global-gsharp-table '((#\r :meta))) +(set-key 'com-rotate-notehead 'global-gsharp-table '((#\r :control))) + +;;; melody table + +(define-command-table melody-table) + +(set-key 'com-lower 'melody-table '((#\L :shift))) +(set-key 'com-higher 'melody-table '((#\H :shift))) +(set-key 'com-insert-note-a 'melody-table '(#\a)) +(set-key 'com-insert-note-b 'melody-table '(#\b)) +(set-key 'com-insert-note-c 'melody-table '(#\c)) +(set-key 'com-insert-note-d 'melody-table '(#\d)) +(set-key 'com-insert-note-e 'melody-table '(#\e)) +(set-key 'com-insert-note-f 'melody-table '(#\f)) +(set-key 'com-insert-note-g 'melody-table '(#\g)) +(set-key 'com-insert-rest 'melody-table '((#\,))) +(set-key 'com-insert-empty-cluster 'melody-table '((#\Space))) +(set-key 'com-add-note-c 'melody-table '(#\C)) +(set-key 'com-add-note-d 'melody-table '(#\D)) +(set-key 'com-add-note-e 'melody-table '(#\E)) +(set-key 'com-add-note-f 'melody-table '(#\F)) +(set-key 'com-add-note-g 'melody-table '(#\G)) +(set-key 'com-add-note-a 'melody-table '(#\A)) +(set-key 'com-add-note-b 'melody-table '(#\B)) +(set-key 'com-current-increment 'melody-table '((#\p))) +(set-key 'com-current-decrement 'melody-table '((#\n))) +(set-key 'com-istate-more-dots 'melody-table '((#\i) (#\.))) +(set-key 'com-istate-more-lbeams 'melody-table '((#\i) (#\[))) +(set-key 'com-istate-more-rbeams 'melody-table '((#\i) (#\]))) +(set-key 'com-istate-rotate-notehead 'melody-table '((#\i) (#\h))) +(set-key 'com-istate-rotate-stem-direction 'melody-table '((#\i) (#\s))) +(set-key 'com-istate-fewer-dots 'melody-table '((#\i) (#\x) (#\.))) +(set-key 'com-istate-fewer-lbeams 'melody-table '((#\i) (#\x) (#\[))) +(set-key 'com-istate-fewer-rbeams 'melody-table '((#\i) (#\x) (#\]))) +(set-key 'com-fewer-dots 'melody-table '((#\x) (#\.))) +(set-key 'com-fewer-lbeams 'melody-table '((#\x) (#\[))) +(set-key 'com-fewer-rbeams 'melody-table '((#\x) (#\]))) +(set-key 'com-erase-element 'melody-table '((#\h :control))) +(set-key 'com-rotate-notehead 'melody-table '((#\h :meta))) +(set-key 'com-rotate-stem-direction 'melody-table '((#\s :meta))) +(set-key 'com-sharper 'melody-table '((#\#))) +(set-key 'com-flatter 'melody-table '(#\@)) +(set-key 'com-more-sharps 'melody-table '((#\# :meta))) +(set-key 'com-more-sharps 'melody-table '((#\# :meta :shift))) +(set-key 'com-more-flats 'melody-table '((#\@ :meta :shift))) +(set-key 'com-up 'melody-table '((#\u :meta))) +(set-key 'com-down 'melody-table '((#\d :meta))) ;;; lyrics mode table -(defparameter *lyrics-layer-mode-table* (make-sequence-dico :test #'equal)) +(define-command-table lyrics-table) -(add-keyseq '((#\h :control)) (lambda () (erase-char (cur-element))) - *lyrics-layer-mode-table*) -(add-keyseq '((#\h :meta)) 'com-erase-element *lyrics-layer-mode-table*) -(add-keyseq '((#\Space :control)) 'insert-lyrics-element *lyrics-layer-mode-table*) +(set-key (lambda () (erase-char (cur-element))) 'lyrics-table '((#\h :control))) +(set-key 'com-erase-element 'lyrics-table '((#\h :meta))) +(set-key 'insert-lyrics-element 'lyrics-table '((#\Space :control))) (defun make-insert-fun (code) @@ -89,78 +75,78 @@ (loop for c in '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z) for i from 65 - do (add-keyseq `((,c :shift)) (make-insert-fun i) *lyrics-layer-mode-table*)) + do (set-key (make-insert-fun i) 'lyrics-table `((,c :shift)))) (loop for c in '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z) for i from 97 - do (add-keyseq `((,c)) (make-insert-fun i) *lyrics-layer-mode-table*)) + do (set-key (make-insert-fun i) 'lyrics-table`((,c)))) ;;; try some latin prefix mode for national characters -(add-keyseq '((:dead--grave) (#\A :shift)) (make-insert-fun 192) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--acute) (#\A :shift)) (make-insert-fun 193) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--circumflex :shift) (#\A :shift)) (make-insert-fun 194) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--tilde :shift) (#\A :shift)) (make-insert-fun 195) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--diaeresis :shift) (#\A :shift)) (make-insert-fun 196) *lyrics-layer-mode-table*) -(add-keyseq '((:dead-above-ring) (#\A :shift)) (make-insert-fun 197) *lyrics-layer-mode-table*) -(add-keyseq '((:dead-above-ring) (#\E :shift)) (make-insert-fun 198) *lyrics-layer-mode-table*) -(add-keyseq '((:dead-above-ring) (#\C :shift)) (make-insert-fun 199) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--grave) (#\E :shift)) (make-insert-fun 200) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--acute) (#\E :shift)) (make-insert-fun 201) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--circumflex :shift) (#\E :shift)) (make-insert-fun 202) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--diaeresis :shift) (#\E :shift)) (make-insert-fun 203) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--grave) (#\I :shift)) (make-insert-fun 204) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--acute) (#\I :shift)) (make-insert-fun 205) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--circumflex :shift) (#\I :shift)) (make-insert-fun 206) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--diaeresis :shift) (#\I :shift)) (make-insert-fun 207) *lyrics-layer-mode-table*) -(add-keyseq '((:dead-above-ring) (#\D :shift)) (make-insert-fun 208) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--tilde :shift) (#\N :shift)) (make-insert-fun 209) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--grave) (#\O :shift)) (make-insert-fun 210) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--acute) (#\O :shift)) (make-insert-fun 211) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--circumflex :shift) (#\O :shift)) (make-insert-fun 212) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--tilde :shift) (#\O :shift)) (make-insert-fun 213) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--diaeresis :shift) (#\O :shift)) (make-insert-fun 214) *lyrics-layer-mode-table*) - -(add-keyseq '((:dead-above-ring) (#\O :shift)) (make-insert-fun 216) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--grave) (#\U :shift)) (make-insert-fun 217) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--acute) (#\U :shift)) (make-insert-fun 218) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--circumflex :shift) (#\U :shift)) (make-insert-fun 219) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--diaeresis :shift) (#\U :shift)) (make-insert-fun 220) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--acute) (#\Y :shift)) (make-insert-fun 221) *lyrics-layer-mode-table*) - - -(add-keyseq '((:dead--grave) (#\a)) (make-insert-fun 224) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--acute) (#\a)) (make-insert-fun 225) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--circumflex :shift) (#\a)) (make-insert-fun 226) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--tilde :shift) (#\a)) (make-insert-fun 227) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--diaeresis :shift) (#\a)) (make-insert-fun 228) *lyrics-layer-mode-table*) -(add-keyseq '((:dead-above-ring) (#\a)) (make-insert-fun 229) *lyrics-layer-mode-table*) -(add-keyseq '((:dead-above-ring) (#\e)) (make-insert-fun 230) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--tilde :shift) (#\c)) (make-insert-fun 231) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--grave) (#\e)) (make-insert-fun 232) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--acute) (#\e)) (make-insert-fun 233) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--circumflex :shift) (#\e)) (make-insert-fun 234) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--diaeresis :shift) (#\e)) (make-insert-fun 235) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--grave) (#\i)) (make-insert-fun 236) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--acute) (#\i)) (make-insert-fun 237) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--circumflex :shift) (#\i)) (make-insert-fun 238) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--diaeresis :shift) (#\i)) (make-insert-fun 239) *lyrics-layer-mode-table*) - - -(add-keyseq '((:dead--grave) (#\o)) (make-insert-fun 242) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--acute) (#\o)) (make-insert-fun 243) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--circumflex :shift) (#\o)) (make-insert-fun 244) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--tilde :shift) (#\o)) (make-insert-fun 245) *lyrics-layer-mode-table*) -(add-keyseq `((:dead--diaeresis :shift) (#\o)) (make-insert-fun 246) *lyrics-layer-mode-table*) - -(add-keyseq '((:dead-above-ring) (#\o)) (make-insert-fun 248) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--grave) (#\u)) (make-insert-fun 249) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--acute) (#\u)) (make-insert-fun 250) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--circumflex :shift) (#\u)) (make-insert-fun 251) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--diaeresis :shift) (#\u)) (make-insert-fun 252) *lyrics-layer-mode-table*) -(add-keyseq '((:dead--acute) (#\y)) (make-insert-fun 253) *lyrics-layer-mode-table*) +(set-key (make-insert-fun 192) 'lyrics-table '((:dead--grave) (#\A :shift))) +(set-key (make-insert-fun 193) 'lyrics-table '((:dead--acute) (#\A :shift))) +(set-key (make-insert-fun 194) 'lyrics-table '((:dead--circumflex :shift) (#\A :shift))) +(set-key (make-insert-fun 195) 'lyrics-table '((:dead--tilde :shift) (#\A :shift))) +(set-key (make-insert-fun 196) 'lyrics-table '((:dead--diaeresis :shift) (#\A :shift))) +(set-key (make-insert-fun 197) 'lyrics-table '((:dead-above-ring) (#\A :shift))) +(set-key (make-insert-fun 198) 'lyrics-table '((:dead-above-ring) (#\E :shift))) +(set-key (make-insert-fun 199) 'lyrics-table '((:dead-above-ring) (#\C :shift))) +(set-key (make-insert-fun 200) 'lyrics-table '((:dead--grave) (#\E :shift))) +(set-key (make-insert-fun 201) 'lyrics-table '((:dead--acute) (#\E :shift))) +(set-key (make-insert-fun 202) 'lyrics-table '((:dead--circumflex :shift) (#\E :shift))) +(set-key (make-insert-fun 203) 'lyrics-table '((:dead--diaeresis :shift) (#\E :shift))) +(set-key (make-insert-fun 204) 'lyrics-table '((:dead--grave) (#\I :shift))) +(set-key (make-insert-fun 205) 'lyrics-table '((:dead--acute) (#\I :shift))) +(set-key (make-insert-fun 206) 'lyrics-table '((:dead--circumflex :shift) (#\I :shift))) +(set-key (make-insert-fun 207) 'lyrics-table '((:dead--diaeresis :shift) (#\I :shift))) +(set-key (make-insert-fun 208) 'lyrics-table '((:dead-above-ring) (#\D :shift))) +(set-key (make-insert-fun 209) 'lyrics-table '((:dead--tilde :shift) (#\N :shift))) +(set-key (make-insert-fun 210) 'lyrics-table '((:dead--grave) (#\O :shift))) +(set-key (make-insert-fun 211) 'lyrics-table '((:dead--acute) (#\O :shift))) +(set-key (make-insert-fun 212) 'lyrics-table '((:dead--circumflex :shift) (#\O :shift))) +(set-key (make-insert-fun 213) 'lyrics-table '((:dead--tilde :shift) (#\O :shift))) +(set-key (make-insert-fun 214) 'lyrics-table '((:dead--diaeresis :shift) (#\O :shift))) + +(set-key (make-insert-fun 216) 'lyrics-table '((:dead-above-ring) (#\O :shift))) +(set-key (make-insert-fun 217) 'lyrics-table '((:dead--grave) (#\U :shift))) +(set-key (make-insert-fun 218) 'lyrics-table '((:dead--acute) (#\U :shift))) +(set-key (make-insert-fun 219) 'lyrics-table '((:dead--circumflex :shift) (#\U :shift))) +(set-key (make-insert-fun 220) 'lyrics-table '((:dead--diaeresis :shift) (#\U :shift))) +(set-key (make-insert-fun 221) 'lyrics-table '((:dead--acute) (#\Y :shift))) + + +(set-key (make-insert-fun 224) 'lyrics-table '((:dead--grave) (#\a))) +(set-key (make-insert-fun 225) 'lyrics-table '((:dead--acute) (#\a))) +(set-key (make-insert-fun 226) 'lyrics-table '((:dead--circumflex :shift) (#\a))) +(set-key (make-insert-fun 227) 'lyrics-table '((:dead--tilde :shift) (#\a))) +(set-key (make-insert-fun 228) 'lyrics-table '((:dead--diaeresis :shift) (#\a))) +(set-key (make-insert-fun 229) 'lyrics-table '((:dead-above-ring) (#\a))) +(set-key (make-insert-fun 230) 'lyrics-table '((:dead-above-ring) (#\e))) +(set-key (make-insert-fun 231) 'lyrics-table '((:dead--tilde :shift) (#\c))) +(set-key (make-insert-fun 232) 'lyrics-table '((:dead--grave) (#\e))) +(set-key (make-insert-fun 233) 'lyrics-table '((:dead--acute) (#\e))) +(set-key (make-insert-fun 234) 'lyrics-table '((:dead--circumflex :shift) (#\e))) +(set-key (make-insert-fun 235) 'lyrics-table '((:dead--diaeresis :shift) (#\e))) +(set-key (make-insert-fun 236) 'lyrics-table '((:dead--grave) (#\i))) +(set-key (make-insert-fun 237) 'lyrics-table '((:dead--acute) (#\i))) +(set-key (make-insert-fun 238) 'lyrics-table '((:dead--circumflex :shift) (#\i))) +(set-key (make-insert-fun 239) 'lyrics-table '((:dead--diaeresis :shift) (#\i))) + + +(set-key (make-insert-fun 242) 'lyrics-table '((:dead--grave) (#\o))) +(set-key (make-insert-fun 243) 'lyrics-table '((:dead--acute) (#\o))) +(set-key (make-insert-fun 244) 'lyrics-table '((:dead--circumflex :shift) (#\o))) +(set-key (make-insert-fun 245) 'lyrics-table '((:dead--tilde :shift) (#\o))) +(set-key (make-insert-fun 246) 'lyrics-table `((:dead--diaeresis :shift) (#\o))) + +(set-key (make-insert-fun 248) 'lyrics-table '((:dead-above-ring) (#\o))) +(set-key (make-insert-fun 249) 'lyrics-table '((:dead--grave) (#\u))) +(set-key (make-insert-fun 250) 'lyrics-table '((:dead--acute) (#\u))) +(set-key (make-insert-fun 251) 'lyrics-table '((:dead--circumflex :shift) (#\u))) +(set-key (make-insert-fun 252) 'lyrics-table '((:dead--diaeresis :shift) (#\u))) +(set-key (make-insert-fun 253) 'lyrics-table '((:dead--acute) (#\y))) -(add-keyseq '((:dead--diaeresis :shift) (#\y)) (make-insert-fun 255) *lyrics-layer-mode-table*) +(set-key (make-insert-fun 255) 'lyrics-table '((:dead--diaeresis :shift) (#\y))) Index: gsharp/packages.lisp diff -u gsharp/packages.lisp:1.8 gsharp/packages.lisp:1.9 --- gsharp/packages.lisp:1.8 Sat Jul 24 22:09:55 2004 +++ gsharp/packages.lisp Mon Jul 25 11:52:14 2005 @@ -1,8 +1,3 @@ -(defpackage :sequence-dico - (:use :clim-lisp) - (:export #:sequence-dico #:standard-sequence-dico - #:make-sequence-dico #:dico-object)) - (defpackage :gsharp-utilities (:shadow built-in-class) (:use :clim-lisp :clim-mop) @@ -131,8 +126,19 @@ #:quarter-rest #:8th-rest #:16th-rest #:32nd-rest #:64th-rest #:128th-rest #:measure-rest #:double-whole-rest)) +(defpackage :esa + (:use :clim-lisp :clim) + (:export #:minibuffer-pane #:display-message + #:esa-pane-mixin #:previous-command + #:info-pane #:master-pane + #:esa-frame-mixin #:windows #:recordingp #:executingp + #:*numeric-argument-p* #:*current-gesture* + #:esa-top-level #:simple-command-loop + #:global-esa-table #:keyboard-macro-table + #:set-key)) + (defpackage :score-pane - (:use :clim :clim-extensions :clim-lisp :sdl) + (:use :clim :clim-extensions :clim-lisp :sdl :esa) (:shadow #:rest) (:export #:draw-fiveline-staff #:draw-lyrics-staff #:draw-stem #:draw-right-stem #:draw-left-stem @@ -196,7 +202,7 @@ #:unknown-event #:status #:data-byte)) (defpackage :gsharp - (:use :clim :clim-lisp :gsharp-utilities + (:use :clim :clim-lisp :gsharp-utilities :esa :gsharp-buffer :gsharp-cursor :gsharp-drawing :gsharp-numbering :gsharp-measure :sdl :midi :sequence-dico) (:shadowing-import-from :gsharp-numbering #:number) Index: gsharp/score-pane.lisp diff -u gsharp/score-pane.lisp:1.6 gsharp/score-pane.lisp:1.7 --- gsharp/score-pane.lisp:1.6 Fri Jul 23 18:51:16 2004 +++ gsharp/score-pane.lisp Mon Jul 25 11:52:14 2005 @@ -2,7 +2,7 @@ (defclass score-view (view) ()) -(defclass score-pane (application-pane) +(defclass score-pane (esa-pane-mixin application-pane) ((pixmaps :initform (make-hash-table :test #'eq) :reader pane-pixmaps) (darker-gray-progressions :initform (make-array 10 :initial-element nil :adjustable t) :reader darker-gray-progressions) Index: gsharp/system.lisp diff -u gsharp/system.lisp:1.5 gsharp/system.lisp:1.6 --- gsharp/system.lisp:1.5 Thu Jun 2 13:52:37 2005 +++ gsharp/system.lisp Mon Jul 25 11:52:14 2005 @@ -22,7 +22,6 @@ (gsharp-defsystem (:gsharp :depends-on (:mcclim)) "packages" - "sequence-dico" "utilities" "gf" "sdl" @@ -40,4 +39,5 @@ "input-state" "midi" "modes" + "esa" "gui") From rstrandh at common-lisp.net Mon Jul 25 09:53:28 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Mon, 25 Jul 2005 11:53:28 +0200 (CEST) Subject: [gsharp-cvs] CVS update: gsharp/esa.lisp Message-ID: <20050725095328.2F28E88165@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv18153 Added Files: esa.lisp Log Message: I am adding this file, even though that will make it duplacated in Climacs and Gsharp. Later, I'll find a different place to put it that is common between the two. Date: Mon Jul 25 11:53:28 2005 Author: rstrandh From rstrandh at common-lisp.net Mon Jul 25 11:14:39 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Mon, 25 Jul 2005 13:14:39 +0200 (CEST) Subject: [gsharp-cvs] CVS update: gsharp/gui.lisp gsharp/modes.lisp gsharp/packages.lisp gsharp/system.lisp Message-ID: <20050725111439.60EC0880DF@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv23448 Modified Files: gui.lisp modes.lisp packages.lisp system.lisp Log Message: fixed some minor problems Date: Mon Jul 25 13:14:38 2005 Author: rstrandh Index: gsharp/gui.lisp diff -u gsharp/gui.lisp:1.19 gsharp/gui.lisp:1.20 --- gsharp/gui.lisp:1.19 Mon Jul 25 11:52:14 2005 +++ gsharp/gui.lisp Mon Jul 25 13:14:37 2005 @@ -9,8 +9,6 @@ (defvar *gsharp-frame* nil) -(defparameter *modes* (list *melody-layer-mode-table* *global-mode-table*)) - (defclass gsharp-minibuffer-pane (minibuffer-pane) () (:default-initargs @@ -426,9 +424,8 @@ (if success layer (error 'no-such-layer)))) (defmethod select-layer :after (cursor (layer layer)) - (setf *modes* (list (cond ((typep layer 'melody-layer) *melody-layer-mode-table*) - ((typep layer 'lyrics-layer) *lyrics-layer-mode-table*)) - *global-mode-table*))) + ;; set the command tables here + ) (define-gsharp-command (com-select-layer :name t) () (let ((selected-layer (accept 'layer :prompt "Select layer"))) Index: gsharp/modes.lisp diff -u gsharp/modes.lisp:1.4 gsharp/modes.lisp:1.5 --- gsharp/modes.lisp:1.4 Mon Jul 25 11:52:14 2005 +++ gsharp/modes.lisp Mon Jul 25 13:14:37 2005 @@ -13,13 +13,14 @@ (set-key 'com-left 'global-gsharp-table '((#\l :meta))) (set-key 'com-right 'global-gsharp-table '((#\r :meta))) (set-key 'com-rotate-notehead 'global-gsharp-table '((#\r :control))) +(set-key 'com-load-file 'global-gsharp-table '((#\x :control) (#\f :control))) ;;; melody table (define-command-table melody-table) -(set-key 'com-lower 'melody-table '((#\L :shift))) -(set-key 'com-higher 'melody-table '((#\H :shift))) +(set-key 'com-lower 'melody-table '(#\L)) +(set-key 'com-higher 'melody-table '(#\H)) (set-key 'com-insert-note-a 'melody-table '(#\a)) (set-key 'com-insert-note-b 'melody-table '(#\b)) (set-key 'com-insert-note-c 'melody-table '(#\c)) Index: gsharp/packages.lisp diff -u gsharp/packages.lisp:1.9 gsharp/packages.lisp:1.10 --- gsharp/packages.lisp:1.9 Mon Jul 25 11:52:14 2005 +++ gsharp/packages.lisp Mon Jul 25 13:14:38 2005 @@ -204,7 +204,7 @@ (defpackage :gsharp (:use :clim :clim-lisp :gsharp-utilities :esa :gsharp-buffer :gsharp-cursor :gsharp-drawing :gsharp-numbering - :gsharp-measure :sdl :midi :sequence-dico) + :gsharp-measure :sdl :midi) (:shadowing-import-from :gsharp-numbering #:number) (:shadowing-import-from :gsharp-buffer #:rest)) Index: gsharp/system.lisp diff -u gsharp/system.lisp:1.6 gsharp/system.lisp:1.7 --- gsharp/system.lisp:1.6 Mon Jul 25 11:52:14 2005 +++ gsharp/system.lisp Mon Jul 25 13:14:38 2005 @@ -22,6 +22,7 @@ (gsharp-defsystem (:gsharp :depends-on (:mcclim)) "packages" + "esa" "utilities" "gf" "sdl" @@ -39,5 +40,4 @@ "input-state" "midi" "modes" - "esa" "gui") From strandh at labri.fr Mon Jul 25 16:16:31 2005 From: strandh at labri.fr (Robert Strandh) Date: Mon, 25 Jul 2005 18:16:31 +0200 Subject: [gsharp-cvs] CVS update: gsharp/gui.lisp gsharp/modes.lisp gsharp/packages.lisp gsharp/score-pane.lisp gsharp/system.lisp In-Reply-To: <20050725095215.EA0E388165@common-lisp.net> References: <20050725095215.EA0E388165@common-lisp.net> Message-ID: <17125.4191.93884.935351@serveur5.labri.fr> Robert Strandh writes: > Climacs is now an ESA (Emacs-style application) using the new package that > was abstracted out of Climacs. I meant to say that `Gsharp' is now an ESA. -- Robert Strandh --------------------------------------------------------------------- Greenspun's Tenth Rule of Programming: any sufficiently complicated C or Fortran program contains an ad hoc informally-specified bug-ridden slow implementation of half of Common Lisp. --------------------------------------------------------------------- From rstrandh at common-lisp.net Sun Jul 31 23:36:59 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Mon, 1 Aug 2005 01:36:59 +0200 (CEST) Subject: [gsharp-cvs] CVS update: gsharp/drawing.lisp gsharp/gui.lisp gsharp/score-pane.lisp gsharp/sdl.lisp Message-ID: <20050731233659.BC67E88526@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv18655 Modified Files: drawing.lisp gui.lisp score-pane.lisp sdl.lisp Log Message: Changed the sheet transformation of the score pane to be the default for CLIM stream panes (0,0) in the upper-left corner. This was in order to simplify the rest of the code, and in particular the output recording stuff. There are probably some edge cases that don't yet work like they are supposed to with the possibility of off-by-a-pixel errors. Removed all the rectangle output records in favor of calls to draw-rectangle*. Temporarily removed the double buffering as a preparation for better seeing what is going on with incremental redisplay. Getting incremental redisplay to work might require fixing a problem in McCLIM which does not necessarily rely on the output-record protocol, but instead sometimes assume the existence of a slot in the record, whereas no such slot is required by the specification. The result is that the user cannot define his or her own output records and have them work with incremental redisplay. Date: Mon Aug 1 01:36:57 2005 Author: rstrandh Index: gsharp/drawing.lisp diff -u gsharp/drawing.lisp:1.8 gsharp/drawing.lisp:1.9 --- gsharp/drawing.lisp:1.8 Sat Jul 24 22:09:55 2004 +++ gsharp/drawing.lisp Mon Aug 1 01:36:56 2005 @@ -117,7 +117,7 @@ (draw-measure pane measure min-dist compress x method draw-cursor) (incf x width) (score-pane:draw-bar-line pane x - (score-pane:staff-step 8) + (- (score-pane:staff-step 8)) (staff-yoffset (car (last staves))))))) (defmethod draw-buffer (pane (buffer buffer) *cursor* x y draw-cursor) @@ -141,7 +141,8 @@ (- (line-width old-method) timesig-offset)))) (right-edge (right-edge buffer))) (loop for staff in staves - for offset downfrom 0 by 90 do + for offset from 0 by 90 do +;; for offset downfrom 0 by 90 do (setf (staff-yoffset staff) offset)) (let ((yy y)) (gsharp-measure::new-map-over-obseq-subsequences @@ -151,7 +152,7 @@ (draw-system pane measures (+ x (left-offset buffer) timesig-offset) widths method staves draw-cursor) (score-pane:draw-bar-line pane x - (score-pane:staff-step 8) + (- (score-pane:staff-step 8)) (staff-yoffset (car (last staves))))) (loop for staff in staves do (score-pane:with-vertical-score-position (pane yy) @@ -159,7 +160,7 @@ (draw-staff-and-clef pane staff x right-edge) (score-pane:with-light-glyphs pane (draw-staff-and-clef pane staff x right-edge)))) - (decf yy 90)))) + (incf yy 90)))) buffer))))) (define-added-mixin velement () melody-element @@ -367,7 +368,7 @@ (draw-element pane element (element-xpos element) nil)))))) (defun draw-cursor (pane x) - (draw-line* pane x (score-pane:staff-step -4) x (score-pane:staff-step 12) :ink +red+)) + (draw-line* pane x (- (score-pane:staff-step -4)) x (- (score-pane:staff-step 12)) :ink +red+)) (defmethod draw-bar (pane (bar melody-bar) x width time-alist draw-cursor) (compute-element-x-positions bar x time-alist) @@ -619,11 +620,11 @@ (unless (eq (notehead element) :whole) (if (eq direction :up) (score-pane:draw-right-stem pane x - (+ (score-pane:staff-step min-pos) min-yoffset) - (+ (score-pane:staff-step stem-pos) stem-yoffset)) + (- min-yoffset (score-pane:staff-step min-pos)) + (- stem-yoffset (score-pane:staff-step stem-pos))) (score-pane:draw-left-stem pane x - (+ (score-pane:staff-step max-pos) max-yoffset) - (+ (score-pane:staff-step stem-pos) stem-yoffset))))))) + (- max-yoffset (score-pane:staff-step max-pos)) + (- stem-yoffset (score-pane:staff-step stem-pos)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Index: gsharp/gui.lisp diff -u gsharp/gui.lisp:1.20 gsharp/gui.lisp:1.21 --- gsharp/gui.lisp:1.20 Mon Jul 25 13:14:37 2005 +++ gsharp/gui.lisp Mon Aug 1 01:36:56 2005 @@ -7,8 +7,6 @@ (bar (barno slice 0))) (make-cursor bar 0))) -(defvar *gsharp-frame* nil) - (defclass gsharp-minibuffer-pane (minibuffer-pane) () (:default-initargs @@ -28,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)) @@ -63,7 +61,7 @@ (gsharp-condition (condition) (message "~a~%" condition)))) (defmethod display-state ((frame gsharp) pane) - (let ((state (input-state *gsharp-frame*))) + (let ((state (input-state *application-frame*))) (score-pane:with-score-pane pane (score-pane:with-staff-size 10 (score-pane:with-vertical-score-position (pane 800) @@ -103,8 +101,8 @@ (score-pane:draw-dot pane (+ xpos dx) 4))))))))) (defun draw-the-cursor (pane x) - (let* ((state (input-state *gsharp-frame*)) - (staff (car (staves (layer (cursor *gsharp-frame*))))) + (let* ((state (input-state *application-frame*)) + (staff (car (staves (layer (cursor *application-frame*))))) (yoffset (gsharp-drawing::staff-yoffset staff))) (if (typep staff 'fiveline-staff) (let* ((clef (clef staff)) @@ -112,24 +110,24 @@ (lineno clef))) (lnote-offset (score-pane:staff-step (- (last-note state) bottom-line)))) (draw-line* pane - x (+ (score-pane:staff-step 12) yoffset) - x (+ (score-pane:staff-step -4) yoffset) + x (- (+ (score-pane:staff-step 12) yoffset)) + x (- (+ (score-pane:staff-step -4) yoffset)) :ink +yellow+) (draw-line* pane - (- x 1) (+ (score-pane:staff-step -3.4) yoffset lnote-offset) - (- x 1) (+ (score-pane:staff-step 3.6) yoffset lnote-offset) + (- x 1) (- (+ (score-pane:staff-step -3.4) yoffset lnote-offset)) + (- x 1) (- (+ (score-pane:staff-step 3.6) yoffset lnote-offset)) :ink +red+) (draw-line* pane - (+ x 1) (+ (score-pane:staff-step -3.4) yoffset lnote-offset) - (+ x 1) (+ (score-pane:staff-step 3.6) yoffset lnote-offset) + (+ x 1) (- (+ (score-pane:staff-step -3.4) yoffset lnote-offset)) + (+ x 1) (- (+ (score-pane:staff-step 3.6) yoffset lnote-offset)) :ink +red+)) (progn (draw-line* pane - (+ x 1) (+ (score-pane:staff-step 2) yoffset) - (+ x 1) (+ (score-pane:staff-step -2) yoffset) + (+ x 1) (- (+ (score-pane:staff-step 2) yoffset)) + (+ x 1) (- (+ (score-pane:staff-step -2) yoffset)) :ink +red+) (draw-line* pane - (- x 1) (+ (score-pane:staff-step 2) yoffset) - (- x 1) (+ (score-pane:staff-step -2) yoffset) + (- x 1) (- (+ (score-pane:staff-step 2) yoffset)) + (- x 1) (- (+ (score-pane:staff-step -2) yoffset)) :ink +red+))))) (defmethod display-score ((frame gsharp) pane) @@ -137,8 +135,8 @@ (recompute-measures buffer) (score-pane:with-score-pane pane (flet ((draw-cursor (x) (draw-the-cursor pane x))) - (draw-buffer pane buffer (cursor *gsharp-frame*) - (left-margin buffer) 800 #'draw-cursor))))) + (draw-buffer pane buffer (cursor *application-frame*) + (left-margin buffer) 100 #'draw-cursor))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -220,9 +218,9 @@ (cursor (make-initial-cursor buffer)) (staff (car (staves buffer))) (input-state (make-input-state))) - (setf (buffer *gsharp-frame*) buffer - (cursor *gsharp-frame*) cursor - (input-state *gsharp-frame*) input-state + (setf (buffer *application-frame*) buffer + (cursor *application-frame*) cursor + (input-state *application-frame*) input-state (staves (car (layers (car (segments buffer))))) (list staff)))) (define-presentation-type completable-pathname () @@ -306,26 +304,26 @@ (or pathname string))) (define-gsharp-command (com-load-file :name t) () - (let* ((stream (frame-standard-input *gsharp-frame*)) + (let* ((stream (frame-standard-input *application-frame*)) (filename (handler-case (accept 'completable-pathname :stream stream :prompt "File Name") (simple-parse-error () (error 'file-not-found)))) (buffer (read-everything filename)) (input-state (make-input-state)) (cursor (make-initial-cursor buffer))) - (setf (buffer *gsharp-frame*) buffer - (input-state *gsharp-frame*) input-state - (cursor *gsharp-frame*) cursor) - (number-all (buffer *gsharp-frame*)) - (select-layer cursor (car (layers (segment (cursor *gsharp-frame*))))))) + (setf (buffer *application-frame*) buffer + (input-state *application-frame*) input-state + (cursor *application-frame*) cursor) + (number-all (buffer *application-frame*)) + (select-layer cursor (car (layers (segment (cursor *application-frame*))))))) (define-gsharp-command (com-save-buffer-as :name t) () - (let* ((stream (frame-standard-input *gsharp-frame*)) + (let* ((stream (frame-standard-input *application-frame*)) (filename (handler-case (accept 'completable-pathname :stream stream :prompt "File Name") (simple-parse-error () (error 'file-not-found))))) (with-open-file (stream filename :direction :output) - (save-buffer-to-stream (buffer *gsharp-frame*) stream) + (save-buffer-to-stream (buffer *application-frame*) stream) (message "Saved buffer to ~A~%" filename)))) (define-gsharp-command (com-quit :name t) () @@ -355,23 +353,23 @@ ("Insert Before Current" :command com-insert-segment-before))) (define-gsharp-command (com-forward-segment :name t) () - (forward-segment (cursor *gsharp-frame*))) + (forward-segment (cursor *application-frame*))) (define-gsharp-command (com-backward-segment :name t) () - (backward-segment (cursor *gsharp-frame*))) + (backward-segment (cursor *application-frame*))) (define-gsharp-command (com-delete-segment :name t) () - (delete-segment (cursor *gsharp-frame*))) + (delete-segment (cursor *application-frame*))) (define-gsharp-command (com-insert-segment-before :name t) () - (let ((cursor (cursor *gsharp-frame*))) - (insert-segment-before (make-initialized-segment (car (staves (buffer *gsharp-frame*)))) + (let ((cursor (cursor *application-frame*))) + (insert-segment-before (make-initialized-segment (car (staves (buffer *application-frame*)))) cursor) (backward-segment cursor))) (define-gsharp-command (com-insert-segment-after :name t) () - (let ((cursor (cursor *gsharp-frame*))) - (insert-segment-after (make-initialized-segment (car (staves (buffer *gsharp-frame*)))) + (let ((cursor (cursor *application-frame*))) + (insert-segment-after (make-initialized-segment (car (staves (buffer *application-frame*)))) cursor) (forward-segment cursor))) @@ -395,7 +393,7 @@ (defun acquire-unique-layer-name (prompt) (let ((name (accept 'string :prompt prompt))) - (assert (not (member name (layers (segment (cursor *gsharp-frame*))) + (assert (not (member name (layers (segment (cursor *application-frame*))) :test #'string= :key #'name)) () `layer-name-not-unique) name)) @@ -413,7 +411,7 @@ (lambda (so-far mode) (complete-from-possibilities so-far - (layers (segment (cursor *gsharp-frame*))) + (layers (segment (cursor *application-frame*))) '() :action mode :predicate (constantly t) @@ -429,7 +427,7 @@ (define-gsharp-command (com-select-layer :name t) () (let ((selected-layer (accept 'layer :prompt "Select layer"))) - (select-layer (cursor *gsharp-frame*) selected-layer))) + (select-layer (cursor *application-frame*) selected-layer))) (define-gsharp-command (com-rename-layer :name t) () (setf (name (accept 'layer :prompt "Rename layer")) @@ -439,11 +437,11 @@ (let* ((name (acquire-unique-layer-name "Name of new layer")) (staff (accept 'score-pane:staff :prompt "Initial staff of new layer")) (new-layer (make-layer name staff))) - (add-layer new-layer (segment (cursor *gsharp-frame*))) - (select-layer (cursor *gsharp-frame*) new-layer))) + (add-layer new-layer (segment (cursor *application-frame*))) + (select-layer (cursor *application-frame*) new-layer))) (define-gsharp-command (com-delete-layer :name t) () - (delete-layer (cursor *gsharp-frame*))) + (delete-layer (cursor *application-frame*))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -457,19 +455,19 @@ ("Tail" :command com-tail-slisce))) (define-gsharp-command (com-head-slice :name t) () - (head-slice (cursor *gsharp-frame*))) + (head-slice (cursor *application-frame*))) (define-gsharp-command (com-body-slice :name t) () - (body-slice (cursor *gsharp-frame*))) + (body-slice (cursor *application-frame*))) (define-gsharp-command (com-tail-slice :name t) () - (tail-slice (cursor *gsharp-frame*))) + (tail-slice (cursor *application-frame*))) (define-gsharp-command (com-forward-slice :name t) () - (forward-slice (cursor *gsharp-frame*))) + (forward-slice (cursor *application-frame*))) (define-gsharp-command (com-backward-slice :name t) () - (backward-slice (cursor *gsharp-frame*))) + (backward-slice (cursor *application-frame*))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -482,10 +480,10 @@ ("Backward" :command com-backward-measure))) (define-gsharp-command (com-forward-measure :name t) () - (forward-bar (cursor *gsharp-frame*))) + (forward-bar (cursor *application-frame*))) (define-gsharp-command (com-backward-measure :name t) () - (backward-bar (cursor *gsharp-frame*))) + (backward-bar (cursor *application-frame*))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -509,7 +507,7 @@ :menu '(("Rotate" :command com-rotate-staves))) (define-gsharp-command (com-rotate-staves :name t) () - (let ((layer (layer (cursor *gsharp-frame*)))) + (let ((layer (layer (cursor *application-frame*)))) (setf (staves layer) (append (cdr (staves layer)) (list (car (staves layer))))))) @@ -571,7 +569,7 @@ (bars slice) durations)))) (define-gsharp-command (com-play-segment :name t) () - (let* ((slices (mapcar #'body (layers (car (segments (buffer *gsharp-frame*)))))) + (let* ((slices (mapcar #'body (layers (car (segments (buffer *application-frame*)))))) (durations (measure-durations slices)) (tracks (loop for slice in slices for i from 0 @@ -589,7 +587,7 @@ (error "write compatibility layer for RUN-PROGRAM"))) (define-gsharp-command (com-play-layer :name t) () - (let* ((slice (body (layer (cursor *gsharp-frame*)))) + (let* ((slice (body (layer (cursor *application-frame*)))) (durations (measure-durations (list slice))) (tracks (list (track-from-slice slice 0 durations))) (midifile (make-instance 'midifile @@ -609,13 +607,13 @@ (staff (car (staves buffer))) (input-state (make-input-state)) (cursor (make-initial-cursor buffer))) - (let ((*gsharp-frame* (make-application-frame 'gsharp + (let ((*application-frame* (make-application-frame 'gsharp :buffer buffer :input-state input-state :cursor cursor :width width :height height))) (setf (staves (car (layers (car (segments buffer))))) (list staff)) - (run-frame-top-level *gsharp-frame*)))) + (run-frame-top-level *application-frame*)))) ;; (defun run-gsharp () ;; (loop for port in climi::*all-ports* @@ -625,20 +623,20 @@ ;; (staff (car (staves buffer))) ;; (input-state (make-input-state)) ;; (cursor (make-initial-cursor buffer))) -;; (setf *gsharp-frame* (make-application-frame 'gsharp +;; (setf *application-frame* (make-application-frame 'gsharp ;; :buffer buffer ;; :input-state input-state ;; :cursor cursor) ;; (staves (car (layers (car (segments buffer))))) (list staff))) -;; (run-frame-top-level *gsharp-frame*)) +;; (run-frame-top-level *application-frame*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; note insertion commands (defun insert-cluster () - (let* ((state (input-state *gsharp-frame*)) - (cursor (cursor *gsharp-frame*)) + (let* ((state (input-state *application-frame*)) + (cursor (cursor *application-frame*)) (cluster (make-cluster (if (eq (notehead state) :filled) (rbeams state) 0) (if (eq (notehead state) :filled) (lbeams state) 0) (dots state) @@ -652,7 +650,7 @@ (defparameter *current-note* nil) (defun insert-note (pitch cluster) - (let* ((state (input-state *gsharp-frame*)) + (let* ((state (input-state *application-frame*)) (staff (car (staves (layer (slice (bar cluster)))))) (note (make-note pitch staff @@ -664,7 +662,7 @@ (add-note cluster note))) (defun compute-and-adjust-note (pitch) - (let* ((state (input-state *gsharp-frame*)) + (let* ((state (input-state *application-frame*)) (old-pitch (mod (last-note state) 7)) (diff (- pitch old-pitch))) (incf (last-note state) @@ -698,13 +696,13 @@ (insert-numbered-note-new-cluster 4)) (define-gsharp-command com-insert-rest () - (let* ((state (input-state *gsharp-frame*)) - (cursor (cursor *gsharp-frame*)) + (let* ((state (input-state *application-frame*)) + (cursor (cursor *application-frame*)) (rest (make-rest (if (eq (notehead state) :filled) (rbeams state) 0) (if (eq (notehead state) :filled) (lbeams state) 0) (dots state) (notehead state) - (car (staves (layer (cursor *gsharp-frame*))))))) + (car (staves (layer (cursor *application-frame*))))))) (insert-element rest cursor) (forward-element cursor) rest)) @@ -713,10 +711,10 @@ (insert-cluster)) (defun cur-cluster () - (current-cluster (cursor *gsharp-frame*))) + (current-cluster (cursor *application-frame*))) (defun cur-element () - (current-element (cursor *gsharp-frame*))) + (current-element (cursor *application-frame*))) (defun cur-note () (let ((cluster (cur-cluster))) @@ -821,7 +819,7 @@ (notehead (notehead element)) (staff-pos (staff-pos element)) (staff (staff element)) - (cursor (cursor *gsharp-frame*))) + (cursor (cursor *application-frame*))) (backward-element cursor) (delete-element cursor) (insert-element (make-instance 'rest @@ -849,7 +847,7 @@ (notehead (notehead element)) (staff-pos (staff-pos element)) (staff (staff element)) - (cursor (cursor *gsharp-frame*))) + (cursor (cursor *application-frame*))) (backward-element cursor) (delete-element cursor) (insert-element (make-instance 'rest @@ -898,10 +896,10 @@ ;;; motion by element (define-gsharp-command com-forward-element () - (forward-element (cursor *gsharp-frame*))) + (forward-element (cursor *application-frame*))) (define-gsharp-command com-backward-element () - (backward-element (cursor *gsharp-frame*))) + (backward-element (cursor *application-frame*))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -928,7 +926,7 @@ (forward-element cursor)))) (define-gsharp-command com-delete-element () - (let ((cursor (cursor *gsharp-frame*))) + (let ((cursor (cursor *application-frame*))) ;;; this will signal a condition if in last bar and ;;; interrupt the execution of the command (forward-element cursor) @@ -938,7 +936,7 @@ (delete-element cursor)))) (define-gsharp-command com-erase-element () - (let ((cursor (cursor *gsharp-frame*))) + (let ((cursor (cursor *application-frame*))) (backward-element cursor) (if (end-of-bar-p cursor) (fuse-bar-with-next cursor) @@ -949,39 +947,39 @@ ;;; Input State Settings (define-gsharp-command com-istate-more-dots () - (setf (dots (input-state *gsharp-frame*)) - (min (1+ (dots (input-state *gsharp-frame*))) 3))) + (setf (dots (input-state *application-frame*)) + (min (1+ (dots (input-state *application-frame*))) 3))) (define-gsharp-command com-istate-fewer-dots () - (setf (dots (input-state *gsharp-frame*)) - (max (1- (dots (input-state *gsharp-frame*))) 0))) + (setf (dots (input-state *application-frame*)) + (max (1- (dots (input-state *application-frame*))) 0))) (define-gsharp-command com-istate-more-rbeams () - (setf (rbeams (input-state *gsharp-frame*)) - (min (1+ (rbeams (input-state *gsharp-frame*))) 3))) + (setf (rbeams (input-state *application-frame*)) + (min (1+ (rbeams (input-state *application-frame*))) 3))) (define-gsharp-command com-istate-fewer-lbeams () - (setf (lbeams (input-state *gsharp-frame*)) - (max (1- (lbeams (input-state *gsharp-frame*))) 0))) + (setf (lbeams (input-state *application-frame*)) + (max (1- (lbeams (input-state *application-frame*))) 0))) (define-gsharp-command com-istate-more-lbeams () - (setf (lbeams (input-state *gsharp-frame*)) - (min (1+ (lbeams (input-state *gsharp-frame*))) 3))) + (setf (lbeams (input-state *application-frame*)) + (min (1+ (lbeams (input-state *application-frame*))) 3))) (define-gsharp-command com-istate-fewer-rbeams () - (setf (rbeams (input-state *gsharp-frame*)) - (max (1- (rbeams (input-state *gsharp-frame*))) 0))) + (setf (rbeams (input-state *application-frame*)) + (max (1- (rbeams (input-state *application-frame*))) 0))) (define-gsharp-command com-istate-rotate-notehead () - (setf (notehead (input-state *gsharp-frame*)) - (ecase (notehead (input-state *gsharp-frame*)) + (setf (notehead (input-state *application-frame*)) + (ecase (notehead (input-state *application-frame*)) (:whole :half) (:half :filled) (:filled :whole)))) (define-gsharp-command com-istate-rotate-stem-direction () - (setf (stem-direction (input-state *gsharp-frame*)) - (ecase (stem-direction (input-state *gsharp-frame*)) + (setf (stem-direction (input-state *application-frame*)) + (ecase (stem-direction (input-state *application-frame*)) (:auto :up) (:up :down) (:down :auto)))) @@ -993,13 +991,13 @@ (setf (clef staff) (make-clef type line)))) (define-gsharp-command com-higher () - (incf (last-note (input-state *gsharp-frame*)) 7)) + (incf (last-note (input-state *application-frame*)) 7)) (define-gsharp-command com-lower () - (decf (last-note (input-state *gsharp-frame*)) 7)) + (decf (last-note (input-state *application-frame*)) 7)) (define-gsharp-command com-insert-measure-bar () - (let ((cursor (cursor *gsharp-frame*)) + (let ((cursor (cursor *application-frame*)) (elements '())) (loop until (end-of-bar-p cursor) do (push (cursor-element cursor) elements) @@ -1026,7 +1024,7 @@ (lambda (so-far mode) (complete-from-possibilities so-far - (staves (buffer *gsharp-frame*)) + (staves (buffer *application-frame*)) '() :action mode :predicate (constantly t) @@ -1043,7 +1041,7 @@ (lambda (so-far mode) (complete-from-possibilities so-far - (staves (buffer *gsharp-frame*)) + (staves (buffer *application-frame*)) '() :action mode :predicate (lambda (obj) (typep obj 'fiveline-staff)) @@ -1110,7 +1108,7 @@ (defun acquire-unique-staff-name (prompt) (let ((name (accept 'string :prompt prompt))) - (assert (not (member name (staves (buffer *gsharp-frame*)) :test #'string= :key #'name)) + (assert (not (member name (staves (buffer *application-frame*)) :test #'string= :key #'name)) () `staff-name-not-unique) name)) @@ -1125,36 +1123,36 @@ (define-gsharp-command (com-insert-staff-before :name t) () (add-staff-before-staff (accept 'score-pane:staff :prompt "Insert staff before staff") (acquire-new-staff) - (buffer *gsharp-frame*))) + (buffer *application-frame*))) (define-gsharp-command (com-insert-staff-after :name t) () (add-staff-after-staff (accept 'score-pane:staff :prompt "Insert staff after staff") (acquire-new-staff) - (buffer *gsharp-frame*))) + (buffer *application-frame*))) (define-gsharp-command (com-delete-staff :name t) () (remove-staff-from-buffer (accept 'score-pane:staff :prompt "Staff") - (buffer *gsharp-frame*))) + (buffer *application-frame*))) (define-gsharp-command (com-rename-staff :name t) () (let* ((staff (accept 'score-pane:staff :prompt "Rename staff")) (name (acquire-unique-staff-name "New name of staff")) - (buffer (buffer *gsharp-frame*))) + (buffer (buffer *application-frame*))) (rename-staff name staff buffer))) (define-gsharp-command (com-add-staff-to-layer :name t) () (let ((staff (accept 'score-pane:staff :prompt "Add staff to layer")) - (layer (layer (cursor *gsharp-frame*)))) + (layer (layer (cursor *application-frame*)))) (add-staff-to-layer staff layer))) ;;; FIXME restrict to staves that are actually in the layer. (define-gsharp-command (com-delete-staff-from-layer :name t) () (let ((staff (accept 'score-pane:staff :prompt "Add staff to layer")) - (layer (layer (cursor *gsharp-frame*)))) + (layer (layer (cursor *application-frame*)))) (remove-staff-from-layer staff layer))) (define-gsharp-command com-more-sharps () - (let ((keysig (keysig (car (staves (layer (cursor *gsharp-frame*))))))) + (let ((keysig (keysig (car (staves (layer (cursor *application-frame*))))))) (cond ((eq (aref keysig 3) :flat) (setf (aref keysig 3) :natural)) ((eq (aref keysig 0) :flat) (setf (aref keysig 0) :natural)) ((eq (aref keysig 4) :flat) (setf (aref keysig 4) :natural)) @@ -1171,7 +1169,7 @@ ((eq (aref keysig 6) :natural) (setf (aref keysig 6) :sharp))))) (define-gsharp-command com-more-flats () - (let ((keysig (keysig (car (staves (layer (cursor *gsharp-frame*))))))) + (let ((keysig (keysig (car (staves (layer (cursor *application-frame*))))))) (cond ((eq (aref keysig 6) :sharp) (setf (aref keysig 6) :natural)) ((eq (aref keysig 2) :sharp) (setf (aref keysig 2) :natural)) ((eq (aref keysig 5) :sharp) (setf (aref keysig 5) :natural)) @@ -1192,14 +1190,14 @@ ;;; Lyrics (defun insert-lyrics-element () - (let* ((state (input-state *gsharp-frame*)) - (cursor (cursor *gsharp-frame*)) + (let* ((state (input-state *application-frame*)) + (cursor (cursor *application-frame*)) (element (make-lyrics-element (if (eq (notehead state) :filled) (rbeams state) 0) (if (eq (notehead state) :filled) (lbeams state) 0) (dots state) (notehead state) - (car (staves (layer (cursor *gsharp-frame*))))))) + (car (staves (layer (cursor *application-frame*))))))) (insert-element element cursor) (forward-element cursor) element)) Index: gsharp/score-pane.lisp diff -u gsharp/score-pane.lisp:1.7 gsharp/score-pane.lisp:1.8 --- gsharp/score-pane.lisp:1.7 Mon Jul 25 11:52:14 2005 +++ gsharp/score-pane.lisp Mon Aug 1 01:36:56 2005 @@ -103,36 +103,6 @@ (with-bounding-rectangle* (x1 y1 x2 y2) record (region-intersects-region-p region (make-rectangle* x1 y1 x2 y2)))) -;;;;;;;;;;;;;;;;;; rectangle output record - -(defclass rectangle-output-record (score-output-record) - ()) - -(defmethod replay-output-record ((record rectangle-output-record) stream - &optional (region +everywhere+) - (x-offset 0) (y-offset 0)) - (declare (ignore x-offset y-offset region)) - (with-bounding-rectangle* (x1 y1 x2 y2) record - (with-slots (ink) record - (let ((medium (sheet-medium stream))) - (with-drawing-options (medium :ink ink) - (medium-draw-rectangle* medium x1 y1 x2 y2 t)))))) - -(defun make-rectangle-record (class medium x1 y1 x2 y2) - (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 (min x1 x2) :x2 (max x1 x2) - :y1 (min y1 y2) :y2 (max y1 y2) - :ink (medium-ink medium))))) - -(defun add-new-rectangle-record (class stream x1 y1 x2 y2) - (stream-add-output-record - stream (make-rectangle-record class (sheet-medium stream) - x1 y1 x2 y2))) - ;;;;;;;;;;;;;;;;;; pixmap output record (defclass pixmap-output-record (score-output-record) @@ -229,7 +199,7 @@ (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) (+ (staff-step staff-step) dy))))))) + (,medium-draw-name pane pixmap (+ x dx) (- dy (staff-step staff-step)))))))) ;;;;;;;;;;;;;;;;;; notehead @@ -309,40 +279,14 @@ (define-pixmap-recording (dot-output-record medium-draw-dot draw-dot ()) +glyph-dot+) -;;;;;;;;;;;;;;;;;; helper macro - -(defmacro define-rectangle-recording ((record-name medium-draw-name draw-name args) &body body) - `(progn - (defclass ,record-name (rectangle-output-record) ()) - - (defgeneric ,medium-draw-name (medium x1 y1 x2 y2)) - - (defmethod ,medium-draw-name ((medium medium) x1 y1 x2 y2) - (medium-draw-rectangle* medium x1 y1 x2 y2 t)) - - (defmethod ,medium-draw-name ((sheet sheet) x1 y1 x2 y2) - (,medium-draw-name (sheet-medium sheet) x1 y1 x2 y2)) - - (defmethod ,medium-draw-name :around ((pane score-pane) x1 y1 x2 y2) - (when (stream-recording-p pane) - (add-new-rectangle-record ',record-name pane x1 y1 x2 y2)) - (when (stream-drawing-p pane) - (,medium-draw-name (sheet-medium pane) x1 y1 x2 y2))) - - (defun ,draw-name (pane , at args) - , at body))) - ;;;;;;;;;;;;;;;;;; staff line -(define-rectangle-recording (staff-line-output-record - medium-draw-staff-line - draw-staff-line - (x1 staff-step x2)) - (multiple-value-bind (down up) (staff-line-offsets *font*) - (let ((y1 (+ (staff-step staff-step) down)) - (y2 (+ (staff-step staff-step) up))) - (medium-draw-staff-line pane x1 y1 x2 y2)))) - +(defun draw-staff-line (pane x1 staff-step x2) + (multiple-value-bind (down up) (staff-line-offsets *font*) + (let ((y1 (- (- (staff-step staff-step)) up)) + (y2 (- (- (staff-step staff-step)) down))) + (draw-rectangle* pane x1 y1 x2 y2)))) + (defclass staff-output-record (output-record) ((parent :initarg :parent :initform nil :accessor output-record-parent) (x :initarg :x1 :initarg :x-position) @@ -445,14 +389,11 @@ ;;;;;;;;;;;;;;;;;; stem -(define-rectangle-recording (stem-output-record - medium-draw-stem - draw-stem - (x y1 y2)) - (multiple-value-bind (left right) (stem-offsets *font*) - (let ((x1 (+ x left)) - (x2 (+ x right))) - (medium-draw-stem pane x1 y1 x2 y2)))) +(defun draw-stem (pane x y1 y2) + (multiple-value-bind (left right) (stem-offsets *font*) + (let ((x1 (+ x left)) + (x2 (+ x right))) + (draw-rectangle* pane x1 y1 x2 y2)))) (defun draw-right-stem (pane x y1 y2) (multiple-value-bind (dx dy) (notehead-right-offsets *font*) @@ -466,28 +407,23 @@ ;;;;;;;;;;;;;;;;;; ledger line -(define-rectangle-recording (ledger-line-output-record - medium-draw-ledger-line - draw-ledger-line - (x staff-step)) - (multiple-value-bind (down up) (ledger-line-y-offsets *font*) - (multiple-value-bind (left right) (ledger-line-x-offsets *font*) - (let ((x1 (+ x left)) - (y1 (+ (staff-step staff-step) down)) - (x2 (+ x right)) - (y2 (+ (staff-step staff-step) up))) - (medium-draw-ledger-line pane x1 y1 x2 y2))))) +(defun draw-ledger-line (pane x staff-step) + (multiple-value-bind (down up) (ledger-line-y-offsets *font*) + (multiple-value-bind (left right) (ledger-line-x-offsets *font*) + (let ((x1 (+ x left)) + (y1 (- (+ (staff-step staff-step) down))) + (x2 (+ x right)) + (y2 (- (+ (staff-step staff-step) up)))) + (draw-rectangle* pane x1 y1 x2 y2))))) + ;;;;;;;;;;;;;;;;;; bar line -(define-rectangle-recording (bar-line-output-record - medium-draw-bar-line - draw-bar-line - (x y1 y2)) - (multiple-value-bind (left right) (bar-line-offsets *font*) - (let ((x1 (+ x left)) - (x2 (+ x right))) - (medium-draw-bar-line pane x1 y1 x2 y2)))) +(defun draw-bar-line (pane x y1 y2) + (multiple-value-bind (left right) (bar-line-offsets *font*) + (let ((x1 (+ x left)) + (x2 (+ x right))) + (draw-rectangle* pane x1 y1 x2 y2)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -496,15 +432,9 @@ (defclass beam-output-record (score-output-record) ((thickness :initarg :thickness))) -(defclass horizontal-beam-output-record (beam-output-record rectangle-output-record) - ()) - (defun draw-horizontal-beam (medium x1 y1 x2 thickness) (let ((y2 (- y1 thickness))) - (when (stream-recording-p *pane*) - (add-new-rectangle-record 'horizontal-beam-output-record *pane* x1 y1 x2 y2)) - (when (stream-drawing-p *pane*) - (medium-draw-rectangle* medium x1 y1 x2 y2 t)))) + (draw-rectangle* medium x1 y1 x2 y2))) (defvar *darker-gray-progressions*) (defvar *lighter-gray-progressions*) @@ -604,10 +534,8 @@ (with-drawing-options (medium :ink ink) (let ((*lighter-gray-progressions* (lighter-gray-progressions stream)) (*darker-gray-progressions* (darker-gray-progressions stream))) - ;; we replay with the identity tranformation, so - ;; we have to draw the other way - (draw-downward-beam medium x1 (1- y2) (1- (+ y1 thickness)) thickness - (/ (- x2 x1) (- y2 y1 thickness)))))))))) + (draw-upward-beam medium x1 y1 y2 thickness + (/ (- x2 x1) (- y2 y1)))))))))) (defclass downward-beam-output-record (beam-output-record) ()) @@ -623,22 +551,20 @@ (with-drawing-options (medium :ink ink) (let ((*lighter-gray-progressions* (lighter-gray-progressions stream)) (*darker-gray-progressions* (darker-gray-progressions stream))) - ;; we replay with the identity tranformation, so - ;; we have to draw the other way - (draw-upward-beam medium x1 (1- (+ y1 thickness)) (1- y2) thickness - (/ (- x2 x1) (- y2 y1 thickness)))))))))) + (draw-downward-beam medium x1 y2 y1 thickness + (/ (- x2 x1) (- y2 y1)))))))))) (defun draw-sloped-beam (medium x1 y1 x2 y2 thickness inverse-slope) (let ((transformation (medium-transformation *pane*))) (cond ((< y1 y2) (when (stream-recording-p *pane*) (multiple-value-bind (xx1 yy1) - (transform-position transformation x1 (- y1 thickness)) + (transform-position transformation x1 y1) (multiple-value-bind (xx2 yy2) (transform-position transformation x2 y2) (stream-add-output-record *pane* (make-instance 'upward-beam-output-record - :x1 xx1 :y1 yy2 :x2 xx2 :y2 yy1 + :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))) @@ -647,7 +573,7 @@ (multiple-value-bind (xx1 yy1) (transform-position transformation x1 y1) (multiple-value-bind (xx2 yy2) - (transform-position transformation x2 (- y2 thickness)) + (transform-position transformation x2 y2) (stream-add-output-record *pane* (make-instance 'downward-beam-output-record :x1 xx1 :y1 yy1 :x2 xx2 :y2 yy2 @@ -662,8 +588,8 @@ (multiple-value-bind (left right) (stem-offsets *font*) (let* ((xx1 (+ x1 left)) (xx2 (+ x2 right)) - (y1 (floor (staff-step (+ staff-step-1 1/2 (* 1/2 offset1))))) - (y2 (floor (staff-step (+ staff-step-2 1/2 (* 1/2 offset2))))) + (y1 (- (floor (staff-step (+ staff-step-1 (* 1/2 offset1)))))) + (y2 (- (floor (staff-step (+ staff-step-2 (* 1/2 offset2)))))) (slope (abs (/ (- y2 y1) (- xx2 xx1)))) (thickness (/ (staff-line-distance *font*) 2)) (medium (sheet-medium pane))) @@ -696,14 +622,14 @@ (*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) - , at 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*)) +;; (with-translation (pane 0 900) +;; (with-scaling (pane 1 -1) + , at 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) Index: gsharp/sdl.lisp diff -u gsharp/sdl.lisp:1.4 gsharp/sdl.lisp:1.5 --- gsharp/sdl.lisp:1.4 Fri Mar 26 15:24:11 2004 +++ gsharp/sdl.lisp Mon Aug 1 01:36:56 2005 @@ -54,9 +54,9 @@ notehead-left-y-offset) font (let ((staff-line-thickness (round (/ (staff-line-distance font) 10)))) (setf staff-line-offset-down - (- (floor (/ staff-line-thickness 2))) + (floor (/ staff-line-thickness 2)) staff-line-offset-up - (+ staff-line-thickness staff-line-offset-down))) + (- staff-line-thickness staff-line-offset-down))) (let ((stem-thickness (round (/ staff-line-distance 11.9)))) (setf stem-offset-left (- (floor (/ stem-thickness 2))) @@ -103,7 +103,7 @@ (declare (ignore initargs)) (with-slots (gf-char x-offset y-offset) glyph (setf x-offset (floor (gf-char-min-m gf-char) 4) - y-offset (ceiling (1+ (gf-char-max-n gf-char)) 4)))) + y-offset (- (floor (1+ (gf-char-max-n gf-char)) 4))))) (defmethod glyph ((font font) glyph-no) (with-slots (gf-char pixmap) (aref (glyphs font) glyph-no)