From rstrandh at common-lisp.net Sun Aug 1 15:14:33 2004 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sun, 01 Aug 2004 08:14:33 -0700 Subject: [gsharp-cvs] CVS update: gsharp/gui.lisp gsharp/modes.lisp Message-ID: Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv3200 Modified Files: gui.lisp modes.lisp Log Message: Lyrics input now allows for accents, provided that your keyboard is capable of generating dead keys for these accents. It only works for X11 at the moment, I would think. The way I do it is not great, since now I get messages about missing commands for the control keys. I have to think of a better way of doing it. Loading a file now calls select-layer so that the appropriate mode is selected. Loading the bach score with lyrics now immediately lets you edit the lyrics. Date: Sun Aug 1 08:14:33 2004 Author: rstrandh Index: gsharp/gui.lisp diff -u gsharp/gui.lisp:1.16 gsharp/gui.lisp:1.17 --- gsharp/gui.lisp:1.16 Sat Jul 24 13:09:55 2004 +++ gsharp/gui.lisp Sun Aug 1 08:14:33 2004 @@ -17,8 +17,8 @@ (defparameter *last-character* nil) (defmethod dispatch-event :around ((pane score-pane:score-pane) (event key-press-event)) - (when (keyboard-event-character event) - (let ((key (list (keyboard-event-character 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))) @@ -289,7 +289,8 @@ (setf (buffer *gsharp-frame*) buffer (input-state *gsharp-frame*) input-state (cursor *gsharp-frame*) cursor) - (number-all (buffer *gsharp-frame*)))) + (number-all (buffer *gsharp-frame*)) + (select-layer cursor (car (layers (segment (cursor *gsharp-frame*))))))) (define-gsharp-command (com-save-buffer-as :name t) () (let* ((stream (frame-standard-input *gsharp-frame*)) Index: gsharp/modes.lisp diff -u gsharp/modes.lisp:1.2 gsharp/modes.lisp:1.3 --- gsharp/modes.lisp:1.2 Sat Jul 24 13:09:55 2004 +++ gsharp/modes.lisp Sun Aug 1 08:14:33 2004 @@ -97,70 +97,70 @@ do (add-keyseq `((,c)) (make-insert-fun i) *lyrics-layer-mode-table*)) ;;; try some latin prefix mode for national characters -(add-keyseq '((#\`) (#\A :shift)) (make-insert-fun 192) *lyrics-layer-mode-table*) -(add-keyseq '((#\') (#\A :shift)) (make-insert-fun 193) *lyrics-layer-mode-table*) -(add-keyseq '((#\^) (#\A :shift)) (make-insert-fun 194) *lyrics-layer-mode-table*) -(add-keyseq '((#\~) (#\A :shift)) (make-insert-fun 195) *lyrics-layer-mode-table*) -(add-keyseq '((#\") (#\A :shift)) (make-insert-fun 196) *lyrics-layer-mode-table*) -(add-keyseq '((#\/) (#\A :shift)) (make-insert-fun 197) *lyrics-layer-mode-table*) -(add-keyseq '((#\/) (#\E :shift)) (make-insert-fun 198) *lyrics-layer-mode-table*) -(add-keyseq '((#\/) (#\C :shift)) (make-insert-fun 199) *lyrics-layer-mode-table*) -(add-keyseq '((#\`) (#\E :shift)) (make-insert-fun 200) *lyrics-layer-mode-table*) -(add-keyseq '((#\') (#\E :shift)) (make-insert-fun 201) *lyrics-layer-mode-table*) -(add-keyseq '((#\^) (#\E :shift)) (make-insert-fun 202) *lyrics-layer-mode-table*) -(add-keyseq '((#\") (#\E :shift)) (make-insert-fun 203) *lyrics-layer-mode-table*) -(add-keyseq '((#\`) (#\I :shift)) (make-insert-fun 204) *lyrics-layer-mode-table*) -(add-keyseq '((#\') (#\I :shift)) (make-insert-fun 205) *lyrics-layer-mode-table*) -(add-keyseq '((#\^) (#\I :shift)) (make-insert-fun 206) *lyrics-layer-mode-table*) -(add-keyseq '((#\") (#\I :shift)) (make-insert-fun 207) *lyrics-layer-mode-table*) -(add-keyseq '((#\/) (#\D :shift)) (make-insert-fun 208) *lyrics-layer-mode-table*) -(add-keyseq '((#\~) (#\N :shift)) (make-insert-fun 209) *lyrics-layer-mode-table*) -(add-keyseq '((#\`) (#\O :shift)) (make-insert-fun 210) *lyrics-layer-mode-table*) -(add-keyseq '((#\') (#\O :shift)) (make-insert-fun 211) *lyrics-layer-mode-table*) -(add-keyseq '((#\^) (#\O :shift)) (make-insert-fun 212) *lyrics-layer-mode-table*) -(add-keyseq '((#\~) (#\O :shift)) (make-insert-fun 213) *lyrics-layer-mode-table*) -(add-keyseq '((#\") (#\O :shift)) (make-insert-fun 214) *lyrics-layer-mode-table*) - -(add-keyseq '((#\/) (#\O :shift)) (make-insert-fun 216) *lyrics-layer-mode-table*) -(add-keyseq '((#\`) (#\U :shift)) (make-insert-fun 217) *lyrics-layer-mode-table*) -(add-keyseq '((#\') (#\U :shift)) (make-insert-fun 218) *lyrics-layer-mode-table*) -(add-keyseq '((#\^) (#\U :shift)) (make-insert-fun 219) *lyrics-layer-mode-table*) -(add-keyseq '((#\") (#\U :shift)) (make-insert-fun 220) *lyrics-layer-mode-table*) -(add-keyseq '((#\') (#\Y :shift)) (make-insert-fun 221) *lyrics-layer-mode-table*) - - -(add-keyseq '((#\`) (#\a)) (make-insert-fun 224) *lyrics-layer-mode-table*) -(add-keyseq '((#\') (#\a)) (make-insert-fun 225) *lyrics-layer-mode-table*) -(add-keyseq '((#\^) (#\a)) (make-insert-fun 226) *lyrics-layer-mode-table*) -(add-keyseq '((#\~) (#\a)) (make-insert-fun 227) *lyrics-layer-mode-table*) -(add-keyseq '((#\") (#\a)) (make-insert-fun 228) *lyrics-layer-mode-table*) -(add-keyseq '((#\/) (#\a)) (make-insert-fun 229) *lyrics-layer-mode-table*) -(add-keyseq '((#\/) (#\e)) (make-insert-fun 230) *lyrics-layer-mode-table*) -(add-keyseq '((#\~) (#\c)) (make-insert-fun 231) *lyrics-layer-mode-table*) -(add-keyseq '((#\`) (#\e)) (make-insert-fun 232) *lyrics-layer-mode-table*) -(add-keyseq '((#\') (#\e)) (make-insert-fun 233) *lyrics-layer-mode-table*) -(add-keyseq '((#\^) (#\e)) (make-insert-fun 234) *lyrics-layer-mode-table*) -(add-keyseq '((#\") (#\e)) (make-insert-fun 235) *lyrics-layer-mode-table*) -(add-keyseq '((#\`) (#\i)) (make-insert-fun 236) *lyrics-layer-mode-table*) -(add-keyseq '((#\') (#\i)) (make-insert-fun 237) *lyrics-layer-mode-table*) -(add-keyseq '((#\^) (#\i)) (make-insert-fun 238) *lyrics-layer-mode-table*) -(add-keyseq '((#\") (#\i)) (make-insert-fun 239) *lyrics-layer-mode-table*) - - -(add-keyseq '((#\`) (#\o)) (make-insert-fun 242) *lyrics-layer-mode-table*) -(add-keyseq '((#\') (#\o)) (make-insert-fun 243) *lyrics-layer-mode-table*) -(add-keyseq '((#\^) (#\o)) (make-insert-fun 244) *lyrics-layer-mode-table*) -(add-keyseq '((#\~) (#\o)) (make-insert-fun 245) *lyrics-layer-mode-table*) -(add-keyseq `((#\") (#\o)) (make-insert-fun 246) *lyrics-layer-mode-table*) - -(add-keyseq '((#\/) (#\o)) (make-insert-fun 248) *lyrics-layer-mode-table*) -(add-keyseq '((#\`) (#\u)) (make-insert-fun 249) *lyrics-layer-mode-table*) -(add-keyseq '((#\') (#\u)) (make-insert-fun 250) *lyrics-layer-mode-table*) -(add-keyseq '((#\^) (#\u)) (make-insert-fun 251) *lyrics-layer-mode-table*) -(add-keyseq '((#\") (#\u)) (make-insert-fun 252) *lyrics-layer-mode-table*) -(add-keyseq '((#\') (#\y)) (make-insert-fun 253) *lyrics-layer-mode-table*) +(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*) -(add-keyseq '((#\") (#\y)) (make-insert-fun 255) *lyrics-layer-mode-table*) +(add-keyseq '((:dead--diaeresis :shift) (#\y)) (make-insert-fun 255) *lyrics-layer-mode-table*) From rstrandh at common-lisp.net Sun Aug 1 15:15:30 2004 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sun, 01 Aug 2004 08:15:30 -0700 Subject: [gsharp-cvs] CVS update: Directory change: gsharp/Flexichain Message-ID: Update of /project/gsharp/cvsroot/gsharp/Flexichain In directory common-lisp.net:/tmp/cvs-serv27296/Flexichain Log Message: Directory /project/gsharp/cvsroot/gsharp/Flexichain added to the repository Date: Sun Aug 1 08:15:30 2004 Author: rstrandh New directory gsharp/Flexichain added From rstrandh at common-lisp.net Sun Aug 1 15:18:02 2004 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sun, 01 Aug 2004 08:18:02 -0700 Subject: [gsharp-cvs] CVS update: Directory change: gsharp/Flexichain/Doc Message-ID: Update of /project/gsharp/cvsroot/gsharp/Flexichain/Doc In directory common-lisp.net:/tmp/cvs-serv18496/Doc Log Message: Directory /project/gsharp/cvsroot/gsharp/Flexichain/Doc added to the repository Date: Sun Aug 1 08:18:02 2004 Author: rstrandh New directory gsharp/Flexichain/Doc added From rstrandh at common-lisp.net Sun Aug 1 15:27:20 2004 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sun, 01 Aug 2004 08:27:20 -0700 Subject: [gsharp-cvs] CVS update: gsharp/Flexichain/flexichain.asd gsharp/Flexichain/flexichain.lisp gsharp/Flexichain/flexicursor.lisp gsharp/Flexichain/package.lisp gsharp/Flexichain/tester-package.lisp gsharp/Flexichain/tester.lisp gsharp/Flexichain/utilities.lisp Message-ID: Update of /project/gsharp/cvsroot/gsharp/Flexichain In directory common-lisp.net:/tmp/cvs-serv27456/Flexichain Added Files: flexichain.asd flexichain.lisp flexicursor.lisp package.lisp tester-package.lisp tester.lisp utilities.lisp Log Message: I am proud to announce the first reasonably complete version of the `flexichain' library. The bad news is that the API does not quite correspond to what was previously announced. There are three pieces of good news, however: First the API is better now, second, the documentation has been updated to be consistent with the modified API, and third the code is much simpler than it would have been with the original API. There are still some inconsistencies between the documentation and the code (names of conditions, missing pieces of the API in the doc), but it is mostly there. Oh, and since it was so hard to test, I wrote a CLIM application to test it. The upper half is a black-box test and the lower half is the white-box test. Let me know what you think. Before integrating the Flexichain library into Gsharp, I would like to test it some more, so if anyone feels like doing that and reporting bugs, that would be fantastic. Date: Sun Aug 1 08:27:19 2004 Author: rstrandh From rstrandh at common-lisp.net Sun Aug 1 15:27:20 2004 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sun, 01 Aug 2004 08:27:20 -0700 Subject: [gsharp-cvs] CVS update: gsharp/Flexichain/Doc/Makefile gsharp/Flexichain/Doc/circular.fig gsharp/Flexichain/Doc/flexichain.tex gsharp/Flexichain/Doc/gap1.fig gsharp/Flexichain/Doc/gap2.fig gsharp/Flexichain/Doc/gap3.fig gsharp/Flexichain/Doc/spec-macros.tex gsharp/Flexichain/Doc/strip-dependence gsharp/Flexichain/Doc/tex-dependencies Message-ID: Update of /project/gsharp/cvsroot/gsharp/Flexichain/Doc In directory common-lisp.net:/tmp/cvs-serv27456/Flexichain/Doc Added Files: Makefile circular.fig flexichain.tex gap1.fig gap2.fig gap3.fig spec-macros.tex strip-dependence tex-dependencies Log Message: I am proud to announce the first reasonably complete version of the `flexichain' library. The bad news is that the API does not quite correspond to what was previously announced. There are three pieces of good news, however: First the API is better now, second, the documentation has been updated to be consistent with the modified API, and third the code is much simpler than it would have been with the original API. There are still some inconsistencies between the documentation and the code (names of conditions, missing pieces of the API in the doc), but it is mostly there. Oh, and since it was so hard to test, I wrote a CLIM application to test it. The upper half is a black-box test and the lower half is the white-box test. Let me know what you think. Before integrating the Flexichain library into Gsharp, I would like to test it some more, so if anyone feels like doing that and reporting bugs, that would be fantastic. Date: Sun Aug 1 08:27:20 2004 Author: rstrandh From rstrandh at common-lisp.net Wed Aug 4 19:59:29 2004 From: rstrandh at common-lisp.net (Robert Strandh) Date: Wed, 04 Aug 2004 12:59:29 -0700 Subject: [gsharp-cvs] CVS update: gsharp/buffer.lisp Message-ID: Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv3372 Modified Files: buffer.lisp Log Message: Factored out named objects in a mixin class Cleaned up print-object by using method combination and a base class for all buffer objects. Date: Wed Aug 4 12:59:28 2004 Author: rstrandh Index: gsharp/buffer.lisp diff -u gsharp/buffer.lisp:1.6 gsharp/buffer.lisp:1.7 --- gsharp/buffer.lisp:1.6 Sat Jul 24 13:09:55 2004 +++ gsharp/buffer.lisp Wed Aug 4 12:59:28 2004 @@ -9,25 +9,38 @@ (defun skip-until-close-bracket (stream) (loop until (eql (read-char stream) #\]))) +(defclass gsharp-object () ()) + +(defmethod print-object ((obj gsharp-object) stream) + nil) + +(defmethod print-object :around ((obj gsharp-object) stream) + (format stream "[~a " (slot-value obj 'print-character)) + (call-next-method) + (format stream "] ")) + +(defgeneric name (obj)) + +(defclass name-mixin () + ((name :initarg :name :accessor name))) + +(defmethod print-object :after ((obj name-mixin) stream) + (format stream ":name ~W " (name obj))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Clef -;;; The name of a clef is one of :TREBLE, :BASS, -;;; :C, and :PERCUSSION -(defgeneric name (clef)) - ;;; The line number on which the clef is located on the staff. ;;; The bottom line of the staff is number 1. (defgeneric lineno (clef)) -(defclass clef () - ((name :reader name :initarg :name :initform nil) +(defclass clef (gsharp-object name-mixin) + ((print-character :allocation :class :initform #\K) (lineno :reader lineno :initarg :lineno :initform nil))) -(defmethod print-object ((c clef) stream) - (with-slots (name lineno) c - (format stream "[K :name ~W :lineno ~W ] " name lineno))) +(defmethod print-object :after ((c clef) stream) + (format stream ":lineno ~W " (lineno c))) (defun make-clef (name &optional lineno) (declare (type (member :treble :bass :c :percussion) name) @@ -64,21 +77,22 @@ ;;; ;;; Staff -(defclass staff () - ((name :accessor name :initarg :name :initform "default staff"))) +(defclass staff (gsharp-object name-mixin) + () + (:default-initargs :name "default staff")) ;;; fiveline (defgeneric clef (fiveline-staff)) (defclass fiveline-staff (staff) - ((clef :accessor clef :initarg :clef :initform nil) + ((print-character :allocation :class :initform #\=) + (clef :accessor clef :initarg :clef :initform nil) (keysig :accessor keysig :initarg :keysig :initform (make-array 7 :initial-element :natural)))) -(defmethod print-object ((s fiveline-staff) stream) - (with-slots (name clef keysig) s - (format stream "[= :name ~W :clef ~W :keysig ~W ] " name clef keysig))) +(defmethod print-object :after ((s fiveline-staff) stream) + (format stream ":clef ~W :keysig ~W " (clef s) (keysig s))) (defun make-fiveline-staff (name &optional (clef (make-clef :treble))) (make-instance 'fiveline-staff :name name :clef clef)) @@ -105,11 +119,7 @@ ;;; lyric (defclass lyrics-staff (staff) - ()) - -(defmethod print-object ((s lyrics-staff) stream) - (with-slots (name) s - (format stream "[L :name ~W ] " name))) + ((print-character :allocation :class :initform #\L))) (defun make-lyrics-staff (name) (make-instance 'lyrics-staff :name name)) @@ -146,18 +156,19 @@ ;;; currently does not belong to any cluster. (defgeneric cluster (note)) -(defclass note () - ((cluster :initform nil :initarg :cluster :accessor cluster) +(defclass note (gsharp-object) + ((print-character :allocation :class :initform #\N) + (cluster :initform nil :initarg :cluster :accessor cluster) (pitch :initarg :pitch :reader pitch) (staff :initarg :staff :reader staff) (head :initarg :head :reader head) (accidentals :initarg :accidentals :reader accidentals) (dots :initarg :dots :reader dots))) -(defmethod print-object ((n note) stream) +(defmethod print-object :after ((n note) stream) (with-slots (pitch staff head accidentals dots) n (format stream - "[N :pitch ~W :staff ~W :head ~W :accidentals ~W :dots ~W ] " + ":pitch ~W :staff ~W :head ~W :accidentals ~W :dots ~W " pitch staff head accidentals dots))) ;;; Make a note with the pitch and staff given. @@ -240,7 +251,7 @@ (defgeneric dots (element)) (defgeneric (setf dots) (dots element)) -(defclass element () +(defclass element (gsharp-object) ((bar :initform nil :initarg :bar :reader bar) (notehead :initarg :notehead :accessor notehead) (rbeams :initarg :rbeams :accessor rbeams) @@ -248,6 +259,12 @@ (dots :initarg :dots :accessor dots) (xoffset :initform 0 :initarg :xoffset :accessor xoffset))) +(defmethod print-object :after ((e element) stream) + (with-slots (notehead rbeams lbeams dots xoffset) e + (format stream + ":notehead ~W :rbeams ~W :lbeams ~W :dots ~W :xoffset ~W " + notehead rbeams lbeams dots xoffset))) + (defmethod notehead-duration ((element element)) (ecase (notehead element) (:whole 1) @@ -290,15 +307,14 @@ (defgeneric remove-note (note)) (defclass cluster (melody-element) - ((notes :initform '() :initarg :notes :accessor notes) + ((print-character :allocation :class :initform #\%) + (notes :initform '() :initarg :notes :accessor notes) (stem-direction :initarg :stem-direction :accessor stem-direction) (stem-length :initform nil :initarg :stem-length :accessor stem-length))) -(defmethod print-object ((c cluster) stream) - (with-slots (notehead rbeams lbeams dots xoffset stem-direction notes) c - (format stream - "[% :notehead ~W :rbeams ~W :lbeams ~W :dots ~W :xoffset ~W :stem-direction ~W :notes ~W ] " - notehead rbeams lbeams dots xoffset stem-direction notes))) +(defmethod print-object :after ((c cluster) stream) + (with-slots (stem-direction notes) c + (format stream ":stem-direction ~W :notes ~W " stem-direction notes))) (defun make-cluster (rbeams lbeams dots notehead stem-direction) (make-instance 'cluster @@ -358,14 +374,13 @@ ;;; Rest (defclass rest (melody-element) - ((staff :initarg :staff :reader staff) + ((print-character :allocation :class :initform #\-) + (staff :initarg :staff :reader staff) (staff-pos :initarg :staff-pos :initform 4 :reader staff-pos))) -(defmethod print-object ((s rest) stream) - (with-slots (notehead rbeams lbeams dots xoffset staff staff-pos) s - (format stream - "[- :notehead ~W :rbeams ~W :lbeams ~W :dots ~W :xoffset ~W :staff ~W :staff-pos ~W ] " - notehead rbeams lbeams dots xoffset staff staff-pos))) +(defmethod print-object :after ((s rest) stream) + (with-slots (staff staff-pos) s + (format stream ":staff ~W :staff-pos ~W " staff staff-pos))) (defun make-rest (rbeams lbeams dots notehead staff) (make-instance 'rest @@ -403,7 +418,8 @@ ;;; Lyrics element (defclass lyrics-element (element) - ((staff :initarg :staff :reader staff) + ((print-character :allocation :class :initform #\A) + (staff :initarg :staff :reader staff) (text :initarg :text :initform (make-array 5 :adjustable t :element-type 'fixnum :fill-pointer 0) :reader text))) @@ -421,9 +437,9 @@ :rbeams rbeams :lbeams lbeams :dots dots :notehead notehead :staff staff)) -(defmethod print-object ((elem lyrics-element) stream) - (with-slots (notehead rbeams lbeams dots xoffset staff text) elem - (format stream "[A :notehead ~W :rbeams ~W :lbeams ~W :dots ~W :xoffset ~W :staff ~W :text ~W ] " notehead rbeams lbeams dots xoffset staff text))) +(defmethod print-object :after ((elem lyrics-element) stream) + (with-slots (staff text) elem + (format stream ":staff ~W :text ~W " staff text))) (defun read-lyrics-element-v3 (stream char n) (declare (ignore char n)) @@ -467,10 +483,13 @@ ;;; Delete an element from the bar to which it belongs. (defgeneric remove-element (element)) -(defclass bar () +(defclass bar (gsharp-object) ((slice :initform nil :initarg :slice :reader slice) (elements :initform '() :initarg :elements :reader elements))) +(defmethod print-object :after ((b bar) stream) + (format stream ":elements ~W " (elements b))) + (defmethod nb-elements ((bar bar)) (length (elements bar))) @@ -504,10 +523,8 @@ (setf elements (delete element elements :test #'eq))) (setf bar nil))) -(defclass melody-bar (bar) ()) - -(defmethod print-object ((b melody-bar) stream) - (format stream "[| :elements ~W ] " (elements b))) +(defclass melody-bar (bar) + ((print-character :allocation :class :initform #\|))) (defun make-melody-bar () (make-instance 'melody-bar)) @@ -537,10 +554,8 @@ #'read-melody-bar-v3 *gsharp-readtable-v3*) -(defclass lyrics-bar (bar) ()) - -(defmethod print-object ((b lyrics-bar) stream) - (format stream "[C :elements ~W ] " (elements b))) +(defclass lyrics-bar (bar) + ((print-character :allocation :class :initform #\C))) (defun make-lyrics-bar () (make-instance 'lyrics-bar)) @@ -579,12 +594,13 @@ ;;; Delete a bar from the slice to which it belongs. (defgeneric remove-bar (bar)) -(defclass slice () - ((layer :initform nil :initarg :layer :reader layer) +(defclass slice (gsharp-object) + ((print-character :allocation :class :initform #\/) + (layer :initform nil :initarg :layer :reader layer) (bars :initform '() :initarg :bars :reader bars))) -(defmethod print-object ((s slice) stream) - (format stream "[/ :bars ~W ] " (bars s))) +(defmethod print-object :after ((s slice) stream) + (format stream ":bars ~W " (bars s))) (defun make-empty-slice () (make-instance 'slice)) @@ -688,17 +704,23 @@ ;;; Return the tail slice of the layer (defgeneric tail (layer)) -(defclass layer () - ((name :initform "default layer" :initarg :name :accessor name) - (segment :initform nil :initarg :segment :reader segment) +(defclass layer (gsharp-object name-mixin) + ((segment :initform nil :initarg :segment :reader segment) (staves :initarg :staves :accessor staves) (head :initarg :head :accessor head) (body :initarg :body :accessor body) - (tail :initarg :tail :accessor tail))) + (tail :initarg :tail :accessor tail)) + (:default-initargs :name "default layer")) + +(defmethod print-object :after ((l layer) stream) + (with-slots (head body tail staves) l + (format stream ":staves ~W :head ~W :body ~W :tail ~W " + staves head body tail))) ;;; melody layer -(defclass melody-layer (layer) ()) +(defclass melody-layer (layer) + ((print-character :allocation :class :initform #\_))) (defmethod make-layer (name (initial-staff fiveline-staff)) (flet ((make-initialized-slice () @@ -716,11 +738,6 @@ (slot-value tail 'layer) result) result))) -(defmethod print-object ((l melody-layer) stream) - (with-slots (head body tail name staves) l - (format stream "[_ :name ~W :staves ~W :head ~W :body ~W :tail ~W ] " - name staves head body tail))) - (defun read-melody-layer-v2 (stream char n) (declare (ignore char n)) (let* ((staves (read stream nil nil t)) @@ -754,7 +771,8 @@ ;;; lyrics layer -(defclass lyrics-layer (layer) ()) +(defclass lyrics-layer (layer) + ((print-character :allocation :class :initform #\M))) (defmethod make-layer (name (initial-staff lyrics-staff)) (flet ((make-initialized-slice () @@ -772,11 +790,6 @@ (slot-value tail 'layer) result) result))) -(defmethod print-object ((l lyrics-layer) stream) - (with-slots (head body tail name staves) l - (format stream "[M :name ~W :staves ~W :head ~W :body ~W :tail ~W ] " - name staves head body tail))) - (defun read-lyrics-layer-v3 (stream char n) (declare (ignore char n)) (let* ((rest (read-delimited-list #\] stream t)) @@ -860,12 +873,13 @@ ;;; Delete a layer from the segment to which it belongs (defgeneric remove-layer (layer)) -(defclass segment () - ((buffer :initform nil :initarg :buffer :reader buffer) +(defclass segment (gsharp-object) + ((print-character :allocation :class :initform #\S) + (buffer :initform nil :initarg :buffer :reader buffer) (layers :initform '() :initarg :layers :reader layers))) -(defmethod print-object ((s segment) stream) - (format stream "[S :layers ~W ] " (layers s))) +(defmethod print-object :after ((s segment) stream) + (format stream ":layers ~W " (layers s))) (defun make-empty-segment () (make-instance 'segment)) @@ -974,8 +988,9 @@ (defvar *default-left-offset* 30) (defvar *default-left-margin* 20) -(defclass buffer () - ((segments :initform '() :initarg :segments :accessor segments) +(defclass buffer (gsharp-object) + ((print-character :allocation :class :initform #\B) + (segments :initform '() :initarg :segments :accessor segments) (staves :initform (list (make-fiveline-staff "default staff")) :initarg :staves :accessor staves) (min-width :initform *default-min-width* :initarg :min-width :accessor min-width) @@ -984,9 +999,9 @@ (left-offset :initform *default-left-offset* :initarg :left-offset :accessor left-offset) (left-margin :initform *default-left-margin* :initarg :left-margin :accessor left-margin))) -(defmethod print-object ((b buffer) stream) +(defmethod print-object :after ((b buffer) stream) (with-slots (staves segments min-width spacing-style right-edge left-offset left-margin) b - (format stream "[B :staves ~W :segments ~W :min-width ~W :spacing-style ~W :right-edge ~W :left-offset ~W :left-margin ~W ] " + (format stream ":staves ~W :segments ~W :min-width ~W :spacing-style ~W :right-edge ~W :left-offset ~W :left-margin ~W " staves segments min-width spacing-style right-edge left-offset left-margin))) (defun make-empty-buffer () From rstrandh at common-lisp.net Thu Aug 5 05:58:44 2004 From: rstrandh at common-lisp.net (Robert Strandh) Date: Wed, 04 Aug 2004 22:58:44 -0700 Subject: [gsharp-cvs] CVS update: gsharp/buffer.lisp Message-ID: Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv13827 Modified Files: buffer.lisp Log Message: Removed support for V2 files. I do not think Gsharp is sufficiently widely used that we have to care about legacy scores. Started moving code for initializing parents of various buffer elements from the reader function to :after methods on initialize-instance. This move allowed some factoring of code to a common superclass. Date: Wed Aug 4 22:58:44 2004 Author: rstrandh Index: gsharp/buffer.lisp diff -u gsharp/buffer.lisp:1.7 gsharp/buffer.lisp:1.8 --- gsharp/buffer.lisp:1.7 Wed Aug 4 12:59:28 2004 +++ gsharp/buffer.lisp Wed Aug 4 22:58:43 2004 @@ -1,9 +1,7 @@ (in-package :gsharp-buffer) -(defparameter *gsharp-readtable-v2* (copy-readtable)) (defparameter *gsharp-readtable-v3* (copy-readtable)) -(make-dispatch-macro-character #\[ nil *gsharp-readtable-v2*) (make-dispatch-macro-character #\[ nil *gsharp-readtable-v3*) (defun skip-until-close-bracket (stream) @@ -54,17 +52,6 @@ (:c 4) (:percussion 3))))) -(defun read-clef-v2 (stream char n) - (declare (ignore char n)) - (let ((name (read stream nil nil t)) - (lineno (read stream nil nil t))) - (skip-until-close-bracket stream) - (make-instance 'clef :name name :lineno lineno))) - -(set-dispatch-macro-character #\[ #\K - #'read-clef-v2 - *gsharp-readtable-v2*) - (defun read-clef-v3 (stream char n) (declare (ignore char n)) (apply #'make-instance 'clef (read-delimited-list #\] stream t))) @@ -97,17 +84,6 @@ (defun make-fiveline-staff (name &optional (clef (make-clef :treble))) (make-instance 'fiveline-staff :name name :clef clef)) -(defun read-fiveline-staff-v2 (stream char n) - (declare (ignore char n)) - (let ((clef (read stream nil nil t)) - (keysig (read stream nil nil t))) - (skip-until-close-bracket stream) - (make-instance 'fiveline-staff :clef clef :keysig keysig))) - -(set-dispatch-macro-character #\[ #\= - #'read-fiveline-staff-v2 - *gsharp-readtable-v2*) - (defun read-fiveline-staff-v3 (stream char n) (declare (ignore char n)) (apply #'make-instance 'fiveline-staff (read-delimited-list #\] stream t))) @@ -203,16 +179,12 @@ :pitch pitch :staff staff :head head :accidentals accidentals :dots dots)) -(defun read-note-v2 (stream char n) +(defun read-note-v3 (stream char n) (declare (ignore char n)) (apply #'make-instance 'note (read-delimited-list #\] stream t))) (set-dispatch-macro-character #\[ #\N - #'read-note-v2 - *gsharp-readtable-v2*) - -(set-dispatch-macro-character #\[ #\N - #'read-note-v2 + #'read-note-v3 *gsharp-readtable-v3*) ;;; Return true if note1 is considered less than note2. @@ -252,7 +224,7 @@ (defgeneric (setf dots) (dots element)) (defclass element (gsharp-object) - ((bar :initform nil :initarg :bar :reader bar) + ((bar :initform nil :initarg :bar :accessor bar) (notehead :initarg :notehead :accessor notehead) (rbeams :initarg :rbeams :accessor rbeams) (lbeams :initarg :lbeams :accessor lbeams) @@ -312,6 +284,11 @@ (stem-direction :initarg :stem-direction :accessor stem-direction) (stem-length :initform nil :initarg :stem-length :accessor stem-length))) +(defmethod initialize-instance :after ((c cluster) &rest args) + (declare (ignore args)) + (loop for note in (notes c) + do (setf (cluster note) c))) + (defmethod print-object :after ((c cluster) stream) (with-slots (stem-direction notes) c (format stream ":stem-direction ~W :notes ~W " stem-direction notes))) @@ -321,19 +298,12 @@ :rbeams rbeams :lbeams lbeams :dots dots :notehead notehead :stem-direction stem-direction)) -(defun read-cluster-v2 (stream char n) +(defun read-cluster-v3 (stream char n) (declare (ignore char n)) - (let ((cluster (apply #'make-instance 'cluster (read-delimited-list #\] stream t)))) - (loop for note in (notes cluster) do - (setf (slot-value note 'cluster) cluster)) - cluster)) + (apply #'make-instance 'cluster (read-delimited-list #\] stream t))) (set-dispatch-macro-character #\[ #\% - #'read-cluster-v2 - *gsharp-readtable-v2*) - -(set-dispatch-macro-character #\[ #\% - #'read-cluster-v2 + #'read-cluster-v3 *gsharp-readtable-v3*) (define-condition gsharp-condition (error) ()) @@ -387,24 +357,6 @@ :rbeams rbeams :lbeams lbeams :dots dots :notehead notehead :staff staff)) -(defun read-rest-v2 (stream char n) - (declare (ignore char n)) - (let ((notehead (read stream nil nil t)) - (rbeams (read stream nil nil t)) - (lbeams (read stream nil nil t)) - (dots (read stream nil nil t)) - (staff (read stream nil nil t)) - (staff-pos (read stream nil nil t))) - (skip-until-close-bracket stream) - (make-instance 'rest - :rbeams rbeams :lbeams lbeams - :dots dots :notehead notehead - :staff staff :staff-pos staff-pos))) - -(set-dispatch-macro-character #\[ #\- - #'read-rest-v2 - *gsharp-readtable-v2*) - (defun read-rest-v3 (stream char n) (declare (ignore char n)) (apply #'make-instance 'rest (read-delimited-list #\] stream t))) @@ -484,8 +436,13 @@ (defgeneric remove-element (element)) (defclass bar (gsharp-object) - ((slice :initform nil :initarg :slice :reader slice) - (elements :initform '() :initarg :elements :reader elements))) + ((slice :initform nil :initarg :slice :accessor slice) + (elements :initform '() :initarg :elements :accessor elements))) + +(defmethod initialize-instance :after ((b bar) &rest args) + (declare (ignore args)) + (loop for element in (elements b) + do (setf (bar element) b))) (defmethod print-object :after ((b bar) stream) (format stream ":elements ~W " (elements b))) @@ -529,26 +486,9 @@ (defun make-melody-bar () (make-instance 'melody-bar)) -(defun read-melody-bar-v2 (stream char n) - (declare (ignore char n)) - (let* ((elements (read stream nil nil t)) - (bar (make-instance 'melody-bar :elements elements))) - (loop for element in elements do - (setf (slot-value element 'bar) bar)) - (skip-until-close-bracket stream) - bar)) - -(set-dispatch-macro-character #\[ #\| - #'read-melody-bar-v2 - *gsharp-readtable-v2*) - (defun read-melody-bar-v3 (stream char n) (declare (ignore char n)) - (let* ((rest (read-delimited-list #\] stream t)) - (bar (apply #'make-instance 'melody-bar rest))) - (loop for element in (elements bar) do - (setf (slot-value element 'bar) bar)) - bar)) + (apply #'make-instance 'melody-bar (read-delimited-list #\] stream t))) (set-dispatch-macro-character #\[ #\| #'read-melody-bar-v3 @@ -562,11 +502,7 @@ (defun read-lyrics-bar-v3 (stream char n) (declare (ignore char n)) - (let* ((rest (read-delimited-list #\] stream t)) - (bar (apply #'make-instance 'lyrics-bar rest))) - (loop for element in (elements bar) do - (setf (slot-value element 'bar) bar)) - bar)) + (apply #'make-instance 'lyrics-bar (read-delimited-list #\] stream t))) (set-dispatch-macro-character #\[ #\C #'read-lyrics-bar-v3 @@ -596,8 +532,13 @@ (defclass slice (gsharp-object) ((print-character :allocation :class :initform #\/) - (layer :initform nil :initarg :layer :reader layer) - (bars :initform '() :initarg :bars :reader bars))) + (layer :initform nil :initarg :layer :accessor layer) + (bars :initform '() :initarg :bars :accessor bars))) + +(defmethod initialize-instance :after ((s slice) &rest args) + (declare (ignore args)) + (loop for bar in (bars s) + do (setf (slice bar) s))) (defmethod print-object :after ((s slice) stream) (format stream ":bars ~W " (bars s))) @@ -605,26 +546,9 @@ (defun make-empty-slice () (make-instance 'slice)) -(defun read-slice-v2 (stream char n) - (declare (ignore char n)) - (let* ((bars (read stream nil nil t)) - (slice (make-instance 'slice :bars bars))) - (loop for bar in bars do - (setf (slot-value bar 'slice) slice)) - (skip-until-close-bracket stream) - slice)) - -(set-dispatch-macro-character #\[ #\/ - #'read-slice-v2 - *gsharp-readtable-v2*) - (defun read-slice-v3 (stream char n) (declare (ignore char n)) - (let* ((rest (read-delimited-list #\] stream t)) - (slice (apply #'make-instance 'slice rest))) - (loop for bar in (bars slice) do - (setf (slot-value bar 'slice) slice)) - slice)) + (apply #'make-instance 'slice (read-delimited-list #\] stream t))) (set-dispatch-macro-character #\[ #\/ #'read-slice-v3 @@ -705,7 +629,7 @@ (defgeneric tail (layer)) (defclass layer (gsharp-object name-mixin) - ((segment :initform nil :initarg :segment :reader segment) + ((segment :initform nil :initarg :segment :accessor segment) (staves :initarg :staves :accessor staves) (head :initarg :head :accessor head) (body :initarg :body :accessor body) @@ -738,24 +662,6 @@ (slot-value tail 'layer) result) result))) -(defun read-melody-layer-v2 (stream char n) - (declare (ignore char n)) - (let* ((staves (read stream nil nil t)) - (head (read stream nil nil t)) - (body (read stream nil nil t)) - (tail (read stream nil nil t)) - (layer (make-instance 'melody-layer - :staves staves :head head :body body :tail tail))) - (setf (slot-value head 'layer) layer - (slot-value body 'layer) layer - (slot-value tail 'layer) layer) - (skip-until-close-bracket stream) - layer)) - -(set-dispatch-macro-character #\[ #\_ - #'read-melody-layer-v2 - *gsharp-readtable-v2*) - (defun read-melody-layer-v3 (stream char n) (declare (ignore char n)) (let* ((rest (read-delimited-list #\] stream t)) @@ -875,8 +781,8 @@ (defclass segment (gsharp-object) ((print-character :allocation :class :initform #\S) - (buffer :initform nil :initarg :buffer :reader buffer) - (layers :initform '() :initarg :layers :reader layers))) + (buffer :initform nil :initarg :buffer :accessor buffer) + (layers :initform '() :initarg :layers :accessor layers))) (defmethod print-object :after ((s segment) stream) (format stream ":layers ~W " (layers s))) @@ -889,19 +795,6 @@ (add-layer (make-layer "Default layer" staff) segment) segment)) -(defun read-segment-v2 (stream char n) - (declare (ignore char n)) - (let* ((layers (read stream nil nil t)) - (segment (make-instance 'segment :layers layers))) - (loop for layer in layers do - (setf (slot-value layer 'segment) segment)) - (skip-until-close-bracket stream) - segment)) - -(set-dispatch-macro-character #\[ #\S - #'read-segment-v2 - *gsharp-readtable-v2*) - (defun read-segment-v3 (stream char n) (declare (ignore char n)) (let* ((rest (read-delimited-list #\] stream t)) @@ -1012,20 +905,6 @@ (add-segment (make-initialized-segment (car (staves buffer))) buffer 0) buffer)) -(defun read-buffer-v2 (stream char n) - (declare (ignore char n)) - (let* ((staves (read stream nil nil t)) - (segments (read stream nil nil t)) - (buffer (make-instance 'buffer :staves staves :segments segments))) - (loop for segment in segments do - (setf (slot-value segment 'buffer) buffer)) - (skip-until-close-bracket stream) - buffer)) - -(set-dispatch-macro-character #\[ #\B - #'read-buffer-v2 - *gsharp-readtable-v2*) - (defun read-buffer-v3 (stream char n) (declare (ignore char n)) (let* ((rest (read-delimited-list #\] stream t)) @@ -1148,8 +1027,7 @@ (format stream "Unknown file version")))) (defparameter *readtables* - `(("G#V2" . ,*gsharp-readtable-v2*) - ("G#V3" . ,*gsharp-readtable-v3*))) + `(("G#V3" . ,*gsharp-readtable-v3*))) (defun read-everything (filename) (assert (probe-file filename) () 'file-does-not-exist) From rstrandh at common-lisp.net Thu Aug 5 06:31:57 2004 From: rstrandh at common-lisp.net (Robert Strandh) Date: Wed, 04 Aug 2004 23:31:57 -0700 Subject: [gsharp-cvs] CVS update: gsharp/buffer.lisp gsharp/numbering.lisp Message-ID: Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv24928 Modified Files: buffer.lisp numbering.lisp Log Message: Finished factoring out code to initialize parent slots from readers to :after methods of initialize-instance. Fixed a bug in numbering.lisp, where :after method specilized on layer instead of nlayer. Date: Wed Aug 4 23:31:57 2004 Author: rstrandh Index: gsharp/buffer.lisp diff -u gsharp/buffer.lisp:1.8 gsharp/buffer.lisp:1.9 --- gsharp/buffer.lisp:1.8 Wed Aug 4 22:58:43 2004 +++ gsharp/buffer.lisp Wed Aug 4 23:31:57 2004 @@ -636,6 +636,12 @@ (tail :initarg :tail :accessor tail)) (:default-initargs :name "default layer")) +(defmethod initialize-instance :after ((l layer) &rest args) + (declare (ignore args)) + (setf (layer (head l)) l + (layer (body l)) l + (layer (tail l)) l)) + (defmethod print-object :after ((l layer) stream) (with-slots (head body tail staves) l (format stream ":staves ~W :head ~W :body ~W :tail ~W " @@ -664,12 +670,7 @@ (defun read-melody-layer-v3 (stream char n) (declare (ignore char n)) - (let* ((rest (read-delimited-list #\] stream t)) - (layer (apply #'make-instance 'melody-layer rest))) - (setf (slot-value (head layer) 'layer) layer - (slot-value (body layer) 'layer) layer - (slot-value (tail layer) 'layer) layer) - layer)) + (apply #'make-instance 'melody-layer (read-delimited-list #\] stream t))) (set-dispatch-macro-character #\[ #\_ #'read-melody-layer-v3 @@ -698,12 +699,7 @@ (defun read-lyrics-layer-v3 (stream char n) (declare (ignore char n)) - (let* ((rest (read-delimited-list #\] stream t)) - (layer (apply #'make-instance 'lyrics-layer rest))) - (setf (slot-value (head layer) 'layer) layer - (slot-value (body layer) 'layer) layer - (slot-value (tail layer) 'layer) layer) - layer)) + (apply #'make-instance 'lyrics-layer (read-delimited-list #\] stream t))) (set-dispatch-macro-character #\[ #\M #'read-lyrics-layer-v3 @@ -784,6 +780,11 @@ (buffer :initform nil :initarg :buffer :accessor buffer) (layers :initform '() :initarg :layers :accessor layers))) +(defmethod initialize-instance :after ((s segment) &rest args) + (declare (ignore args)) + (loop for layer in (layers s) + do (setf (segment layer) s))) + (defmethod print-object :after ((s segment) stream) (format stream ":layers ~W " (layers s))) @@ -797,11 +798,7 @@ (defun read-segment-v3 (stream char n) (declare (ignore char n)) - (let* ((rest (read-delimited-list #\] stream t)) - (segment (apply #'make-instance 'segment rest))) - (loop for layer in (layers segment) do - (setf (slot-value layer 'segment) segment)) - segment)) + (apply #'make-instance 'segment (read-delimited-list #\] stream t))) (set-dispatch-macro-character #\[ #\S #'read-segment-v3 @@ -892,6 +889,11 @@ (left-offset :initform *default-left-offset* :initarg :left-offset :accessor left-offset) (left-margin :initform *default-left-margin* :initarg :left-margin :accessor left-margin))) +(defmethod initialize-instance :after ((b buffer) &rest args) + (declare (ignore args)) + (loop for segment in (segments b) + do (setf (buffer segment) b))) + (defmethod print-object :after ((b buffer) stream) (with-slots (staves segments min-width spacing-style right-edge left-offset left-margin) b (format stream ":staves ~W :segments ~W :min-width ~W :spacing-style ~W :right-edge ~W :left-offset ~W :left-margin ~W " @@ -907,11 +909,7 @@ (defun read-buffer-v3 (stream char n) (declare (ignore char n)) - (let* ((rest (read-delimited-list #\] stream t)) - (buffer (apply #'make-instance 'buffer rest))) - (loop for segment in (segments buffer) do - (setf (slot-value segment 'buffer) buffer)) - buffer)) + (apply #'make-instance 'buffer (read-delimited-list #\] stream t))) (set-dispatch-macro-character #\[ #\B #'read-buffer-v3 Index: gsharp/numbering.lisp diff -u gsharp/numbering.lisp:1.2 gsharp/numbering.lisp:1.3 --- gsharp/numbering.lisp:1.2 Fri Jul 23 09:51:16 2004 +++ gsharp/numbering.lisp Wed Aug 4 23:31:57 2004 @@ -64,7 +64,7 @@ (defnclass nlayer layer ()) -(defmethod initialize-instance :after ((layer layer) &rest args) +(defmethod initialize-instance :after ((layer nlayer) &rest args) (declare (ignore args)) (setf (number (head layer)) 0 (number (body layer)) 1 From rstrandh at common-lisp.net Fri Aug 6 15:47:36 2004 From: rstrandh at common-lisp.net (Robert Strandh) Date: Fri, 06 Aug 2004 08:47:36 -0700 Subject: [gsharp-cvs] CVS update: gsharp/Flexichain/flexichain.lisp gsharp/Flexichain/flexicursor.lisp Message-ID: Update of /project/gsharp/cvsroot/gsharp/Flexichain In directory common-lisp.net:/tmp/cvs-serv27009 Modified Files: flexichain.lisp flexicursor.lisp Log Message: Completely modified the implementation of cursors. Now, a cursorchain can hold a large number of cursors without any negative impact on performance. For cursorchains, the flexichain buffer now has a parallel that holds per-element lists of cursors that stick to that element. Introduced new generic functions in the internal protocol fill-gap and resize-buffer. Updated the documentation accordingly. Date: Fri Aug 6 08:47:36 2004 Author: rstrandh Index: gsharp/Flexichain/flexichain.lisp diff -u gsharp/Flexichain/flexichain.lisp:1.1 gsharp/Flexichain/flexichain.lisp:1.2 --- gsharp/Flexichain/flexichain.lisp:1.1 Sun Aug 1 08:27:19 2004 +++ gsharp/Flexichain/flexichain.lisp Fri Aug 6 08:47:36 2004 @@ -385,15 +385,20 @@ (when (and (<= start2 data-start) (< data-start end2)) (incf data-start (- start1 start2))))) +(defgeneric fill-gap (standard-flexichain start end) + (:documentation "fill part of gap with the fill element")) + +(defmethod fill-gap ((fc standard-flexichain) start end) + (with-slots (buffer fill-element) fc + (fill buffer fill-element :start start :end end))) + (defun push-elements-left (chain count) "Pushes the COUNT elements of CHAIN at the right of the gap, to the beginning of the gap. The gap must be continuous. Example: PUSH-ELEMENTS-LEFT abcd-----efghijklm 2 => abcdef-----ghijklm" - (with-slots (buffer gap-start gap-end fill-element) chain + (with-slots (buffer gap-start gap-end) chain (move-elements chain buffer buffer gap-start gap-end (+ gap-end count)) - (fill buffer fill-element - :start (max gap-end (+ gap-start count)) - :end (+ gap-end count)) + (fill-gap chain (max gap-end (+ gap-start count)) (+ gap-end count)) (incf gap-start count) (incf gap-end count) (normalize-indices chain))) @@ -402,14 +407,12 @@ "Pushes the COUNT elements of CHAIN at the left of the gap, to the end of the gap. The gap must be continuous. Example: PUSH-ELEMENTS-RIGHT abcd-----efghijklm 2 => ab-----cdefghijklm" - (with-slots (buffer gap-start gap-end fill-element) chain + (with-slots (buffer gap-start gap-end) chain (let* ((buffer-size (length buffer)) (rotated-gap-end (if (zerop gap-end) buffer-size gap-end))) (move-elements chain buffer buffer (- rotated-gap-end count) (- gap-start count) gap-start) - (fill buffer fill-element - :start (- gap-start count) - :end (min gap-start (- rotated-gap-end count))) + (fill-gap chain (- gap-start count) (min gap-start (- rotated-gap-end count))) (decf gap-start count) (setf gap-end (- rotated-gap-end count)) (normalize-indices chain)))) @@ -418,13 +421,12 @@ "Moves the COUNT rightmost elements to the end of the gap, on the left of the data. Example: HOP-ELEMENTS-LEFT ---abcdefghijklm--- 2 => -lmabcdefghijk-----" - (with-slots (buffer gap-start gap-end fill-element) chain + (with-slots (buffer gap-start gap-end) chain (let* ((buffer-size (length buffer)) (rotated-gap-start (if (zerop gap-start) buffer-size gap-start))) (move-elements chain buffer buffer (- gap-end count) (- rotated-gap-start count) rotated-gap-start) - (fill buffer fill-element - :start (- rotated-gap-start count) :end rotated-gap-start) + (fill-gap chain (- rotated-gap-start count) rotated-gap-start) (setf gap-start (- rotated-gap-start count)) (decf gap-end count) (normalize-indices chain)))) @@ -433,9 +435,9 @@ "Moves the COUNT leftmost elements to the beginning of the gap, on the right of the data. Example: HOP-ELEMENTS-RIGHT ---abcdefghijklm--- 2 => -----cdefghijklmab-" - (with-slots (buffer gap-start gap-end fill-element) chain + (with-slots (buffer gap-start gap-end) chain (move-elements chain buffer buffer gap-start gap-end (+ gap-end count)) - (fill buffer fill-element :start gap-end :end (+ gap-end count)) + (fill-gap chain gap-end (+ gap-end count)) (incf gap-start count) (incf gap-end count) (normalize-indices chain))) @@ -446,31 +448,34 @@ (defun decrease-buffer-size (chain) (resize-buffer chain (required-space chain (nb-elements chain)))) -(defun resize-buffer (chain new-buffer-size) +(defgeneric resize-buffer (standard-flexichain new-buffer-size) + (:documentation "allocate a new buffer with the size indicated")) + +(defmethod resize-buffer ((fc standard-flexichain) new-buffer-size) (with-slots (buffer gap-start gap-end - fill-element element-type expand-factor) chain + fill-element element-type expand-factor) fc (let ((buffer-size (length buffer)) (buffer-after (make-array new-buffer-size :element-type element-type :initial-element fill-element))) - (case (gap-location chain) + (case (gap-location fc) ((:gap-empty :gap-middle) - (move-elements chain buffer-after buffer 0 0 gap-start) + (move-elements fc buffer-after buffer 0 0 gap-start) (let ((gap-end-after (- new-buffer-size (- buffer-size gap-end)))) - (move-elements chain buffer-after buffer gap-end-after gap-end buffer-size) + (move-elements fc buffer-after buffer gap-end-after gap-end buffer-size) (setf gap-end gap-end-after))) (:gap-right - (move-elements chain buffer-after buffer 0 0 gap-start)) + (move-elements fc buffer-after buffer 0 0 gap-start)) (:gap-left - (let ((gap-end-after (- new-buffer-size (nb-elements chain)))) - (move-elements chain buffer-after buffer gap-end-after gap-end buffer-size) + (let ((gap-end-after (- new-buffer-size (nb-elements fc)))) + (move-elements fc buffer-after buffer gap-end-after gap-end buffer-size) (setf gap-end gap-end-after))) (:gap-non-contiguous - (move-elements chain buffer-after buffer 0 gap-end gap-start) + (move-elements fc buffer-after buffer 0 gap-end gap-start) (decf gap-start gap-end) (setf gap-end 0))) (setf buffer buffer-after))) - (normalize-indices chain)) + (normalize-indices fc)) (defun normalize-indices (chain) "Sets gap limits to 0 if they are at the end of the buffer." Index: gsharp/Flexichain/flexicursor.lisp diff -u gsharp/Flexichain/flexicursor.lisp:1.1 gsharp/Flexichain/flexicursor.lisp:1.2 --- gsharp/Flexichain/flexicursor.lisp:1.1 Sun Aug 1 08:27:19 2004 +++ gsharp/Flexichain/flexicursor.lisp Fri Aug 6 08:47:36 2004 @@ -101,41 +101,74 @@ (:documentation "Replaces the element immediately after the cursor.")) (defclass standard-cursorchain (cursorchain standard-flexichain) - ((cursors :accessor cursorchain-cursors :initform '())) + ((cursors :accessor cursorchain-cursors) + (temp-cursors :initform nil)) (:documentation "The standard instantiable subclass of CURSORCHAIN")) +(defmethod initialize-instance :after ((cc standard-cursorchain) &rest args) + (declare (ignore args)) + (with-slots (buffer cursors) cc + (setf cursors (make-array (length buffer) :initial-element '())))) + +(defmethod resize-buffer :around ((cc standard-cursorchain) new-buffer-size) + (with-slots (cursors temp-cursors) cc + (setf temp-cursors (make-array new-buffer-size :initial-element '())) + (call-next-method) + (setf cursors temp-cursors + temp-cursors nil))) + +(defmethod move-elements :after ((cc standard-cursorchain) to from start1 start2 end2) + (declare (ignore to from)) + (with-slots (cursors temp-cursors) cc + (let ((destination (or temp-cursors cursors))) + (replace destination cursors :start1 start1 :start2 start2 :end2 end2) + (loop for i from start1 below (+ start1 (- end2 start2)) + do (setf (aref destination i) + (loop for cursor-wp in (aref destination i) + as cursor = (weak-pointer-value cursor-wp) + when cursor + do (setf (flexicursor-index cursor) i) + and collect cursor-wp)))))) + +(defmethod fill-gap :after ((cc standard-cursorchain) start end) + (with-slots (cursors) cc + (fill cursors '() :start start :end end))) + (defclass standard-flexicursor (flexicursor) ((chain :reader chain :initarg :chain) - (index :accessor flexicursor-index :initarg :index)) + (index :accessor flexicursor-index)) (:documentation "The standard instantiable subclass of FLEXICURSOR")) (defclass left-sticky-flexicursor (standard-flexicursor) ()) (defclass right-sticky-flexicursor (standard-flexicursor) ()) -(defmethod initialize-instance :after ((cursor standard-flexicursor) - &rest initargs) - (declare (ignore initargs)) - (with-slots (chain) cursor - (push (make-weak-pointer cursor) - (cursorchain-cursors chain)))) - (defmethod initialize-instance :after ((cursor left-sticky-flexicursor) &rest initargs) (declare (ignore initargs)) (with-slots (index chain) cursor - (setf index (slot-value chain 'data-start)))) + (setf index (slot-value chain 'data-start)) + (with-slots (cursors) chain + (push (make-weak-pointer cursor) + (aref cursors (slot-value chain 'data-start)))))) (defmethod initialize-instance :after ((cursor right-sticky-flexicursor) &rest initargs) (declare (ignore initargs)) (with-slots (index chain) cursor - (setf index (position-index chain 0)))) + (setf index (position-index chain 0)) + (with-slots (cursors) chain + (push (make-weak-pointer cursor) + (aref cursors (position-index chain 0)))))) (defmethod clone-cursor ((cursor standard-flexicursor)) (let ((result (make-instance (class-of cursor) :chain (chain cursor)))) - (setf (slot-value result 'index) (slot-value cursor 'index)))) + (setf (slot-value result 'index) (slot-value cursor 'index)) + (with-slots (cursors) (chain cursor) + (push (make-weak-pointer result) + (aref cursors (slot-value cursor 'index)))) + result)) (defmethod cursor-pos ((cursor left-sticky-flexicursor)) (1+ (index-position (chain cursor) (slot-value cursor 'index)))) @@ -167,7 +200,15 @@ (t (let ((cursor-pos (cursor-pos cursor))) (assert (<= (+ n cursor-pos) (nb-elements (chain cursor))) () 'at-end-error :cursor cursor) - (setf (cursor-pos cursor) (+ cursor-pos n)))))) + (with-slots (cursors) (chain cursor) + (with-slots (index) cursor + (setf (aref cursors index) + (delete cursor (aref cursors index) + :test #'eq + :key #'weak-pointer-value)) + (setf (cursor-pos cursor) (+ cursor-pos n)) + (push (make-weak-pointer cursor) + (aref cursors index)))))))) (defmethod move< ((cursor standard-flexicursor) &optional (n 1)) (cond ((minusp n) (move> cursor (- n))) @@ -175,15 +216,15 @@ (t (let ((cursor-pos (cursor-pos cursor))) (assert (>= cursor-pos n) () 'at-beginning-error :cursor cursor) - (setf (cursor-pos cursor) (- cursor-pos n)))))) - -(defmethod move-elements :after ((cc standard-cursorchain) to from start1 start2 end2) - (loop for cursor-wp in (cursorchain-cursors cc) - as cursor = (weak-pointer-value cursor-wp) - do (when cursor - (with-slots (index) cursor - (when (and (<= start2 index) (< index end2)) - (incf index (- start1 start2))))))) + (with-slots (cursors) (chain cursor) + (with-slots (index) cursor + (setf (aref cursors index) + (delete cursor (aref cursors index) + :test #'eq + :key #'weak-pointer-value)) + (setf (cursor-pos cursor) (- cursor-pos n)) + (push (make-weak-pointer cursor) + (aref cursors index)))))))) (defmethod insert ((cursor standard-flexicursor) object) (insert* (chain cursor) (cursor-pos cursor) object)) @@ -194,16 +235,16 @@ (insert cursor object)) sequence)) -(defmethod delete* :around ((chain standard-flexichain) position) +(defmethod delete* :around ((chain standard-cursorchain) position) (with-slots (cursors) chain - (let* ((index (position-index chain position)) - (save (loop for cursor-wp in cursors - as cursor = (weak-pointer-value cursor-wp) - when (and cursor (= (slot-value cursor 'index) index)) - collect cursor))) + (let ((save (aref cursors (position-index chain position)))) (call-next-method) - (loop for cursor in save - do (setf (cursor-pos cursor) position))))) + (loop for cursor-wp in save + as cursor = (weak-pointer-value cursor-wp) + when cursor + do (setf (cursor-pos cursor) position) + and do (push cursor-wp + (aref cursors (flexicursor-index cursor))))))) (defmethod delete> ((cursor standard-flexicursor) &optional (n 1)) (let ((chain (chain cursor)) From rstrandh at common-lisp.net Fri Aug 6 15:47:37 2004 From: rstrandh at common-lisp.net (Robert Strandh) Date: Fri, 06 Aug 2004 08:47:37 -0700 Subject: [gsharp-cvs] CVS update: gsharp/Flexichain/Doc/flexichain.tex Message-ID: Update of /project/gsharp/cvsroot/gsharp/Flexichain/Doc In directory common-lisp.net:/tmp/cvs-serv27009/Doc Modified Files: flexichain.tex Log Message: Completely modified the implementation of cursors. Now, a cursorchain can hold a large number of cursors without any negative impact on performance. For cursorchains, the flexichain buffer now has a parallel that holds per-element lists of cursors that stick to that element. Introduced new generic functions in the internal protocol fill-gap and resize-buffer. Updated the documentation accordingly. Date: Fri Aug 6 08:47:36 2004 Author: rstrandh Index: gsharp/Flexichain/Doc/flexichain.tex diff -u gsharp/Flexichain/Doc/flexichain.tex:1.1 gsharp/Flexichain/Doc/flexichain.tex:1.2 --- gsharp/Flexichain/Doc/flexichain.tex:1.1 Sun Aug 1 08:27:20 2004 +++ gsharp/Flexichain/Doc/flexichain.tex Fri Aug 6 08:47:36 2004 @@ -526,12 +526,18 @@ \subsection{Performance} -We assume that the number of cursors of a particular chain is -relatively small. Although under normal circumstances simple -operations like insert and delete will not take a time proportional to -the number of cursors, it is possible that cursors need to be -updated from time to time. We do not promise any bound on complexity -for a large number of cursors. +There can be a very large number of cursors in a chain without any +negative impact on performance. In particular, a sequence of insert +operations is not affected by the number of cursors of the chain. +For insert operations, we maintain the complexity proportional to the +distance between two consecutive positions. + +A delete operation takes time proportional to the number of +left-sticky cursors to the right of the element to delete plus the +number of right-sticky cursors to the left of it. + +The only bad case is thus a delete operation of an element with an +unbounded number of cursors sticking to it. \subsection{Protocol classes and functions} @@ -683,7 +689,9 @@ \section{Implementation of the \texttt{flexicursor} protocol} Cursors are stored as lists of weak references so that they can be -recycled when no longer referenced by client code. +recycled when no longer referenced by client code. A vector that +parallels the one holding elements of the flexichain holds per-element +lists of cursors that stick to that element. A cursor contains its \textit{index in the vector} as opposed to its \textit{position in the sequence}. This method avoids most updates of @@ -693,11 +701,12 @@ right-sticky cursors, we store $p$ itself. After a delete operation, cursors with indexes equal to the old value -of \texttt{gap-end} need to be updated to the new value of -\texttt{gap-end}, including the cursor that was used in the call. +of \texttt{gap-end} need to be updated. Right-sticky cursors will be +attached to the index corresponding to the new value of +\texttt{gap-end}, whereas left-sticky cursors get attached to the +position immediately preceding \texttt{gap-start}. -After an insert operation, only the cursor used in the call needs to -be incremented. All other cursors remain the same. +Insert operations do not affect cursors at all. Mixing of \texttt{flexicursor} and \texttt{flexichain} editing operations is possible thanks to an internal protocol for moving the From rstrandh at common-lisp.net Sun Aug 15 15:49:41 2004 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sun, 15 Aug 2004 08:49:41 -0700 Subject: [gsharp-cvs] CVS update: gsharp/gui.lisp gsharp/numbering.lisp Message-ID: Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv26973 Modified Files: gui.lisp numbering.lisp Log Message: Better filename completer that works for both SBCL and CMUCL. Gsharp no longer destroys the port before starting up. This is in preparation to run applications from the listener, or from some other application. Made some cosmetic changes after having learned about the existence of CONSTANTLY. *gsharp-frame* (is it still needed?) is no longer setf'ed but bound, so that each thread has its own copy. Added numbering of the segments of a buffer as :after method on initialize-instance on a buffer. Date: Sun Aug 15 08:49:41 2004 Author: rstrandh Index: gsharp/gui.lisp diff -u gsharp/gui.lisp:1.17 gsharp/gui.lisp:1.18 --- gsharp/gui.lisp:1.17 Sun Aug 1 08:14:33 2004 +++ gsharp/gui.lisp Sun Aug 15 08:49:41 2004 @@ -7,7 +7,7 @@ (bar (barno slice 0))) (make-cursor bar 0))) -(defvar *gsharp-frame*) +(defvar *gsharp-frame* nil) (defparameter *kbd-macro-recording-p* nil) (defparameter *kbd-macro-funs* '()) @@ -261,19 +261,73 @@ (declare (ignore condition)) (format stream "File nont found")))) +(defun filename-completer (so-far mode) + (flet ((remove-trail (s) + (subseq s 0 (let ((pos (position #\/ s :from-end t))) + (if pos (1+ pos) 0))))) + (let* ((directory-prefix + (if (and (plusp (length so-far)) (eql (aref so-far 0) #\/)) + "" + (namestring #+sbcl (car (directory ".")) #+cmu (ext:default-directory)))) + (full-so-far (concatenate 'string directory-prefix so-far)) + (pathnames + (loop with length = (length full-so-far) + for path in (directory (concatenate 'string + (remove-trail so-far) + "*.*")) + when (let ((mismatch (mismatch (namestring path) full-so-far))) + (or (null mismatch) (= mismatch length))) + collect path)) + (strings (mapcar #'namestring pathnames)) + (first-string (car strings)) + (length-common-prefix nil) + (completed-string nil) + (full-completed-string nil)) + (unless (null pathnames) + (setf length-common-prefix + (loop with length = (length first-string) + for string in (cdr strings) + do (setf length (min length (or (mismatch string first-string) length))) + finally (return length)))) + (unless (null pathnames) + (setf completed-string + (subseq first-string (length directory-prefix) + (if (null (cdr pathnames)) nil length-common-prefix))) + (setf full-completed-string + (concatenate 'string directory-prefix completed-string))) + (case mode + ((:complete-limited :complete-maximal) + (cond ((null pathnames) + (values so-far nil nil 0 nil)) + ((null (cdr pathnames)) + (values completed-string t (car pathnames) 1 nil)) + (t + (values completed-string nil nil (length pathnames) nil)))) + (:complete + (cond ((null pathnames) + (values so-far nil nil 0 nil)) + ((null (cdr pathnames)) + (values completed-string t (car pathnames) 1 nil)) + ((find full-completed-string strings :test #'string-equal) + (let ((pos (position full-completed-string strings :test #'string-equal))) + (values completed-string + t (elt pathnames pos) (length pathnames) nil))) + (t + (values completed-string nil nil (length pathnames) nil)))) + (:possibilities + (values nil nil nil (length pathnames) + (loop with length = (length directory-prefix) + for name in pathnames + collect (list (subseq (namestring name) length nil) + name)))))))) + + (define-presentation-method accept ((type completable-pathname) stream (view textual-view) &key) (multiple-value-bind (pathname success string) (complete-input stream - (lambda (so-far mode) - (complete-from-possibilities - so-far - #+cmu (ext:ambiguous-files so-far) #-cmu '() - '() - :action mode - :predicate (lambda (obj) (declare (ignore obj)) t) - :name-key #'namestring - :value-key #'identity)) + #'filename-completer + :partial-completers '(#\Space) :allow-any-input t) (declare (ignore success)) (or pathname string))) @@ -389,7 +443,7 @@ (layers (segment (cursor *gsharp-frame*))) '() :action mode - :predicate (lambda (obj) (declare (ignore obj)) t) + :predicate (constantly t) :name-key #'name :value-key #'identity))) (simple-parse-error () (error 'no-such-layer))) @@ -579,19 +633,31 @@ (error "write compatibility layer for RUN-PROGRAM"))) (defun run-gsharp () - (loop for port in climi::*all-ports* - do (destroy-port port)) - (setq climi::*all-ports* nil) (let* ((buffer (make-initialized-buffer)) (staff (car (staves buffer))) (input-state (make-input-state)) (cursor (make-initial-cursor buffer))) - (setf *gsharp-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*)) + (let ((*gsharp-frame* (make-application-frame 'gsharp + :buffer buffer + :input-state input-state + :cursor cursor))) + (setf (staves (car (layers (car (segments buffer))))) (list staff)) + (run-frame-top-level *gsharp-frame*)))) + +;; (defun run-gsharp () +;; (loop for port in climi::*all-ports* +;; do (destroy-port port)) +;; (setq climi::*all-ports* nil) +;; (let* ((buffer (make-initialized-buffer)) +;; (staff (car (staves buffer))) +;; (input-state (make-input-state)) +;; (cursor (make-initial-cursor buffer))) +;; (setf *gsharp-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*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -990,7 +1056,7 @@ (staves (buffer *gsharp-frame*)) '() :action mode - :predicate (lambda (obj) (declare (ignore obj)) t) + :predicate (constantly t) :name-key #'name :value-key #'identity))) (simple-parse-error () (error 'no-such-staff))) @@ -1035,7 +1101,7 @@ '(:fiveline :lyrics) '() :action mode - :predicate (lambda (obj) (declare (ignore obj)) t) + :predicate (constantly t) :name-key #'symbol-name-lowcase :value-key #'identity))) (simple-completion-error () (error 'no-such-staff-type))) @@ -1054,7 +1120,7 @@ '(:treble :bass :c :percussion) '() :action mode - :predicate (lambda (obj) (declare (ignore obj)) t) + :predicate (constantly t) :name-key #'symbol-name-lowcase :value-key #'identity))) (simple-completion-error () (error 'no-such-staff-type))) Index: gsharp/numbering.lisp diff -u gsharp/numbering.lisp:1.3 gsharp/numbering.lisp:1.4 --- gsharp/numbering.lisp:1.3 Wed Aug 4 23:31:57 2004 +++ gsharp/numbering.lisp Sun Aug 15 08:49:41 2004 @@ -98,6 +98,13 @@ ;;; ;;; Buffer +(defnclass nbuffer buffer + ()) + +(defmethod initialize-instance :after ((buffer nbuffer) &rest args) + (declare (ignore args)) + (number-elements (segments buffer))) + (defmethod add-segment :after ((segment nsegment) (buffer buffer) position) (declare (ignore position)) (number-elements (segments buffer))) From rstrandh at common-lisp.net Mon Aug 16 08:12:45 2004 From: rstrandh at common-lisp.net (Robert Strandh) Date: Mon, 16 Aug 2004 01:12:45 -0700 Subject: [gsharp-cvs] CVS update: gsharp/Flexichain/flexichain-package.lisp gsharp/Flexichain/skiplist-package.lisp gsharp/Flexichain/skiplist.lisp gsharp/Flexichain/flexicursor.lisp gsharp/Flexichain/package.lisp Message-ID: Update of /project/gsharp/cvsroot/gsharp/Flexichain In directory common-lisp.net:/tmp/cvs-serv17545 Modified Files: flexicursor.lisp Added Files: flexichain-package.lisp skiplist-package.lisp skiplist.lisp Removed Files: package.lisp Log Message: Removed package.lisp, I think I might start naming the package files mumble-package.lisp for the module mumble.lisp. Added flexichain-package.lisp to replace package.lisp. Added a new module for managing cursors: skiplist. This is a rotatable skiplist, which is like a skiplist, except that it allows "rotations", i.e. a prefix interval of keys can be moved to the end, and q suffix interval of keys can be moved to the beginning. All this in time proportional to log(n) + m (probabilistically, not worst-caase), where n is the size of the skiplist and m is the number of keys that need to be moved. I have (somewhat) tested the skiplist module, and it appears to work, though I may have broken something during the last minor update. The file flexicursor.lisp has been updated to use the skiplist module. I have not yet tested the result, though. Consider this commit as a backup as opposed to a commit of a version believed to be stable. Date: Mon Aug 16 01:12:45 2004 Author: rstrandh Index: gsharp/Flexichain/flexicursor.lisp diff -u gsharp/Flexichain/flexicursor.lisp:1.2 gsharp/Flexichain/flexicursor.lisp:1.3 --- gsharp/Flexichain/flexicursor.lisp:1.2 Fri Aug 6 08:47:36 2004 +++ gsharp/Flexichain/flexicursor.lisp Mon Aug 16 01:12:45 2004 @@ -101,38 +101,42 @@ (:documentation "Replaces the element immediately after the cursor.")) (defclass standard-cursorchain (cursorchain standard-flexichain) - ((cursors :accessor cursorchain-cursors) - (temp-cursors :initform nil)) + ((cursors :initform (make-instance 'skiplist) :accessor cursorchain-cursors)) (:documentation "The standard instantiable subclass of CURSORCHAIN")) -(defmethod initialize-instance :after ((cc standard-cursorchain) &rest args) - (declare (ignore args)) - (with-slots (buffer cursors) cc - (setf cursors (make-array (length buffer) :initial-element '())))) - -(defmethod resize-buffer :around ((cc standard-cursorchain) new-buffer-size) - (with-slots (cursors temp-cursors) cc - (setf temp-cursors (make-array new-buffer-size :initial-element '())) - (call-next-method) - (setf cursors temp-cursors - temp-cursors nil))) +(defun make-wp (value) + +sbcl (sb-ext:make-weak-pointer value) + +cmu (ext:make-wadk-pointer value)) + +(defun wp-value (wp) + +sbcl (sb-ext:weak-pointer-value wp) + +cmu (ext:weak-pointer-value wp)) (defmethod move-elements :after ((cc standard-cursorchain) to from start1 start2 end2) (declare (ignore to from)) - (with-slots (cursors temp-cursors) cc - (let ((destination (or temp-cursors cursors))) - (replace destination cursors :start1 start1 :start2 start2 :end2 end2) - (loop for i from start1 below (+ start1 (- end2 start2)) - do (setf (aref destination i) - (loop for cursor-wp in (aref destination i) - as cursor = (weak-pointer-value cursor-wp) - when cursor - do (setf (flexicursor-index cursor) i) - and collect cursor-wp)))))) - -(defmethod fill-gap :after ((cc standard-cursorchain) start end) - (with-slots (cursors) cc - (fill cursors '() :start start :end end))) + (let ((addfun (lambda (key wp-cursors) + (let ((increment (- start1 start2))) + (loop for wp in wp-cursors + as cursor = (wp-value wp) + unless (null cursor) + do (incf (flexicursor-index cursor) increment)) + (+ key increment))))) + (with-slots (cursors gap-start gap-end) cc + (cond ((= start1 start2) nil) + ((= gap-start gap-end) + (skiplist-slide-keys cursors start2 (1- end2) addfun)) + ((< e s) + (cond ((and (= end2 gap-start) (> start1 start2)) + (skiplist-slide-keys cursors start2 (1- end2) addfun)) + ((= end2 gap-start) + (skiplist-rotate-suffix cursors start2 addfun)) + (t skiplist-rotate-prefix cursors (1- end2) addfun))) + ((plusp gap-start) + (skiplist-slide-keys cursors start2 (1- end2) addfun)) + ((= start2 gap-end) + (skiplist-slide-keys cursors start2 (1- end2) addfun)) + (t + (skiplist-rotate-suffix cursors start2 addfun)))))) (defclass standard-flexicursor (flexicursor) ((chain :reader chain :initarg :chain) @@ -149,8 +153,7 @@ (with-slots (index chain) cursor (setf index (slot-value chain 'data-start)) (with-slots (cursors) chain - (push (make-weak-pointer cursor) - (aref cursors (slot-value chain 'data-start)))))) + (push (make-wp cursor) (skiplist-find cursors index))))) (defmethod initialize-instance :after ((cursor right-sticky-flexicursor) &rest initargs) @@ -158,17 +161,16 @@ (with-slots (index chain) cursor (setf index (position-index chain 0)) (with-slots (cursors) chain - (push (make-weak-pointer cursor) - (aref cursors (position-index chain 0)))))) + (push (make-wp cursor) (skilist-find cursors index))))) (defmethod clone-cursor ((cursor standard-flexicursor)) - (let ((result (make-instance (class-of cursor) - :chain (chain cursor)))) - (setf (slot-value result 'index) (slot-value cursor 'index)) - (with-slots (cursors) (chain cursor) - (push (make-weak-pointer result) - (aref cursors (slot-value cursor 'index)))) - result)) + (with-slots (index) cursor + (let ((result (make-instance (class-of cursor) + :chain (chain cursor)))) + (setf (slot-value result 'index) index) + (with-slots (cursors) (chain cursor) + (push (make-wp result) (skiplist-find cursors index))) + result))) (defmethod cursor-pos ((cursor left-sticky-flexicursor)) (1+ (index-position (chain cursor) (slot-value cursor 'index)))) @@ -202,13 +204,11 @@ 'at-end-error :cursor cursor) (with-slots (cursors) (chain cursor) (with-slots (index) cursor - (setf (aref cursors index) - (delete cursor (aref cursors index) - :test #'eq - :key #'weak-pointer-value)) + (setf (skiplist-find cursors index) + (delete index (skiplist-find cursors index) + :key #'wp-value :test #'eq)) (setf (cursor-pos cursor) (+ cursor-pos n)) - (push (make-weak-pointer cursor) - (aref cursors index)))))))) + (push (make-wp cursor) (skiplist-find cursors index)))))))) (defmethod move< ((cursor standard-flexicursor) &optional (n 1)) (cond ((minusp n) (move> cursor (- n))) @@ -218,13 +218,11 @@ 'at-beginning-error :cursor cursor) (with-slots (cursors) (chain cursor) (with-slots (index) cursor - (setf (aref cursors index) - (delete cursor (aref cursors index) - :test #'eq - :key #'weak-pointer-value)) + (setf (skiplist-find cursors index) + (delete index (skiplist-find cursors index) + :key #'wp-value :test #'eq)) (setf (cursor-pos cursor) (- cursor-pos n)) - (push (make-weak-pointer cursor) - (aref cursors index)))))))) + (push (make-wp cursor) (skiplist-find cursors index)))))))) (defmethod insert ((cursor standard-flexicursor) object) (insert* (chain cursor) (cursor-pos cursor) object)) @@ -237,14 +235,15 @@ (defmethod delete* :around ((chain standard-cursorchain) position) (with-slots (cursors) chain - (let ((save (aref cursors (position-index chain position)))) + (let* ((old-index (position-index chain position)) + (cursors (skiplist-find cursors old-index))) + (skiplist-delete cursors index) (call-next-method) (loop for cursor-wp in save - as cursor = (weak-pointer-value cursor-wp) + as cursor = (wp-value cursor-wp) when cursor do (setf (cursor-pos cursor) position) - and do (push cursor-wp - (aref cursors (flexicursor-index cursor))))))) + and do (push cursor-wp (skiplist-find cursors (flexicursor-index cursor))))))) (defmethod delete> ((cursor standard-flexicursor) &optional (n 1)) (let ((chain (chain cursor)) From rstrandh at common-lisp.net Thu Aug 19 13:58:56 2004 From: rstrandh at common-lisp.net (Robert Strandh) Date: Thu, 19 Aug 2004 06:58:56 -0700 Subject: [gsharp-cvs] CVS update: gsharp/Flexichain/flexichain.lisp gsharp/Flexichain/flexicursor.lisp Message-ID: Update of /project/gsharp/cvsroot/gsharp/Flexichain In directory common-lisp.net:/tmp/cvs-serv25601 Modified Files: flexichain.lisp flexicursor.lisp Log Message: Flexichain now compiles without errors and warnings, and the tester works properly. There are still cases where the cursors get assigned strange values, so it is not quite operational yet. Anyone wanting to run the tester should feel free to do so, though. I expect very little work is needed now to get it to run. But it is so boring that it is still going to take me some time to gather up the energy to actually do it. Date: Thu Aug 19 06:58:54 2004 Author: rstrandh Index: gsharp/Flexichain/flexichain.lisp diff -u gsharp/Flexichain/flexichain.lisp:1.2 gsharp/Flexichain/flexichain.lisp:1.3 --- gsharp/Flexichain/flexichain.lisp:1.2 Fri Aug 6 08:47:36 2004 +++ gsharp/Flexichain/flexichain.lisp Thu Aug 19 06:58:54 2004 @@ -196,7 +196,7 @@ (with-virtual-gap (bl ds gs ge) chain (- bl (- ge gs) 2))) -(defmethod empty-p ((chain standard-flexichain)) +(defmethod flexi-empty-p ((chain standard-flexichain)) (zerop (nb-elements chain))) (defgeneric insert-object (chain position object) Index: gsharp/Flexichain/flexicursor.lisp diff -u gsharp/Flexichain/flexicursor.lisp:1.3 gsharp/Flexichain/flexicursor.lisp:1.4 --- gsharp/Flexichain/flexicursor.lisp:1.3 Mon Aug 16 01:12:45 2004 +++ gsharp/Flexichain/flexicursor.lisp Thu Aug 19 06:58:54 2004 @@ -54,6 +54,9 @@ (defgeneric cursor-pos (cursor) (:documentation "Returns the position of the cursor.")) +(defgeneric (setf cursor-pos) (posistion cursor) + (:documentation "Set the position of the cursor.")) + (defgeneric at-beginning-p (cursor) (:documentation "Returns true if the cursor is at the beginning of the chain.")) @@ -68,19 +71,12 @@ (defgeneric move< (cursor &optional n) (:documentation "Moves the cursor backward N positions.")) -(defgeneric insert< (cursor object) - (:documentation "Inserts an object before the cursor.")) - -(defgeneric insert> (cursor object) - (:documentation "Inserts an object after the cursor.")) +(defgeneric insert (cursor object) + (:documentation "Inserts an object at the cursor.")) -(defgeneric insert-sequence< (cursor sequence) +(defgeneric insert-sequence (cursor sequence) (:documentation "The effect is the same as if each element of the -sequence was inserted using INSERT<.")) - -(defgeneric insert-sequence> (cursor sequence) - (:documentation "The effect is the same as if each element of the -sequence was inserted using INSERT>.")) +sequence was inserted using INSERT.")) (defgeneric delete< (cursor &optional n) (:documentation "Deletes N objects before the cursor.")) @@ -105,12 +101,12 @@ (:documentation "The standard instantiable subclass of CURSORCHAIN")) (defun make-wp (value) - +sbcl (sb-ext:make-weak-pointer value) - +cmu (ext:make-wadk-pointer 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)) + #+sbcl (sb-ext:weak-pointer-value wp) + #+cmu (ext:weak-pointer-value wp)) (defmethod move-elements :after ((cc standard-cursorchain) to from start1 start2 end2) (declare (ignore to from)) @@ -125,12 +121,12 @@ (cond ((= start1 start2) nil) ((= gap-start gap-end) (skiplist-slide-keys cursors start2 (1- end2) addfun)) - ((< e s) + ((< gap-end gap-start) (cond ((and (= end2 gap-start) (> start1 start2)) (skiplist-slide-keys cursors start2 (1- end2) addfun)) ((= end2 gap-start) (skiplist-rotate-suffix cursors start2 addfun)) - (t skiplist-rotate-prefix cursors (1- end2) addfun))) + (t (skiplist-rotate-prefix cursors (1- end2) addfun)))) ((plusp gap-start) (skiplist-slide-keys cursors start2 (1- end2) addfun)) ((= start2 gap-end) @@ -161,7 +157,7 @@ (with-slots (index chain) cursor (setf index (position-index chain 0)) (with-slots (cursors) chain - (push (make-wp cursor) (skilist-find cursors index))))) + (push (make-wp cursor) (skiplist-find cursors index))))) (defmethod clone-cursor ((cursor standard-flexicursor)) (with-slots (index) cursor @@ -236,10 +232,11 @@ (defmethod delete* :around ((chain standard-cursorchain) position) (with-slots (cursors) chain (let* ((old-index (position-index chain position)) - (cursors (skiplist-find cursors old-index))) - (skiplist-delete cursors index) + (cursors-to-adjust (skiplist-find cursors old-index))) + (when cursors-to-adjust + (skiplist-delete cursors old-index)) (call-next-method) - (loop for cursor-wp in save + (loop for cursor-wp in cursors-to-adjust as cursor = (wp-value cursor-wp) when cursor do (setf (cursor-pos cursor) position) From rstrandh at common-lisp.net Sun Aug 22 05:01:06 2004 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sat, 21 Aug 2004 22:01:06 -0700 Subject: [gsharp-cvs] CVS update: gsharp/Flexichain/flexichain.lisp gsharp/Flexichain/flexicursor.lisp Message-ID: Update of /project/gsharp/cvsroot/gsharp/Flexichain In directory common-lisp.net:/tmp/cvs-serv8545 Modified Files: flexichain.lisp flexicursor.lisp Log Message: Fixed a bug where cursors were not deleted from the skiplist before the were moved, which resulted in multiple entries of a cursor in the skiplist. Fixed a test in flexichain the purpose of which was to determine whether to hop or to move was wrong, resulting in too many objects being moved in some cases. Date: Sat Aug 21 22:01:03 2004 Author: rstrandh Index: gsharp/Flexichain/flexichain.lisp diff -u gsharp/Flexichain/flexichain.lisp:1.3 gsharp/Flexichain/flexichain.lisp:1.4 --- gsharp/Flexichain/flexichain.lisp:1.3 Thu Aug 19 06:58:54 2004 +++ gsharp/Flexichain/flexichain.lisp Sat Aug 21 22:01:02 2004 @@ -331,7 +331,7 @@ on the right of the buffer." (with-slots (buffer gap-start gap-end) chain (let ((buffer-size (length buffer))) - (cond ((< (- gap-start hot-spot) (- buffer-size gap-start)) + (cond ((< (- gap-start hot-spot) hot-spot) (push-elements-right chain (- gap-start hot-spot))) ((<= hot-spot (- buffer-size gap-start)) (hop-elements-right chain hot-spot)) Index: gsharp/Flexichain/flexicursor.lisp diff -u gsharp/Flexichain/flexicursor.lisp:1.4 gsharp/Flexichain/flexicursor.lisp:1.5 --- gsharp/Flexichain/flexicursor.lisp:1.4 Thu Aug 19 06:58:54 2004 +++ gsharp/Flexichain/flexicursor.lisp Sat Aug 21 22:01:02 2004 @@ -201,7 +201,7 @@ (with-slots (cursors) (chain cursor) (with-slots (index) cursor (setf (skiplist-find cursors index) - (delete index (skiplist-find cursors index) + (delete cursor (skiplist-find cursors index) :key #'wp-value :test #'eq)) (setf (cursor-pos cursor) (+ cursor-pos n)) (push (make-wp cursor) (skiplist-find cursors index)))))))) @@ -215,7 +215,7 @@ (with-slots (cursors) (chain cursor) (with-slots (index) cursor (setf (skiplist-find cursors index) - (delete index (skiplist-find cursors index) + (delete cursor (skiplist-find cursors index) :key #'wp-value :test #'eq)) (setf (cursor-pos cursor) (- cursor-pos n)) (push (make-wp cursor) (skiplist-find cursors index))))))))