gsharp-cvs

gsharp-cvs@common-lisp.net

396 discussions

[gsharp-cvs] CVS update: gsharp/drawing.lisp gsharp/gui.lisp gsharp/score-pane.lisp gsharp/sdl.lisp
by rstrandh＠common-lisp.net 31 Jul '05

31 Jul '05

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 ,@args) - ,@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) - ,@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) + ,@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)

1 0

[gsharp-cvs] CVS update: gsharp/gui.lisp gsharp/modes.lisp gsharp/packages.lisp gsharp/score-pane.lisp gsharp/system.lisp
by rstrandh＠common-lisp.net 25 Jul '05

25 Jul '05

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")

2 1

[gsharp-cvs] CVS update: gsharp/gui.lisp gsharp/modes.lisp gsharp/packages.lisp gsharp/system.lisp
by rstrandh＠common-lisp.net 25 Jul '05

25 Jul '05

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")

1 0

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

25 Jul '05

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

1 0

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

02 Jun '05

Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv1476 Modified Files: system.lisp Log Message: Make it build out-of-the-box with mcclim/asdf Date: Thu Jun 2 13:52:37 2005 Author: crhodes Index: gsharp/system.lisp diff -u gsharp/system.lisp:1.4 gsharp/system.lisp:1.5 --- gsharp/system.lisp:1.4 Fri Jul 23 18:51:16 2004 +++ gsharp/system.lisp Thu Jun 2 13:52:37 2005 @@ -20,7 +20,7 @@ :defaults *gsharp-directory*)) collect `(:file ,(pathname-name p) :pathname ,p)))))) -(gsharp-defsystem (:gsharp) +(gsharp-defsystem (:gsharp :depends-on (:mcclim)) "packages" "sequence-dico" "utilities"

1 0

[gsharp-cvs] CVS update: gsharp/Flexichain/flexichain-package.lisp gsharp/Flexichain/flexichain.asd
by rstrandh＠common-lisp.net 02 Mar '05

02 Mar '05

Update of /project/gsharp/cvsroot/gsharp/Flexichain In directory common-lisp.net:/tmp/cvs-serv5339 Modified Files: flexichain-package.lisp flexichain.asd Log Message: Flexichain no longer uses skiplists. Date: Wed Mar 2 05:19:28 2005 Author: rstrandh Index: gsharp/Flexichain/flexichain-package.lisp diff -u gsharp/Flexichain/flexichain-package.lisp:1.2 gsharp/Flexichain/flexichain-package.lisp:1.3 --- gsharp/Flexichain/flexichain-package.lisp:1.2 Tue Dec 28 07:57:00 2004 +++ gsharp/Flexichain/flexichain-package.lisp Wed Mar 2 05:19:27 2005 @@ -20,7 +20,7 @@ (defpackage :flexichain - (:use :common-lisp :skiplist) + (:use :common-lisp) (:export #:flexichain #:standard-flexichain #:flexi-error #:flexi-initialization-error #:flexi-position-error #:flexi-incompatible-type-error Index: gsharp/Flexichain/flexichain.asd diff -u gsharp/Flexichain/flexichain.asd:1.2 gsharp/Flexichain/flexichain.asd:1.3 --- gsharp/Flexichain/flexichain.asd:1.2 Mon Jan 17 06:32:06 2005 +++ gsharp/Flexichain/flexichain.asd Wed Mar 2 05:19:27 2005 @@ -29,9 +29,7 @@ ;; for testing. (defsystem flexichain :name "flexichain" - :components ((:file "skiplist-package") - (:file "skiplist" :depends-on ("skiplist-package")) - (:file "flexichain-package" :depends-on ("skiplist-package")) + :components ((:file "flexichain-package") (:file "utilities" :depends-on ("flexichain-package")) (:file "flexichain" :depends-on ("utilities")) (:file "flexicursor" :depends-on ("flexichain"))))

1 0

[gsharp-cvs] CVS update: gsharp/Flexichain/Doc/flexichain.tex
by crhodes＠common-lisp.net 25 Jan '05

25 Jan '05

Update of /project/gsharp/cvsroot/gsharp/Flexichain/Doc In directory common-lisp.net:/tmp/cvs-serv8287/Flexichain/Doc Modified Files: flexichain.tex Log Message: s/elemement/element/ in flexichain spec. Date: Tue Jan 25 03:08:36 2005 Author: crhodes Index: gsharp/Flexichain/Doc/flexichain.tex diff -u gsharp/Flexichain/Doc/flexichain.tex:1.3 gsharp/Flexichain/Doc/flexichain.tex:1.4 --- gsharp/Flexichain/Doc/flexichain.tex:1.3 Mon Sep 6 04:18:42 2004 +++ gsharp/Flexichain/Doc/flexichain.tex Tue Jan 25 03:08:32 2005 @@ -663,7 +663,7 @@ after the last operation has been completed, thus making it more efficient to use this macro than to use individual editing operations. -\Defgeneric {elemement<} {cursor} +\Defgeneric {element<} {cursor} Return the element immediately before the cursor. If the cursor is at the beginning, an at-beginning condition will be signaled. @@ -674,7 +674,7 @@ as argument. If the cursor is at the beginning, an at-beginning condition will be signaled. -\Defgeneric {elemement>} {cursor} +\Defgeneric {element>} {cursor} Return the element immediately after the cursor. If the cursor is at the end, an at-end condition will be signaled.

1 0

[gsharp-cvs] CVS update: gsharp/Flexichain/flexichain.asd
by rstrandh＠common-lisp.net 17 Jan '05

17 Jan '05

Update of /project/gsharp/cvsroot/gsharp/Flexichain In directory common-lisp.net:/tmp/cvs-serv14516 Modified Files: flexichain.asd Log Message: patch to reflect new package files. Date: Mon Jan 17 06:32:07 2005 Author: rstrandh Index: gsharp/Flexichain/flexichain.asd diff -u gsharp/Flexichain/flexichain.asd:1.1 gsharp/Flexichain/flexichain.asd:1.2 --- gsharp/Flexichain/flexichain.asd:1.1 Sun Aug 1 17:27:19 2004 +++ gsharp/Flexichain/flexichain.asd Mon Jan 17 06:32:06 2005 @@ -24,9 +24,15 @@ (in-package #:flexichain-system) +;; The tester is not included, for it depends on clim. The stupid +;; implementation has also been left out, since it seems mostly useful +;; for testing. (defsystem flexichain :name "flexichain" - :components ((:file "package") - (:file "utilities" :depends-on ("package")) + :components ((:file "skiplist-package") + (:file "skiplist" :depends-on ("skiplist-package")) + (:file "flexichain-package" :depends-on ("skiplist-package")) + (:file "utilities" :depends-on ("flexichain-package")) (:file "flexichain" :depends-on ("utilities")) (:file "flexicursor" :depends-on ("flexichain")))) +

1 0

[gsharp-cvs] CVS update: gsharp/Flexichain/utilities.lisp
by tmoore＠common-lisp.net 15 Jan '05

15 Jan '05

Update of /project/gsharp/cvsroot/gsharp/Flexichain In directory common-lisp.net:/tmp/cvs-serv4778 Modified Files: utilities.lisp Log Message: Fixed non-openmcl typo Date: Sat Jan 15 09:43:50 2005 Author: tmoore Index: gsharp/Flexichain/utilities.lisp diff -u gsharp/Flexichain/utilities.lisp:1.2 gsharp/Flexichain/utilities.lisp:1.3 --- gsharp/Flexichain/utilities.lisp:1.2 Fri Jan 14 17:12:41 2005 +++ gsharp/Flexichain/utilities.lisp Sat Jan 15 09:43:50 2005 @@ -40,8 +40,8 @@ ;;; ;;; TODO: check other CL implementations behavior wrt. return values (defclass weak-pointer-container-mixin () - #+openmcl - ((weak-hash :initform (make-hash-table :test #'eq :weak :value))) + (#+openmcl + (weak-hash :initform (make-hash-table :test #'eq :weak :value))) (:documentation "Support for weak references, if needed")) (defgeneric make-weak-pointer (object container))

1 0

[gsharp-cvs] CVS update: gsharp/Flexichain/flexicursor.lisp gsharp/Flexichain/utilities.lisp
by tmoore＠common-lisp.net 14 Jan '05

14 Jan '05

Update of /project/gsharp/cvsroot/gsharp/Flexichain In directory common-lisp.net:/tmp/cvs-serv18364 Modified Files: flexicursor.lisp utilities.lisp Log Message: Generalized weak pointer support and added an implementation for OpenMCL. Date: Fri Jan 14 17:12:42 2005 Author: tmoore Index: gsharp/Flexichain/flexicursor.lisp diff -u gsharp/Flexichain/flexicursor.lisp:1.9 gsharp/Flexichain/flexicursor.lisp:1.10 --- gsharp/Flexichain/flexicursor.lisp:1.9 Mon Jan 3 07:44:42 2005 +++ gsharp/Flexichain/flexicursor.lisp Fri Jan 14 17:12:41 2005 @@ -96,18 +96,11 @@ (defgeneric (setf element>) (object cursor) (:documentation "Replaces the element immediately after the cursor.")) -(defclass standard-cursorchain (cursorchain standard-flexichain) +(defclass standard-cursorchain + (weak-pointer-container-mixin cursorchain standard-flexichain) ((cursors :initform '())) (:documentation "The standard instantiable subclass of CURSORCHAIN")) -(defun make-wp (value) - #+sbcl (sb-ext:make-weak-pointer value) - #+cmu (ext:make-weak-pointer value)) - -(defun wp-value (wp) - #+sbcl (sb-ext:weak-pointer-value wp) - #+cmu (ext:weak-pointer-value wp)) - (defclass standard-flexicursor (flexicursor) ((chain :reader chain :initarg :chain) (index :accessor flexicursor-index)) @@ -123,7 +116,7 @@ (with-slots (index chain) cursor (setf index (position-index chain (1- position))) (with-slots (cursors) chain - (push (make-wp cursor) cursors)))) + (push (make-weak-pointer cursor chain) cursors)))) (defmethod initialize-instance :after ((cursor right-sticky-flexicursor) &rest initargs &key (position 0)) @@ -131,30 +124,32 @@ (with-slots (index chain) cursor (setf index (position-index chain position)) (with-slots (cursors) chain - (push (make-wp cursor) cursors)))) + (push (make-weak-pointer cursor chain) cursors)))) -(defun adjust-cursors (cursors start end increment) +(defun adjust-cursors (chain cursors start end increment) (let ((acc '())) - (loop while cursors - do (cond ((null (wp-value (car cursors))) - (pop cursors)) - ((<= start (flexicursor-index (wp-value (car cursors))) end) - (incf (flexicursor-index (wp-value (car cursors))) increment) + (loop + for cursor = (and cursors (weak-pointer-value (car cursors) chain)) + while cursors + do (cond ((null cursor) + (pop cursors)) + ((<= start (flexicursor-index cursor) end) + (incf (flexicursor-index cursor) increment) (let ((rest (cdr cursors))) (setf (cdr cursors) acc acc cursors cursors rest))) - (t - (let ((rest (cdr cursors))) - (setf (cdr cursors) acc - acc cursors - cursors rest))))) + (t + (let ((rest (cdr cursors))) + (setf (cdr cursors) acc + acc cursors + cursors rest))))) acc)) (defmethod move-elements :after ((cc standard-cursorchain) to from start1 start2 end2) (declare (ignore to from)) (with-slots (cursors) cc - (setf cursors (adjust-cursors cursors start2 (1- end2) (- start1 start2))))) + (setf cursors (adjust-cursors cc cursors start2 (1- end2) (- start1 start2))))) (defmethod clone-cursor ((cursor standard-flexicursor)) (make-instance (class-of cursor) @@ -200,7 +195,7 @@ (with-slots (cursors) chain (let* ((old-index (position-index chain position))) (loop for cursor-wp in cursors - as cursor = (wp-value cursor-wp) + as cursor = (weak-pointer-value cursor-wp chain) when (and cursor (= old-index (flexicursor-index cursor))) do (typecase cursor (right-sticky-flexicursor (incf (cursor-pos cursor))) Index: gsharp/Flexichain/utilities.lisp diff -u gsharp/Flexichain/utilities.lisp:1.1 gsharp/Flexichain/utilities.lisp:1.2 --- gsharp/Flexichain/utilities.lisp:1.1 Sun Aug 1 17:27:19 2004 +++ gsharp/Flexichain/utilities.lisp Fri Jan 14 17:12:41 2005 @@ -34,17 +34,52 @@ (values nil nil) (values (elt sequence position) t)))) -(defun make-weak-pointer (object) - "Returns a weak pointer to OBJECT." - #+cmu (extensions:make-weak-pointer object) - #+sbcl (sb-ext:make-weak-pointer object) - #-(or cmu sbcl) (error "MAKE-WEAK-POINTER not implemented.")) - -(defun weak-pointer-value (weak-pointer) - ;; TODO: check other CL implementations behavior wrt. return values - "Returns the object pointed to by WEAK-POINTER or NIL if the pointer -is broken." +;;; CMUCL and SBCL have direct support for weak pointers. In OpenMCL weak +;;; references are only supported via weak hash tables. This class provides +;;; the means for other classes to manage their weak references. +;;; +;;; TODO: check other CL implementations behavior wrt. return values +(defclass weak-pointer-container-mixin () + #+openmcl + ((weak-hash :initform (make-hash-table :test #'eq :weak :value))) + (:documentation "Support for weak references, if needed")) + +(defgeneric make-weak-pointer (object container)) + +#+(or sbcl cmu) +(defmethod make-weak-pointer (object container) + (declare (ignore container)) + #+cmu (extensions:make-weak-pointer object) + #+sbcl (sb-ext:make-weak-pointer object)) + +#+openmcl +(defmethod make-weak-pointer (object (container weak-pointer-container-mixin)) + (let ((key (cons nil nil))) + (setf (gethash key (slot-value container 'weak-hash)) object) + key)) + +(defgeneric weak-pointer-value (weak-pointer container)) + +#+(or sbcl cmu) +(defmethod weak-pointer-value (weak-pointer container) + (declare (ignore container)) #+cmu (extensions:weak-pointer-value weak-pointer) - #+sbcl (sb-ext:weak-pointer-value weak-pointer) - #-(or cmu sbcl) (error "WEAK-POINTER-VALUE not implemented.")) + #+sbcl (sb-ext:weak-pointer-value weak-pointer)) + +#+openmcl +(defmethod weak-pointer-value + (weak-pointer (container weak-pointer-container-mixin)) + (gethash weak-pointer (slot-value container 'weak-hash) nil)) +#-(or sbcl cmu openmcl) +(progn + (eval-when (:evaluate :compile-toplevel :load-toplevel) + (warning "No support for weak pointers in this implementation. Things may +get big and slow") + ) + (defmethod make-weak-pointer (object container) + (declare (ignore container)) + object) + (defmethod weak-pointer-value (weak-pointer container) + (declare (ignore container)) + weak-pointer))

1 0

← Newer
1
...
30
31
32
33
34
35
36
...
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