From crhodes at common-lisp.net  Thu Oct 18 14:56:00 2007
From: crhodes at common-lisp.net (crhodes)
Date: Thu, 18 Oct 2007 10:56:00 -0400 (EDT)
Subject: [gsharp-cvs] CVS gsharp/Mxml
Message-ID: <20071018145600.528E011A1@common-lisp.net>

Update of /project/gsharp/cvsroot/gsharp/Mxml
In directory clnet:/tmp/cvs-serv30616/Mxml

Log Message:
Directory /project/gsharp/cvsroot/gsharp/Mxml added to the repository





From crhodes at common-lisp.net  Thu Oct 18 14:56:04 2007
From: crhodes at common-lisp.net (crhodes)
Date: Thu, 18 Oct 2007 10:56:04 -0400 (EDT)
Subject: [gsharp-cvs] CVS gsharp/Mxml/tests
Message-ID: <20071018145604.AD64011A2@common-lisp.net>

Update of /project/gsharp/cvsroot/gsharp/Mxml/tests
In directory clnet:/tmp/cvs-serv30659/Mxml/tests

Log Message:
Directory /project/gsharp/cvsroot/gsharp/Mxml/tests added to the repository





From crhodes at common-lisp.net  Thu Oct 18 14:56:26 2007
From: crhodes at common-lisp.net (crhodes)
Date: Thu, 18 Oct 2007 10:56:26 -0400 (EDT)
Subject: [gsharp-cvs] CVS gsharp/Mxml/mxml-dtds
Message-ID: <20071018145626.AFE5670C0@common-lisp.net>

Update of /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds
In directory clnet:/tmp/cvs-serv30700/Mxml/mxml-dtds

Log Message:
Directory /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds added to the repository





From crhodes at common-lisp.net  Thu Oct 18 15:02:47 2007
From: crhodes at common-lisp.net (crhodes)
Date: Thu, 18 Oct 2007 11:02:47 -0400 (EDT)
Subject: [gsharp-cvs] CVS gsharp
Message-ID: <20071018150247.DE3763D07B@common-lisp.net>

Update of /project/gsharp/cvsroot/gsharp
In directory clnet:/tmp/cvs-serv30948

Modified Files:
	gsharp.asd packages.lisp 
Log Message:
Add MusicXML support.  Initial work from Brian Gruber (funded by 
Google's Summer of Code); subsequent development by Christophe Rhodes.

It's far from perfect now, but it needs checking in so that people can 
play with it.  It adds dependencies (puri and cxml) to gsharp; if this 
is a problem, we could make gsharp-mxml a separate system.

Git logs (from git tree at 
<http://www-jcsu.jesus.cam.ac.uk/~csr21/git/gsharp-mxml/.git>) follow:

commit 994cd15ec9f480be41515e699f22e7de1687d0ca
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Mon Sep 24 13:19:41 2007 +0100

    Add a restart to the same-duration case.  It's not good enough, but it allows
    interactive fixing key signatures in the middle of the bar.

commit cdc2098fac5399303e9515bc81ea65020ec8f109
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Wed Sep 19 11:07:28 2007 +0100

    Only add durations from rhythmic elements.

commit acc6cb410cd55dfe59eb30fe608b101a62651ae9
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Wed Sep 19 10:45:12 2007 +0100

    Whoops.  Fix export of notes with no displayed accidentals (from 
overzealous    alteration of CASE -> ECASE

commit dd8d72cac434a8c5a1932aa46db6447e08d9b6ad
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Wed Sep 19 10:41:09 2007 +0100

    Support for longs in MusicXML (import and export)

commit eab440b56b086e766dbd405a3fea44d9976f1a1f
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Wed Sep 19 09:16:07 2007 +0100

    Long ("lunga") patch from HEAD

commit 8cb34a4879ebb4dce06d8b99da761dfa6ad24cf9
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Tue Sep 18 15:43:51 2007 +0100

    Support semi- and sesqui- accidentals

commit 6ba8208d1f8475552a95f35a5e896248110b0efd
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Tue Sep 18 15:25:16 2007 +0100

    Really support breves (and breve rests) -- on output too.

commit a9c36278de0145c12f34123a29815809030b97c2
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Tue Sep 18 15:17:09 2007 +0100

    Slightly batched commit (several changes).

    * support :breve noteheads
    * better stringcase macro (and use it)
    * temporarily hack in "full" = "breve" for Goldsmiths use
    * use ECASE in one or two places to remove compiler warnings.

commit 3a3b980576f0d09ddee4de12f6f7b260932a5552
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Tue Sep 18 15:14:54 2007 +0100

    Slightly friendlier (with friends like this...) Import and Export commands.
    Sets the filepath and name of the buffer on import; sensible export default
    pathname.

commit 7d72a2a4a28f9668271189ebaf862518ada34877
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Tue Sep 18 15:13:31 2007 +0100

    Whitespace

commit b497d6f5111f20f5e8ac9a059578d3caaab1b832
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Mon Sep 17 21:33:29 2007 +0100

    space requirements fix from HEAD

commit 65d173efbcfa78e5edaf1adb9bceb0f7d619002d
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Mon Sep 17 12:04:08 2007 +0100

    Update to Brian Gruber's version of 17th September

commit 91d98d9e2a8d69418edd264ab6293a2f1dbc5a9f
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Mon Sep 17 11:54:53 2007 +0100

    Brian Gruber's patch of August 20th


--- /project/gsharp/cvsroot/gsharp/gsharp.asd	2007/07/11 15:28:13	1.16
+++ /project/gsharp/cvsroot/gsharp/gsharp.asd	2007/10/18 15:02:47	1.17
@@ -20,7 +20,7 @@
 						     :defaults *gsharp-directory*))
 			     collect `(:file ,(pathname-name p) :pathname ,p))))))
 
-(gsharp-defsystem (:gsharp :depends-on (:mcclim :flexichain :midi))
+(gsharp-defsystem (:gsharp :depends-on (:mcclim :flexichain :midi :puri :cxml))
    "packages"
    "utilities"
    "mf"
@@ -38,4 +38,6 @@
    "modes"
    "play"
    "gui"
-   "fontview")
+   "fontview"
+   "Mxml/mxml"
+   "Mxml/commands")
--- /project/gsharp/cvsroot/gsharp/packages.lisp	2007/08/07 11:06:09	1.62
+++ /project/gsharp/cvsroot/gsharp/packages.lisp	2007/10/18 15:02:47	1.63
@@ -177,6 +177,10 @@
 	   #:play-segment
 	   #:play-buffer))
 
+(defpackage :gsharp-mxml
+  (:use :cl :gsharp-buffer :gsharp-measure)
+  (:shadowing-import-from :gsharp-buffer #:rest))
+
 (defpackage :gsharp
   (:use :clim :clim-lisp :gsharp-utilities :esa :esa-buffer :esa-io
 	:gsharp-buffer :gsharp-cursor :gsharp-drawing :gsharp-numbering



From crhodes at common-lisp.net  Thu Oct 18 15:02:48 2007
From: crhodes at common-lisp.net (crhodes)
Date: Thu, 18 Oct 2007 11:02:48 -0400 (EDT)
Subject: [gsharp-cvs] CVS gsharp/Mxml
Message-ID: <20071018150248.7E78853010@common-lisp.net>

Update of /project/gsharp/cvsroot/gsharp/Mxml
In directory clnet:/tmp/cvs-serv30948/Mxml

Added Files:
	commands.lisp mxml.lisp 
Log Message:
Add MusicXML support.  Initial work from Brian Gruber (funded by 
Google's Summer of Code); subsequent development by Christophe Rhodes.

It's far from perfect now, but it needs checking in so that people can 
play with it.  It adds dependencies (puri and cxml) to gsharp; if this 
is a problem, we could make gsharp-mxml a separate system.

Git logs (from git tree at 
<http://www-jcsu.jesus.cam.ac.uk/~csr21/git/gsharp-mxml/.git>) follow:

commit 994cd15ec9f480be41515e699f22e7de1687d0ca
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Mon Sep 24 13:19:41 2007 +0100

    Add a restart to the same-duration case.  It's not good enough, but it allows
    interactive fixing key signatures in the middle of the bar.

commit cdc2098fac5399303e9515bc81ea65020ec8f109
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Wed Sep 19 11:07:28 2007 +0100

    Only add durations from rhythmic elements.

commit acc6cb410cd55dfe59eb30fe608b101a62651ae9
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Wed Sep 19 10:45:12 2007 +0100

    Whoops.  Fix export of notes with no displayed accidentals (from 
overzealous    alteration of CASE -> ECASE

commit dd8d72cac434a8c5a1932aa46db6447e08d9b6ad
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Wed Sep 19 10:41:09 2007 +0100

    Support for longs in MusicXML (import and export)

commit eab440b56b086e766dbd405a3fea44d9976f1a1f
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Wed Sep 19 09:16:07 2007 +0100

    Long ("lunga") patch from HEAD

commit 8cb34a4879ebb4dce06d8b99da761dfa6ad24cf9
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Tue Sep 18 15:43:51 2007 +0100

    Support semi- and sesqui- accidentals

commit 6ba8208d1f8475552a95f35a5e896248110b0efd
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Tue Sep 18 15:25:16 2007 +0100

    Really support breves (and breve rests) -- on output too.

commit a9c36278de0145c12f34123a29815809030b97c2
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Tue Sep 18 15:17:09 2007 +0100

    Slightly batched commit (several changes).

    * support :breve noteheads
    * better stringcase macro (and use it)
    * temporarily hack in "full" = "breve" for Goldsmiths use
    * use ECASE in one or two places to remove compiler warnings.

commit 3a3b980576f0d09ddee4de12f6f7b260932a5552
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Tue Sep 18 15:14:54 2007 +0100

    Slightly friendlier (with friends like this...) Import and Export commands.
    Sets the filepath and name of the buffer on import; sensible export default
    pathname.

commit 7d72a2a4a28f9668271189ebaf862518ada34877
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Tue Sep 18 15:13:31 2007 +0100

    Whitespace

commit b497d6f5111f20f5e8ac9a059578d3caaab1b832
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Mon Sep 17 21:33:29 2007 +0100

    space requirements fix from HEAD

commit 65d173efbcfa78e5edaf1adb9bceb0f7d619002d
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Mon Sep 17 12:04:08 2007 +0100

    Update to Brian Gruber's version of 17th September

commit 91d98d9e2a8d69418edd264ab6293a2f1dbc5a9f
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Mon Sep 17 11:54:53 2007 +0100

    Brian Gruber's patch of August 20th



--- /project/gsharp/cvsroot/gsharp/Mxml/commands.lisp	2007/10/18 15:02:48	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/commands.lisp	2007/10/18 15:02:48	1.1
(in-package :gsharp)

;;; like print-buffer-filename in gui.lisp
(defun export-buffer-filename ()
  (let* ((buffer (current-buffer))
         (filepath (filepath buffer))
         (name (name buffer))
         (defaults (or filepath (merge-pathnames (make-pathname :name name)
                                                 (user-homedir-pathname)))))
    (merge-pathnames (make-pathname :type "xml") defaults)))

;;; like directory-of-current-buffer in esa-io.lisp
(defun directory-of-current-buffer ()
  "Extract the directory part of the filepath to the file in the current buffer.
   If the current buffer does not have a filepath, the path to
   the user's home directory will be returned."
  (make-pathname
   :directory
   (pathname-directory
    (or (filepath (current-buffer))
        (user-homedir-pathname)))))

(define-gsharp-command (com-import-musicxml :name t)
    ((pathname 'pathname
               :prompt "Import From: " :prompt-mode :raw
               :default (directory-of-current-buffer) :default-type 'pathname
               :insert-default t))
  (let* ((buffer (gsharp-mxml::parse-mxml (gsharp-mxml::musicxml-document pathname)))
         (input-state (make-input-state))
         (cursor (make-initial-cursor buffer))
         (view (make-instance 'orchestra-view :buffer buffer :cursor cursor)))
    (setf (view (car (windows *application-frame*))) view
          (filepath buffer) (merge-pathnames (make-pathname :type "gsh") pathname)
          (name buffer) (file-namestring (filepath buffer))
          (input-state *application-frame*) input-state)
    (select-layer cursor (car (layers (segment (current-cursor)))))))
          
(define-gsharp-command (com-export-musicxml :name t)
    ((pathname 'pathname
               :prompt "Export To: " :prompt-mode :raw
               :default (export-buffer-filename) :default-type 'pathname
               :insert-default t))
  (let ((string (gsharp-mxml::write-mxml (current-buffer))))
    (with-open-file (s pathname :if-does-not-exist :create :if-exists :supersede :direction :output)
      (write-string string s))))
--- /project/gsharp/cvsroot/gsharp/Mxml/mxml.lisp	2007/10/18 15:02:48	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/mxml.lisp	2007/10/18 15:02:48	1.1
(in-package :gsharp-mxml)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Utility functions, macros
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmacro test-make-xml (obj id)
  `(cxml:with-xml-output (cxml:make-rod-sink :indentation 2 :canonical nil)
    (make-xml ,obj ,id)))
(defun write-buffer-to-xml-file (buffer filename)
  (with-open-file (s filename :direction :output)
    (write-string (write-mxml buffer) s)))

(defun pcdata (thing)
  (string-trim '(#\Space #\Tab #\Newline) 
               (dom:node-value (dom:first-child thing))))
(defun named-pcdata (node tag-name)
  (if (has-element-type node tag-name)
      (pcdata (elt (dom:get-elements-by-tag-name node tag-name) 0))
      nil))
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun expander-for-stringcase (keyform cases exhaustivep)
    (let ((nkey (gensym "KEY")))
      (flet ((expand-case (case)
               (destructuring-bind (keys &rest forms) case
                 (cond
                   ((member keys '(t otherwise))
                    (when exhaustivep
                      (warn "~S found in ~S" keys 'estringcase))
                    `(t , at forms))
                   ((stringp keys)
                    `((string= ,keys ,nkey) , at forms))
                   ((and (consp keys) (every #'stringp keys))
                    `((or ,@(loop for k in keys collect `(string= ,k ,nkey)))
                      , at forms))
                   (t
                    (warn "Unrecognized keys: ~S" keys))))))
        `(let ((,nkey ,keyform))
          (cond
            ,@(loop for case in cases collect (expand-case case))
            ,@(when exhaustivep
                `((t (error "~S failed to match any key in ~S"
                      ,nkey 'estringcase))))))))))

(defmacro stringcase (keyform &body cases)
  (expander-for-stringcase keyform cases nil))
(defmacro estringcase (keyform &body cases)
  (expander-for-stringcase keyform cases t))

(defun has-element-type (node type-name)
  (> (length (dom:get-elements-by-tag-name node type-name)) 0))

(defmacro for-named-elements ((name varname node) &body body)
  (let ((elements (gensym)))
    `(let ((,elements (dom:get-elements-by-tag-name ,node ,name)))
      (sequence:dosequence (,varname ,elements)
        , at body))))
(defmacro for-children ((varname node) &body body)
  (let ((children (gensym)))
    `(let ((,children (dom:child-nodes ,node)))
      (sequence:dosequence (,varname ,children)
        , at body))))

(defun map-all-lists-maximally (fn id-base &rest all-lists)
  (loop with lists = (copy-list all-lists)
     for i from id-base
     until (every #'null lists)
     collecting (apply fn i (mapcar #'car lists))
     do (map-into lists #'cdr lists)))

(defun split-if (predicate list)
  (loop for x in list
     if (funcall predicate x)
       collect x into a
     else
       collect x into b
     end
     finally (return (values a b))))

(defun find-if-nthcdr (predicate n sequence)
  "Finds the nth element that satisfies the predicate, and returns the
cdr with that element as the head"
  (let ((i 0))
    (do ((e sequence (cdr sequence)))
        ((= i n) e)
      (when (funcall predicate (car e))
        (incf i)))))

;; perhaps these should go in utilities.lisp
(defun unicode-to-string (unicode)
    (map 'string #'gsharp-utilities:unicode-to-char unicode))
(defun string-to-unicode (string)
    (map 'vector #'gsharp-utilities:char-to-unicode string))


;;;;;;;;;;;;;;;
;; Notes on mapping
;;
;; gsh maps to mxml pretty well:
;; staff == staff
;; voice == layer
;; cluster == chord
;;
;; Gsharp allows staffs to be in more than one layer, which isn't
;; explicit in mxml but is there: a note has to be in one staff, but
;; the notes in a chord can be in different ones while in the same
;; voice.
;;
;; the mapping seems to break down in that while mxml allows notes in
;; the same chord to be in different voices (though i'm not sure what
;; that would mean), a cluster in gsharp belongs to one layer. this
;; isn't a problem though, because the mapping of chord to cluster is
;; not really one-to-one.
;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;
;; Import
;;;;;;;;;;;;

(defun parse-mxml-note-duration (note-element)
  "Given a MusicXML note element, return the appropriate Gsharp
notehead, dots and beams values."
  ;; valid types: 256th, 128th, 64th, 32nd, 16th,
  ;; eighth, quarter, half, whole, breve, and long
  (let ((notehead
         (if (has-element-type note-element "type")
             (estringcase (named-pcdata note-element "type")
               (("256th" "128th" "64th" "32nd" "16th" "eighth" "quarter")
                :filled)
               ("half" :half)
               ("whole" :whole)
               (("breve" "full") :breve)
               ("long" :long))
             :filled))
        (beams
         (if (has-element-type note-element "type")
             (estringcase (named-pcdata note-element "type")
               ("256th" 6)
               ("128th" 5)
               ("64th" 4)
               ("32nd" 3)
               ("16th" 2)
               ("eighth" 1)
               (("quarter" "half" "whole" "breve" "full" "long") 0))
             0))
        (dots (length (dom:get-elements-by-tag-name note-element "dot"))))
    (values notehead beams dots)))

(defparameter *step-to-basenote* '((#\C . 0)
                                   (#\D . 1)
                                   (#\E . 2)
                                   (#\F . 3)
                                   (#\G . 4)
                                   (#\A . 5)
                                   (#\B . 6)))

(defun xmlnote-to-gsh (step octave)
  ;; C4 is middle C is 28
  (let ((basenum (cdr (assoc (char-upcase (character step)) *step-to-basenote*))))
    (+ basenum (* 7 octave))))

(defun parse-mxml-accidental (note)
  ;; TODO this should support microtones. also, i wrote it fairly
  ;; early on and it doesn't use things like has-element which it
  ;; should.
  (let ((alters (dom:get-elements-by-tag-name note "alter")))
    (if (= 0 (length alters))
        :natural
        (let ((alter (pcdata (elt alters 0))))
          (stringcase alter
            ("1" :sharp)
            ("0" :natural)
            ("-1" :flat)
            ("2" :double-sharp)
            ("1.5" :sesquisharp)
            ("0.5" :semisharp)
            ("-0.5" :semiflat)
            ("-1.5" :sesquiflat)
            ("-2" :double-flat)
            (t :natural))))))

(defun parse-mxml-note-staff-number (note)
  (if (has-element-type note "staff")
      (1- (parse-integer
           (named-pcdata note "staff")))
      0))

(defun parse-mxml-note-staff (note staves)
"Given an xml note element and a list of all the staff objects, return
the staff object the note is supposed to be assigned to. If none is
specified, returns the first (hopefully default) staff."
(let ((melody-staves
       (remove-if #'(lambda (s) (not (typep s 'fiveline-staff))) staves)))
  (elt melody-staves (parse-mxml-note-staff-number note))))

(defun parse-mxml-pitched-note (note staves)
  (let* ((staff (parse-mxml-note-staff note staves))
         (step (named-pcdata note "step"))
         (octave (parse-integer (named-pcdata note "octave")))
         (pitch (xmlnote-to-gsh step octave))
         (accidentals (parse-mxml-accidental note))
         (tie-left nil)
         (tie-right nil))
    (for-named-elements ("tied" tie note)
      (estringcase (dom:get-attribute tie "type")
        ("start" (setf tie-right t))
        ("stop" (setf tie-left t))))
    (make-instance 'note :pitch pitch :staff staff :accidentals accidentals
                   :tie-left tie-left :tie-right tie-right)))

(defvar *parsing-duration-gmeasure-position*)
(defvar *parsing-in-cluster*)
(defvar *mxml-divisions*)
(defun parse-mxml-note (xnote bars staves lyrics-layer-hash)
  ;; TODO: There is nothing in MusicXML that stops you from having
  ;; multiple notes in a chord that have different durations, types,
  ;; and dots, something which Gsharp does not support in any way.
  ;; However, this is not something often run into: if 2 notes struck
  ;; simultaneously have different rhythmic properties, they are
  ;; almost always to be notated in separate voices. Supporting the
  ;; rare case here is quite complicated, as it requires the
  ;; spontaneous creation of another layer to accommodate it, so for
  ;; now, this code will assume that all notes in a chord have the
  ;; same type and dots as the first one mentioned in the MusicXML
  ;; file. Suggested revision: throw a condition asking the user if
  ;; they want to omit the note or make it the same duration as the
  ;; others.

  ;; Also, this breaks if you have a rest in a chord, which you can
  ;; have in MusicXML, but I'm not really sure what that would be.
  (let ((bar (elt bars (if (has-element-type xnote "voice")
                           (1- (parse-integer (named-pcdata xnote "voice")))
                           0)))
        (advance 0))
    (multiple-value-bind (notehead beams dots)
        (parse-mxml-note-duration xnote)
    
      (when (has-element-type xnote "lyric")
        (let* ((xlyric (elt (dom:get-elements-by-tag-name xnote "lyric") 0))
               (lyrics-staff
                (cadr (find-if-nthcdr #'(lambda (s) (not (typep s 'lyrics-staff)))
                                      (parse-mxml-note-staff-number xnote)
                                      staves)))
               (lyrics-layer (gethash lyrics-staff lyrics-layer-hash))
               (lyrics-bar (car (last (bars (body lyrics-layer)))))
               (lyrics-element (make-lyrics-element lyrics-staff
                                                    :notehead notehead
                                                    :lbeams beams
                                                    :rbeams beams
                                                    :dots dots)))
          ;; TODO there can be multiple lyrics on a given xml-note,
          ;; presumably for verses or something. Right now this just
          ;; ignores all but the first one, but this should be addressed.
          (loop for c across (string-to-unicode (named-pcdata xlyric "text"))
             do (append-char lyrics-element c)) 
          (add-element-at-duration lyrics-element
                                   lyrics-bar
                                   *parsing-duration-gmeasure-position*)))
    
      (when (has-element-type xnote "rest")
        (let ((new-rest (make-rest (parse-mxml-note-staff xnote staves)
                                   :notehead notehead
                                   :lbeams beams
                                   :rbeams beams
                                   :dots dots)))
          (add-element-at-duration new-rest
                                   bar
                                   *parsing-duration-gmeasure-position*)
          (setf advance (duration new-rest))))
    
      (when (has-element-type xnote "pitch")
        (progn
          (unless (has-element-type xnote "chord")
            (multiple-value-bind (notehead beams dots)
                (parse-mxml-note-duration xnote)
              (setf *parsing-in-cluster* (make-cluster :notehead notehead
                                                       :lbeams beams
                                                       :rbeams beams
                                                       :dots dots)))
            (add-element-at-duration *parsing-in-cluster* bar *parsing-duration-gmeasure-position*)
            (setf advance (duration *parsing-in-cluster*)))
          (add-note *parsing-in-cluster* (parse-mxml-pitched-note xnote staves))))
    
      (incf *parsing-duration-gmeasure-position* advance))))

(defun add-element-at-duration (element bar duration-position)
  ;; go through the bar, adding up the 'duration' value of each element.
  ;; if the total is less than the desired duration-position,
  ;;   add an empty cluster of the appropriate length, and then add the new element.
  ;; when the sum is greater than the duration where the element should be placed, look at what the last element was
  ;; if it's not an empty element
  ;;   throw some kind of error
  ;; else
  ;;   concatenate empty elements together
  ;;   if there's not enough room, (this is a fairly complicated calculation), error
  ;;   else split up the empty cluster and insert the new element  
  (loop for ecdr = (elements bar) then (cdr ecdr)
     for e = (car ecdr)
     for position from 0
     until (null ecdr)
     for edur = (duration e)
     summing edur into total-duration
     until (> total-duration duration-position)
     finally
       (if (<= total-duration duration-position) ;;(this is going at the end of the bar)
           (progn
             (dolist (empty-cluster
                       (generate-empty-clusters (- duration-position total-duration)))
               (add-element empty-cluster bar position)
               (incf position))
             (add-element element bar position))
           (if (is-empty e)
               (let ((empty-duration
                      (loop for ee in ecdr
                         until (not (is-empty ee))
                         summing (duration ee))))
                 ;; make sure there is enough empty space
                 (if (> (duration element) empty-duration)
                     (error "There is not enough empty space to put this element")
                     (progn
                       ;; remove all the empty space
                       (loop for ee in ecdr
                          until (not (is-empty ee))
                          do (remove-element ee bar))
                       
                       ;; add back the needed empty preceding space
                       (dolist (empty-cluster
                                 (generate-empty-clusters (- duration-position (- total-duration edur))))
                         (add-element empty-cluster bar position)
                         (incf position))
                       
                       ;; add the element
                       (add-element element bar position)
                       (incf position)
                        
                       ;; add the trailing empty space
                       (dolist (empty-cluster
                                 (generate-empty-clusters
                                  (- empty-duration (- duration-position (- total-duration edur)) (duration element))))
                         (add-element empty-cluster bar position)
                         (incf position)))))
               ;; FIXME: this restart isn't actually good enough; it
               ;; is legitimate to have a new element at the same
               ;; offset from the start of the bar as a previous
               ;; element, as long as that previous element had zero
               ;; duration (e.g. key signature)
               (restart-case 
                   (error "There is already a non-empty element here")
                 (add-anyway ()
                   (add-element element bar position)
                   (incf position)))))))

(defgeneric is-empty (element))
(defmethod is-empty ((element element))
  nil)

[685 lines skipped]


From crhodes at common-lisp.net  Thu Oct 18 15:02:57 2007
From: crhodes at common-lisp.net (crhodes)
Date: Thu, 18 Oct 2007 11:02:57 -0400 (EDT)
Subject: [gsharp-cvs] CVS gsharp/Mxml/mxml-dtds
Message-ID: <20071018150257.B5199481A4@common-lisp.net>

Update of /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds
In directory clnet:/tmp/cvs-serv30948/Mxml/mxml-dtds

Added Files:
	ISOlat1.pen ISOlat2.pen MIDIEvents10.dtd attributes.dtd 
	barline.dtd common.dtd direction.dtd identity.dtd layout.dtd 
	link.dtd midixml.dtd midixml.xsl note.dtd opus.dtd 
	parttime.xsl partwise.dtd score.dtd timepart.xsl timewise.dtd 
	to10.xsl 
Log Message:
Add MusicXML support.  Initial work from Brian Gruber (funded by 
Google's Summer of Code); subsequent development by Christophe Rhodes.

It's far from perfect now, but it needs checking in so that people can 
play with it.  It adds dependencies (puri and cxml) to gsharp; if this 
is a problem, we could make gsharp-mxml a separate system.

Git logs (from git tree at 
<http://www-jcsu.jesus.cam.ac.uk/~csr21/git/gsharp-mxml/.git>) follow:

commit 994cd15ec9f480be41515e699f22e7de1687d0ca
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Mon Sep 24 13:19:41 2007 +0100

    Add a restart to the same-duration case.  It's not good enough, but it allows
    interactive fixing key signatures in the middle of the bar.

commit cdc2098fac5399303e9515bc81ea65020ec8f109
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Wed Sep 19 11:07:28 2007 +0100

    Only add durations from rhythmic elements.

commit acc6cb410cd55dfe59eb30fe608b101a62651ae9
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Wed Sep 19 10:45:12 2007 +0100

    Whoops.  Fix export of notes with no displayed accidentals (from 
overzealous    alteration of CASE -> ECASE

commit dd8d72cac434a8c5a1932aa46db6447e08d9b6ad
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Wed Sep 19 10:41:09 2007 +0100

    Support for longs in MusicXML (import and export)

commit eab440b56b086e766dbd405a3fea44d9976f1a1f
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Wed Sep 19 09:16:07 2007 +0100

    Long ("lunga") patch from HEAD

commit 8cb34a4879ebb4dce06d8b99da761dfa6ad24cf9
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Tue Sep 18 15:43:51 2007 +0100

    Support semi- and sesqui- accidentals

commit 6ba8208d1f8475552a95f35a5e896248110b0efd
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Tue Sep 18 15:25:16 2007 +0100

    Really support breves (and breve rests) -- on output too.

commit a9c36278de0145c12f34123a29815809030b97c2
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Tue Sep 18 15:17:09 2007 +0100

    Slightly batched commit (several changes).

    * support :breve noteheads
    * better stringcase macro (and use it)
    * temporarily hack in "full" = "breve" for Goldsmiths use
    * use ECASE in one or two places to remove compiler warnings.

commit 3a3b980576f0d09ddee4de12f6f7b260932a5552
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Tue Sep 18 15:14:54 2007 +0100

    Slightly friendlier (with friends like this...) Import and Export commands.
    Sets the filepath and name of the buffer on import; sensible export default
    pathname.

commit 7d72a2a4a28f9668271189ebaf862518ada34877
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Tue Sep 18 15:13:31 2007 +0100

    Whitespace

commit b497d6f5111f20f5e8ac9a059578d3caaab1b832
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Mon Sep 17 21:33:29 2007 +0100

    space requirements fix from HEAD

commit 65d173efbcfa78e5edaf1adb9bceb0f7d619002d
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Mon Sep 17 12:04:08 2007 +0100

    Update to Brian Gruber's version of 17th September

commit 91d98d9e2a8d69418edd264ab6293a2f1dbc5a9f
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Mon Sep 17 11:54:53 2007 +0100

    Brian Gruber's patch of August 20th



--- /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/ISOlat1.pen	2007/10/18 15:02:48	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/ISOlat1.pen	2007/10/18 15:02:48	1.1
<!-- (C) International Organization for Standardization 1986
     Permission to copy in any form is granted for use with
     conforming SGML systems and applications as defined in
     ISO 8879, provided this notice is included in all copies.
      
-->
<!-- Character entity set. Typical invocation:
     <!ENTITY % ISOlat1 PUBLIC
       "ISO 8879:1986//ENTITIES Added Latin 1//EN//XML"
       "ISOlat1.pen" >
     %ISOlat1;
     or 
     <!ENTITY % HTMLlat1 PUBLIC
       "ISO 8879:1986//ENTITIES Added Latin 1//EN//XML"
       "ISOlat1.pen" >
     %HTMLlat1;    
-->
<!--
    CATALOG ENTRIES  
    
    PUBLIC "ISO 8879:1986//ENTITIES Added Latin 1//EN//XML"
    "ISOlat1.pen"
    PUBLIC "ISO 8879-1986//ENTITIES Added Latin 1//EN//XML"
    "ISOlat1.pen"       
    PUBLIC "ISO 8879:1986//ENTITIES Added Latin 1//EN"
    "ISOlat1.pen"
    PUBLIC "ISO 8879-1986//ENTITIES Added Latin 1//EN"
    "ISOlat1.pen"  
    
    Note that the last two catalog entries are not correct for
    SGML systems which need to ship the entities as SDATA.
-->   

<!-- This version of the entity set can be used with any SGML document
     which uses ISO 8859-1 or ISO 10646 as its document character 
     set. This includes XML documents and ISO HTML documents.
     
     Prepared: Rick Jelliffe, Allette Systems, (using HTMLlat1)
     
     Version: 1998-11-05
     
     
     Thanks to Debbie Lapeyre and Evan Owens for pointing out the
     error in the invocation example in the 1997-07-07 version.
      
-->
 
    <!ENTITY Agrave  "&#192;" ><!-- capital A, grave accent -->
    <!ENTITY Aacute  "&#193;" ><!-- capital A, acute accent -->
    <!ENTITY Acirc   "&#194;" ><!-- capital A, circumflex accent -->
    <!ENTITY Atilde  "&#195;" ><!-- capital A, tilde -->
    <!ENTITY Auml    "&#196;" ><!-- capital A, dieresis or umlaut mark -->
    <!ENTITY Aring   "&#197;" ><!-- capital A, ring -->
    <!ENTITY AElig   "&#198;" ><!-- capital AE diphthong (ligature) -->
    <!ENTITY Ccedil  "&#199;" ><!-- capital C, cedilla -->
    <!ENTITY Egrave  "&#200;" ><!-- capital E, grave accent -->
    <!ENTITY Eacute  "&#201;" ><!-- capital E, acute accent -->
    <!ENTITY Ecirc   "&#202;" ><!-- capital E, circumflex accent -->
    <!ENTITY Euml    "&#203;" ><!-- capital E, dieresis or umlaut mark -->
    <!ENTITY Igrave  "&#204;" ><!-- capital I, grave accent -->
    <!ENTITY Iacute  "&#205;" ><!-- capital I, acute accent -->
    <!ENTITY Icirc   "&#206;" ><!-- capital I, circumflex accent -->
    <!ENTITY Iuml    "&#207;" ><!-- capital I, dieresis or umlaut mark -->
    <!ENTITY ETH     "&#208;" ><!-- capital Eth, Icelandic -->
    <!ENTITY Ntilde  "&#209;" ><!-- capital N, tilde -->
    <!ENTITY Ograve  "&#210;" ><!-- capital O, grave accent -->
    <!ENTITY Oacute  "&#211;" ><!-- capital O, acute accent -->
    <!ENTITY Ocirc   "&#212;" ><!-- capital O, circumflex accent -->
    <!ENTITY Otilde  "&#213;" ><!-- capital O, tilde -->
    <!ENTITY Ouml    "&#214;" ><!-- capital O, dieresis or umlaut mark -->
    <!ENTITY Oslash  "&#216;" ><!-- capital O, slash -->
    <!ENTITY Ugrave  "&#217;" ><!-- capital U, grave accent -->
    <!ENTITY Uacute  "&#218;" ><!-- capital U, acute accent -->
    <!ENTITY Ucirc   "&#219;" ><!-- capital U, circumflex accent -->
    <!ENTITY Uuml    "&#220;" ><!-- capital U, dieresis or umlaut mark -->
    <!ENTITY Yacute  "&#221;" ><!-- capital Y, acute accent -->
    <!ENTITY THORN   "&#222;" ><!-- capital THORN, Icelandic -->
    <!ENTITY szlig   "&#223;" ><!-- small sharp s, German (sz ligature) -->
    <!ENTITY agrave  "&#224;" ><!-- small a, grave accent -->   
    <!ENTITY aacute  "&#225;" ><!-- small a, acute accent -->
    <!ENTITY acirc   "&#226;" ><!-- small a, circumflex accent -->
    <!ENTITY atilde  "&#227;" ><!-- small a, tilde -->
    <!ENTITY auml    "&#228;" ><!-- small a, dieresis or umlaut mark -->
    <!ENTITY aring   "&#229;" ><!-- small a, ring -->
    <!ENTITY aelig   "&#230;" ><!-- small ae diphthong (ligature) -->
    <!ENTITY ccedil  "&#231;" ><!-- small c, cedilla -->
    <!ENTITY egrave  "&#232;" ><!-- small e, grave accent -->
    <!ENTITY eacute  "&#233;" ><!-- small e, acute accent -->
    <!ENTITY ecirc   "&#234;" ><!-- small e, circumflex accent -->
    <!ENTITY euml    "&#235;" ><!-- small e, dieresis or umlaut mark -->
    <!ENTITY igrave  "&#236;" ><!-- small i, grave accent -->
    <!ENTITY iacute  "&#237;" ><!-- small i, acute accent -->
    <!ENTITY icirc   "&#238;" ><!-- small i, circumflex accent -->
    <!ENTITY iuml    "&#239;" ><!-- small i, dieresis or umlaut mark -->
    <!ENTITY eth     "&#240;" ><!-- small eth, Icelandic -->
    <!ENTITY ntilde  "&#241;" ><!-- small n, tilde -->
    <!ENTITY ograve  "&#242;" ><!-- small o, grave accent -->
    <!ENTITY oacute  "&#243;" ><!-- small o, acute accent -->
    <!ENTITY ocirc   "&#244;" ><!-- small o, circumflex accent -->
    <!ENTITY otilde  "&#245;" ><!-- small o, tilde -->
    <!ENTITY ouml    "&#246;" ><!-- small o, dieresis or umlaut mark -->

    <!ENTITY oslash  "&#248;" ><!-- small o, slash -->
    <!ENTITY ugrave  "&#249;" ><!-- small u, grave accent -->
    <!ENTITY uacute  "&#250;" ><!-- small u, acute accent -->
    <!ENTITY ucirc   "&#251;" ><!-- small u, circumflex accent -->
    <!ENTITY uuml    "&#252;" ><!-- small u, dieresis or umlaut mark -->
    <!ENTITY yacute  "&#253;" ><!-- small y, acute accent -->
    <!ENTITY thorn   "&#254;" ><!-- small thorn, Icelandic -->
    <!ENTITY yuml    "&#255;" ><!-- small y, dieresis or umlaut mark -->

--- /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/ISOlat2.pen	2007/10/18 15:02:48	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/ISOlat2.pen	2007/10/18 15:02:48	1.1
<!-- (C) International Organization for Standardization 1986
     Permission to copy in any form is granted for use with
     conforming SGML systems and applications as defined in
     ISO 8879, provided this notice is included in all copies.
-->
<!-- Character entity set. Typical invocation:
     <!ENTITY % ISOlat2 PUBLIC
       "ISO 8879:1986//ENTITIES Added Latin 2//EN//XML"
       "ISOlat2.pen">
     %ISOlat2;
-->
<!-- This version of the entity set can be used with any SGML document
     which uses ISO 10646 as its document character set. 
     This includes XML documents and ISO HTML documents.
     This entity set uses hexadecimal numeric character references. 
          
     Prepared: Rick Jelliffe, ricko at allette.com.au
     
     Version: 1998-02-06
     
     Thanks to Wilfried Wiehler for finding 3 errors with Sacute,
     Zcaron, and zcaron in the 1997-07-07 version.
-->
<!ENTITY abreve "&#x103;" ><!--=small a, breve-->
<!ENTITY Abreve "&#x102;" ><!--=capital A, breve-->
<!ENTITY amacr  "&#x101;" ><!--=small a, macron-->
<!ENTITY Amacr  "&#x100;" ><!--=capital A, macron-->
<!ENTITY aogon  "&#x105;" ><!--=small a, ogonek-->
<!ENTITY Aogon  "&#x104;" ><!--=capital A, ogonek-->
<!ENTITY cacute "&#x107;" ><!--=small c, acute accent-->
<!ENTITY Cacute "&#x106;" ><!--=capital C, acute accent-->
<!ENTITY ccaron "&#x10D;" ><!--=small c, caron-->
<!ENTITY Ccaron "&#x10C;" ><!--=capital C, caron-->
<!ENTITY ccirc  "&#x109;" ><!--=small c, circumflex accent-->
<!ENTITY Ccirc  "&#x108;" ><!--=capital C, circumflex accent-->
<!ENTITY cdot   "&#x10B;" ><!--=small c, dot above-->
<!ENTITY Cdot   "&#x10A;" ><!--=capital C, dot above-->
<!ENTITY dcaron "&#x10F;" ><!--=small d, caron-->
<!ENTITY Dcaron "&#x10E;" ><!--=capital D, caron-->
<!ENTITY dstrok "&#x111;" ><!--=small d, stroke-->
<!ENTITY Dstrok "&#x110;" ><!--=capital D, stroke-->
<!ENTITY ecaron "&#x11B;" ><!--=small e, caron-->
<!ENTITY Ecaron "&#x11A;" ><!--=capital E, caron-->
<!ENTITY edot   "&#x117;" ><!--=small e, dot above-->
<!ENTITY Edot   "&#x116;" ><!--=capital E, dot above-->
<!ENTITY emacr  "&#x113;" ><!--=small e, macron-->
<!ENTITY Emacr  "&#x112;" ><!--=capital E, macron-->
<!ENTITY eogon  "&#x119;" ><!--=small e, ogonek-->
<!ENTITY Eogon  "&#x118;" ><!--=capital E, ogonek-->
<!ENTITY gacute "&#x1F5;" ><!--=small g, acute accent-->
<!ENTITY gbreve "&#x11F;" ><!--=small g, breve-->
<!ENTITY Gbreve "&#x11E;" ><!--=capital G, breve-->
<!ENTITY Gcedil "&#x122;" ><!--=capital G, cedilla-->
<!ENTITY gcirc  "&#x11D;" ><!--=small g, circumflex accent-->
<!ENTITY Gcirc  "&#x11C;" ><!--=capital G, circumflex accent-->
<!ENTITY gdot   "&#x121;" ><!--=small g, dot above-->
<!ENTITY Gdot   "&#x120;" ><!--=capital G, dot above-->
<!ENTITY hcirc  "&#x125;" ><!--=small h, circumflex accent-->
<!ENTITY Hcirc  "&#x124;" ><!--=capital H, circumflex accent-->
<!ENTITY hstrok "&#x127;" ><!--=small h, stroke-->
<!ENTITY Hstrok "&#x126;" ><!--=capital H, stroke-->
<!ENTITY Idot   "&#x130;" ><!--=capital I, dot above-->
<!ENTITY Imacr  "&#x12A;" ><!--=capital I, macron-->
<!ENTITY imacr  "&#x12B;" ><!--=small i, macron-->
<!ENTITY ijlig  "&#x133;" ><!--=small ij ligature-->
<!ENTITY IJlig  "&#x132;" ><!--=capital IJ ligature-->
<!ENTITY inodot "&#x131;" ><!--=small i without dot-->
<!ENTITY iogon  "&#x12F;" ><!--=small i, ogonek-->
<!ENTITY Iogon  "&#x12E;" ><!--=capital I, ogonek-->
<!ENTITY itilde "&#x129;" ><!--=small i, tilde-->
<!ENTITY Itilde "&#x128;" ><!--=capital I, tilde-->
<!ENTITY jcirc  "&#x135;" ><!--=small j, circumflex accent-->
<!ENTITY Jcirc  "&#x134;" ><!--=capital J, circumflex accent-->
<!ENTITY kcedil "&#x137;" ><!--=small k, cedilla-->
<!ENTITY Kcedil "&#x136;" ><!--=capital K, cedilla-->
<!ENTITY kgreen "&#x138;" ><!--=small k, Greenlandic-->
<!ENTITY lacute "&#x13A;" ><!--=small l, acute accent-->
<!ENTITY Lacute "&#x139;" ><!--=capital L, acute accent-->
<!ENTITY lcaron "&#x13E;" ><!--=small l, caron-->
<!ENTITY Lcaron "&#x13D;" ><!--=capital L, caron-->
<!ENTITY lcedil "&#x13C;" ><!--=small l, cedilla-->
<!ENTITY Lcedil "&#x13B;" ><!--=capital L, cedilla-->
<!ENTITY lmidot "&#x140;" ><!--=small l, middle dot-->
<!ENTITY Lmidot "&#x139;" ><!--=capital L, middle dot-->
<!ENTITY lstrok "&#x142;" ><!--=small l, stroke-->
<!ENTITY Lstrok "&#x141;" ><!--=capital L, stroke-->
<!ENTITY nacute "&#x144;" ><!--=small n, acute accent-->
<!ENTITY Nacute "&#x143;" ><!--=capital N, acute accent-->
<!ENTITY eng    "&#x14B;" ><!--=small eng, Lapp-->
<!ENTITY ENG    "&#x14A;" ><!--=capital ENG, Lapp-->
<!ENTITY napos  "&#x149;" ><!--=small n, apostrophe-->
<!ENTITY ncaron "&#x148;" ><!--=small n, caron-->
<!ENTITY Ncaron "&#x147;" ><!--=capital N, caron-->
<!ENTITY ncedil "&#x146;" ><!--=small n, cedilla-->
<!ENTITY Ncedil "&#x145;" ><!--=capital N, cedilla-->
<!ENTITY odblac "&#x151;" ><!--=small o, double acute accent-->
<!ENTITY Odblac "&#x150;" ><!--=capital O, double acute accent-->
<!ENTITY Omacr  "&#x14C;" ><!--=capital O, macron-->
<!ENTITY omacr  "&#x14D;" ><!--=small o, macron-->
<!ENTITY oelig  "&#x153;" ><!--=small oe ligature-->
<!ENTITY OElig  "&#x152;" ><!--=capital OE ligature-->
<!ENTITY racute "&#x155;" ><!--=small r, acute accent-->
<!ENTITY Racute "&#x154;" ><!--=capital R, acute accent-->
<!ENTITY rcaron "&#x159;" ><!--=small r, caron-->
<!ENTITY Rcaron "&#x158;" ><!--=capital R, caron-->
<!ENTITY rcedil "&#x157;" ><!--=small r, cedilla-->
<!ENTITY Rcedil "&#x156;" ><!--=capital R, cedilla-->
<!ENTITY sacute "&#x15B;" ><!--=small s, acute accent-->
<!ENTITY Sacute "&#x15A;" ><!--=capital S, acute accent-->
<!ENTITY scaron "&#x161;" ><!--=small s, caron-->
<!ENTITY Scaron "&#x160;" ><!--=capital S, caron-->
<!ENTITY scedil "&#x15F;" ><!--=small s, cedilla-->
<!ENTITY Scedil "&#x15E;" ><!--=capital S, cedilla-->
<!ENTITY scirc  "&#x15C;" ><!--=small s, circumflex accent-->
<!ENTITY Scirc  "&#x15D;" ><!--=capital S, circumflex accent-->
<!ENTITY tcaron "&#x165;" ><!--=small t, caron-->
<!ENTITY Tcaron "&#x164;" ><!--=capital T, caron-->
<!ENTITY tcedil "&#x162;" ><!--=small t, cedilla-->
<!ENTITY Tcedil "&#x163;" ><!--=capital T, cedilla-->
<!ENTITY tstrok "&#x167;" ><!--=small t, stroke-->
<!ENTITY Tstrok "&#x166;" ><!--=capital T, stroke-->
<!ENTITY ubreve "&#x16D;" ><!--=small u, breve-->
<!ENTITY Ubreve "&#x16C;" ><!--=capital U, breve-->
<!ENTITY udblac "&#x171;" ><!--=small u, double acute accent-->
<!ENTITY Udblac "&#x170;" ><!--=capital U, double acute accent-->
<!ENTITY umacr  "&#x16B;" ><!--=small u, macron-->
<!ENTITY Umacr  "&#x16A;" ><!--=capital U, macron-->
<!ENTITY uogon  "&#x173;" ><!--=small u, ogonek-->
<!ENTITY Uogon  "&#x172;" ><!--=capital U, ogonek-->
<!ENTITY uring  "&#x16F;" ><!--=small u, ring-->
<!ENTITY Uring  "&#x16E;" ><!--=capital U, ring-->
<!ENTITY utilde "&#x169;" ><!--=small u, tilde-->
<!ENTITY Utilde "&#x168;" ><!--=capital U, tilde-->
<!ENTITY wcirc  "&#x175;" ><!--=small w, circumflex accent-->
<!ENTITY Wcirc  "&#x174;" ><!--=capital W, circumflex accent-->
<!ENTITY ycirc  "&#x177;" ><!--=small y, circumflex accent-->
<!ENTITY Ycirc  "&#x176;" ><!--=capital Y, circumflex accent-->
<!ENTITY Yuml   "&#x178;" ><!--=capital Y, dieresis or umlaut mark-->
<!ENTITY zacute "&#x17A;" ><!--=small z, acute accent-->
<!ENTITY Zacute "&#x179;" ><!--=capital Z, acute accent-->
<!ENTITY zcaron "&#x17E;" ><!--=small z, caron-->
<!ENTITY Zcaron "&#x17D;" ><!--=capital Z, caron-->
<!ENTITY zdot   "&#x17C;" ><!--=small z, dot above-->
<!ENTITY Zdot   "&#x17B;" ><!--=capital Z, dot above-->

--- /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/MIDIEvents10.dtd	2007/10/18 15:02:48	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/MIDIEvents10.dtd	2007/10/18 15:02:48	1.1
<!--
	XML DTD for MIDI messages
	
	Version 1.0, 19 January 2003
	
	Formal Public Identifier:
		"-//MIDI Manufacturers Association//DTD MIDIEvents 1.0//EN"

	URI:
		"http://www.midi.org/dtds/MIDIEvents10.dtd"

	Parameter entities which must be defined before use:
		%ChannelRequired;		#IMPLIED
									for use in contexts, where the event is always
									rechannelized
								#REQUIRED
									when channel messages require Channel attribute

	e.g.
		<!ENTITY % MIDIDTD PUBLIC	"-//MIDI Manufacturers Association//DTD MIDIEvents 1.0//EN"
									"http://www.midi.org/dtds/MIDIEvents10.dtd" >
		%MIDIDTD;
-->

<!--
	CHANNEL MESSAGES
	
	Attribute values:
		Note, Velocity, Pressure, Control, Value, Number are all 0..127
		except: PitchBend's Value is 0..16383
-->

<!ELEMENT NoteOn EMPTY>
	<!ATTLIST NoteOn
		Channel		(1|2|3|4|5|6|7|8|9|10|11|12|13|14|15|16)	%ChannelRequired;
		Note		NMTOKEN										#REQUIRED
		Velocity	NMTOKEN										#REQUIRED>

<!ELEMENT NoteOff EMPTY>
	<!ATTLIST NoteOff
		Channel		(1|2|3|4|5|6|7|8|9|10|11|12|13|14|15|16)	%ChannelRequired;
		Note		NMTOKEN										#REQUIRED
		Velocity	NMTOKEN										#REQUIRED>

<!ELEMENT PolyKeyPressure EMPTY>
	<!ATTLIST PolyKeyPressure
		Channel		(1|2|3|4|5|6|7|8|9|10|11|12|13|14|15|16)	%ChannelRequired;
		Note		NMTOKEN										#REQUIRED
		Pressure	NMTOKEN										#REQUIRED>

<!ELEMENT ControlChange EMPTY>
	<!ATTLIST ControlChange
		Channel		(1|2|3|4|5|6|7|8|9|10|11|12|13|14|15|16)	%ChannelRequired;
		Control		NMTOKEN										#REQUIRED
		Value		NMTOKEN										#REQUIRED>

<!ELEMENT ProgramChange EMPTY>
	<!ATTLIST ProgramChange
		Channel		(1|2|3|4|5|6|7|8|9|10|11|12|13|14|15|16)	%ChannelRequired;
		Number		NMTOKEN										#REQUIRED>

<!ELEMENT ChannelKeyPressure EMPTY>
	<!ATTLIST ChannelKeyPressure
		Channel		(1|2|3|4|5|6|7|8|9|10|11|12|13|14|15|16)	%ChannelRequired;
		Pressure	NMTOKEN										#REQUIRED>

<!ELEMENT PitchBendChange EMPTY>
	<!ATTLIST PitchBendChange
		Channel		(1|2|3|4|5|6|7|8|9|10|11|12|13|14|15|16)	%ChannelRequired;
		Value		NMTOKEN										#REQUIRED>

<!--
	Channel mode messages
-->
<!ELEMENT AllSoundOff EMPTY>
	<!ATTLIST AllSoundOff
		Channel		(1|2|3|4|5|6|7|8|9|10|11|12|13|14|15|16)	%ChannelRequired;>

<!ELEMENT ResetAllControllers EMPTY>
	<!ATTLIST ResetAllControllers
		Channel		(1|2|3|4|5|6|7|8|9|10|11|12|13|14|15|16)	%ChannelRequired;>

<!ELEMENT LocalControl EMPTY>
	<!ATTLIST LocalControl
		Channel		(1|2|3|4|5|6|7|8|9|10|11|12|13|14|15|16)	%ChannelRequired;
		Value		(off|on)									#REQUIRED>

<!ELEMENT AllNotesOff EMPTY>
	<!ATTLIST AllNotesOff
		Channel		(1|2|3|4|5|6|7|8|9|10|11|12|13|14|15|16)	%ChannelRequired;>

<!ELEMENT OmniOff EMPTY>
	<!ATTLIST OmniOff
		Channel		(1|2|3|4|5|6|7|8|9|10|11|12|13|14|15|16)	%ChannelRequired;>

<!ELEMENT OmniOn EMPTY>
	<!ATTLIST OmniOn
		Channel		(1|2|3|4|5|6|7|8|9|10|11|12|13|14|15|16)	%ChannelRequired;>

<!ELEMENT MonoMode EMPTY>
	<!ATTLIST MonoMode
		Channel		(1|2|3|4|5|6|7|8|9|10|11|12|13|14|15|16)	%ChannelRequired;
		Value		NMTOKEN                                     #REQUIRED>

<!ELEMENT PolyMode EMPTY>
	<!ATTLIST PolyMode
		Channel		(1|2|3|4|5|6|7|8|9|10|11|12|13|14|15|16)	%ChannelRequired;>

<!--
	14-bit control changes:
		Value is 0..16383
	
		ControlChange14's Control is MSB 0..31
		RPNN and NRPN are 0..16383
-->

<!ELEMENT ControlChange14 EMPTY>
	<!ATTLIST ControlChange14
		Channel		(1|2|3|4|5|6|7|8|9|10|11|12|13|14|15|16)	%ChannelRequired;
		Control		NMTOKEN										#REQUIRED
		Value		NMTOKEN										#REQUIRED>	

<!ELEMENT RPNChange EMPTY>
	<!ATTLIST RPNChange
		Channel		(1|2|3|4|5|6|7|8|9|10|11|12|13|14|15|16)	%ChannelRequired;
		RPN			NMTOKEN										#REQUIRED
		Value		NMTOKEN										#REQUIRED>

<!ELEMENT NRPNChange EMPTY>
	<!ATTLIST NRPNChange
		Channel		(1|2|3|4|5|6|7|8|9|10|11|12|13|14|15|16)	%ChannelRequired;
		NRPN		NMTOKEN										#REQUIRED
		Value		NMTOKEN										#REQUIRED>


<!--
	SYSTEM MESSAGES
-->

<!ELEMENT SysEx (#PCDATA | SysExDeviceID | SysExChannel)*>		
	<!-- contains string of hex bytes without radix information, e.g.:
	<SysEx>F0 01 02 <SysExDeviceID/> 03 04 05 <SysExChannel Multiplier="1" Offset="32"/> F7</SysEx>	
	-->


[51 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/attributes.dtd	2007/10/18 15:02:48	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/attributes.dtd	2007/10/18 15:02:48	1.1

[412 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/barline.dtd	2007/10/18 15:02:48	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/barline.dtd	2007/10/18 15:02:48	1.1

[510 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/common.dtd	2007/10/18 15:02:48	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/common.dtd	2007/10/18 15:02:48	1.1

[1154 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/direction.dtd	2007/10/18 15:02:49	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/direction.dtd	2007/10/18 15:02:49	1.1

[1770 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/identity.dtd	2007/10/18 15:02:49	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/identity.dtd	2007/10/18 15:02:49	1.1

[1869 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/layout.dtd	2007/10/18 15:02:55	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/layout.dtd	2007/10/18 15:02:55	1.1

[1989 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/link.dtd	2007/10/18 15:02:55	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/link.dtd	2007/10/18 15:02:55	1.1

[2049 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/midixml.dtd	2007/10/18 15:02:57	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/midixml.dtd	2007/10/18 15:02:57	1.1

[2270 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/midixml.xsl	2007/10/18 15:02:57	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/midixml.xsl	2007/10/18 15:02:57	1.1

[2327 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/note.dtd	2007/10/18 15:02:57	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/note.dtd	2007/10/18 15:02:57	1.1

[3353 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/opus.dtd	2007/10/18 15:02:57	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/opus.dtd	2007/10/18 15:02:57	1.1

[3419 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/parttime.xsl	2007/10/18 15:02:57	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/parttime.xsl	2007/10/18 15:02:57	1.1

[3592 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/partwise.dtd	2007/10/18 15:02:57	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/partwise.dtd	2007/10/18 15:02:57	1.1

[3741 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/score.dtd	2007/10/18 15:02:57	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/score.dtd	2007/10/18 15:02:57	1.1

[4050 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/timepart.xsl	2007/10/18 15:02:57	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/timepart.xsl	2007/10/18 15:02:57	1.1

[4226 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/timewise.dtd	2007/10/18 15:02:57	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/timewise.dtd	2007/10/18 15:02:57	1.1

[4375 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/to10.xsl	2007/10/18 15:02:57	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/mxml-dtds/to10.xsl	2007/10/18 15:02:57	1.1

[4552 lines skipped]


From crhodes at common-lisp.net  Thu Oct 18 15:03:06 2007
From: crhodes at common-lisp.net (crhodes)
Date: Thu, 18 Oct 2007 11:03:06 -0400 (EDT)
Subject: [gsharp-cvs] CVS gsharp/Mxml/tests
Message-ID: <20071018150306.0742C53121@common-lisp.net>

Update of /project/gsharp/cvsroot/gsharp/Mxml/tests
In directory clnet:/tmp/cvs-serv30948/Mxml/tests

Added Files:
	2staves.gsh README assorted_accidentals.gsh 
	assorted_accidentals.xml bars.gsh bars.xml clefs.gsh clefs.xml 
	durations.gsh durations.xml flags.gsh forced_naturals.gsh 
	forced_naturals.xml funny_durations.gsh hellochord.gsh 
	hellochord.xml helloworld.gsh helloworld.xml just_voices.xml 
	keychange.gsh keysigs_on_staves.gsh keysigs_on_staves.xml 
	lyrics-test.gsh lyrics.gsh lyrics.xml other_voices.gsh 
	other_voices.xml overlapping_layers.gsh parts.xml 
	position.lisp rests.gsh rests.xml segments.gsh staves.gsh 
	staves.xml tie.gsh tie.xml 
Log Message:
Add MusicXML support.  Initial work from Brian Gruber (funded by 
Google's Summer of Code); subsequent development by Christophe Rhodes.

It's far from perfect now, but it needs checking in so that people can 
play with it.  It adds dependencies (puri and cxml) to gsharp; if this 
is a problem, we could make gsharp-mxml a separate system.

Git logs (from git tree at 
<http://www-jcsu.jesus.cam.ac.uk/~csr21/git/gsharp-mxml/.git>) follow:

commit 994cd15ec9f480be41515e699f22e7de1687d0ca
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Mon Sep 24 13:19:41 2007 +0100

    Add a restart to the same-duration case.  It's not good enough, but it allows
    interactive fixing key signatures in the middle of the bar.

commit cdc2098fac5399303e9515bc81ea65020ec8f109
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Wed Sep 19 11:07:28 2007 +0100

    Only add durations from rhythmic elements.

commit acc6cb410cd55dfe59eb30fe608b101a62651ae9
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Wed Sep 19 10:45:12 2007 +0100

    Whoops.  Fix export of notes with no displayed accidentals (from 
overzealous    alteration of CASE -> ECASE

commit dd8d72cac434a8c5a1932aa46db6447e08d9b6ad
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Wed Sep 19 10:41:09 2007 +0100

    Support for longs in MusicXML (import and export)

commit eab440b56b086e766dbd405a3fea44d9976f1a1f
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Wed Sep 19 09:16:07 2007 +0100

    Long ("lunga") patch from HEAD

commit 8cb34a4879ebb4dce06d8b99da761dfa6ad24cf9
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Tue Sep 18 15:43:51 2007 +0100

    Support semi- and sesqui- accidentals

commit 6ba8208d1f8475552a95f35a5e896248110b0efd
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Tue Sep 18 15:25:16 2007 +0100

    Really support breves (and breve rests) -- on output too.

commit a9c36278de0145c12f34123a29815809030b97c2
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Tue Sep 18 15:17:09 2007 +0100

    Slightly batched commit (several changes).

    * support :breve noteheads
    * better stringcase macro (and use it)
    * temporarily hack in "full" = "breve" for Goldsmiths use
    * use ECASE in one or two places to remove compiler warnings.

commit 3a3b980576f0d09ddee4de12f6f7b260932a5552
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Tue Sep 18 15:14:54 2007 +0100

    Slightly friendlier (with friends like this...) Import and Export commands.
    Sets the filepath and name of the buffer on import; sensible export default
    pathname.

commit 7d72a2a4a28f9668271189ebaf862518ada34877
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Tue Sep 18 15:13:31 2007 +0100

    Whitespace

commit b497d6f5111f20f5e8ac9a059578d3caaab1b832
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Mon Sep 17 21:33:29 2007 +0100

    space requirements fix from HEAD

commit 65d173efbcfa78e5edaf1adb9bceb0f7d619002d
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Mon Sep 17 12:04:08 2007 +0100

    Update to Brian Gruber's version of 17th September

commit 91d98d9e2a8d69418edd264ab6293a2f1dbc5a9f
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date:   Mon Sep 17 11:54:53 2007 +0100

    Brian Gruber's patch of August 20th



--- /project/gsharp/cvsroot/gsharp/Mxml/tests/2staves.gsh	2007/10/18 15:02:58	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/2staves.gsh	2007/10/18 15:02:58	1.1
G#V4

[GSHARP-BUFFER:BUFFER
   :min-width 17
   :spacing-style 0.4
   :right-edge 700
   :left-offset 30
   :left-margin 20
   :staves (#1=[GSHARP-BUFFER:FIVELINE-STAFF
                  :clef [GSHARP-BUFFER:CLEF :lineno 2 :name :TREBLE ]
                  :keysig [GSHARP-BUFFER:KEY-SIGNATURE
                             :staff #1#
                             :alterations #(:NATURAL :NATURAL :NATURAL :NATURAL
                                            :NATURAL :NATURAL :NATURAL)
                             :xoffset 0 ]
                  :name "default staff" ]
            #2=[GSHARP-BUFFER:FIVELINE-STAFF
                  :clef [GSHARP-BUFFER:CLEF :lineno 2 :name :TREBLE ]
                  :keysig [GSHARP-BUFFER:KEY-SIGNATURE
                             :staff #2#
                             :alterations #(:NATURAL :NATURAL :NATURAL :NATURAL
                                            :NATURAL :NATURAL :NATURAL)
                             :xoffset 0 ]
                  :name "below" ])
   :segments ([GSHARP-BUFFER:SEGMENT
                 :layers ([GSHARP-BUFFER:MELODY-LAYER
                             :staves (#2# #1#)
                             :head [GSHARP-BUFFER:SLICE
                                      :bars ([GSHARP-BUFFER:MELODY-BAR
                                                :elements COMMON-LISP:NIL ]) ]
                             :body [GSHARP-BUFFER:SLICE
                                      :bars ([GSHARP-BUFFER:MELODY-BAR
                                                :elements ([GSHARP-BUFFER:CLUSTER
                                                              :stem-direction :AUTO
                                                              :notes ([GSHARP-BUFFER:NOTE
                                                                         :pitch 33
                                                                         :staff #1#
                                                                         :head :FILLED
                                                                         :accidentals :NATURAL
                                                                         :dots 0 ])
                                                              :notehead :FILLED
                                                              :rbeams 0
                                                              :lbeams 0
                                                              :dots 0
                                                              :xoffset 0 ]
                                                           [GSHARP-BUFFER:CLUSTER
                                                              :stem-direction :AUTO
                                                              :notes ([GSHARP-BUFFER:NOTE
                                                                         :pitch 34
                                                                         :staff #2#
                                                                         :head :FILLED
                                                                         :accidentals :NATURAL
                                                                         :dots 0 ])
                                                              :notehead :FILLED
                                                              :rbeams 0
                                                              :lbeams 0
                                                              :dots 0
                                                              :xoffset 0 ]) ]) ]
                             :tail [GSHARP-BUFFER:SLICE
                                      :bars ([GSHARP-BUFFER:MELODY-BAR
                                                :elements COMMON-LISP:NIL ]) ]
                             :name "default layer" ])
                 :tempo 128 ]) ]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/README	2007/10/18 15:02:58	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/README	2007/10/18 15:02:58	1.1
Files with matching names SHOULD roundtrip, excepting the ones involving lyrics.
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/assorted_accidentals.gsh	2007/10/18 15:02:58	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/assorted_accidentals.gsh	2007/10/18 15:02:58	1.1
G#V4

[GSHARP-BUFFER:BUFFER
   :min-width 17
   :spacing-style 0.4
   :right-edge 700
   :left-offset 30
   :left-margin 20
   :staves (#1=[GSHARP-BUFFER:FIVELINE-STAFF
                  :clef [GSHARP-BUFFER:CLEF :lineno 2 :name :TREBLE ]
                  :keysig [GSHARP-BUFFER:KEY-SIGNATURE
                             :staff #1#
                             :alterations #(:NATURAL :NATURAL :NATURAL :NATURAL
                                            :NATURAL :NATURAL :FLAT)
                             :xoffset 0 ]
                  :name "default staff" ])
   :segments ([GSHARP-BUFFER:SEGMENT
                 :layers ([GSHARP-BUFFER:MELODY-LAYER
                             :staves (#1#)
                             :head [GSHARP-BUFFER:SLICE
                                      :bars ([GSHARP-BUFFER:MELODY-BAR
                                                :elements COMMON-LISP:NIL ]) ]
                             :body [GSHARP-BUFFER:SLICE
                                      :bars ([GSHARP-BUFFER:MELODY-BAR
                                                :elements ([GSHARP-BUFFER:CLUSTER
                                                              :stem-direction :AUTO
                                                              :notes ([GSHARP-BUFFER:NOTE
                                                                         :pitch 28
                                                                         :staff #1#
                                                                         :head :FILLED
                                                                         :accidentals :FLAT
                                                                         :dots 0 ])
                                                              :notehead :WHOLE
                                                              :rbeams 0
                                                              :lbeams 0
                                                              :dots 0
                                                              :xoffset 0 ]
                                                           [GSHARP-BUFFER:CLUSTER
                                                              :stem-direction :AUTO
                                                              :notes ([GSHARP-BUFFER:NOTE
                                                                         :pitch 29
                                                                         :staff #1#
                                                                         :head :FILLED
                                                                         :accidentals :DOUBLE-FLAT
                                                                         :dots 0 ])
                                                              :notehead :WHOLE
                                                              :rbeams 0
                                                              :lbeams 0
                                                              :dots 0
                                                              :xoffset 0 ]
                                                           [GSHARP-BUFFER:CLUSTER
                                                              :stem-direction :AUTO
                                                              :notes ([GSHARP-BUFFER:NOTE
                                                                         :pitch 30
                                                                         :staff #1#
                                                                         :head :FILLED
                                                                         :accidentals :SHARP
                                                                         :dots 0 ])
                                                              :notehead :WHOLE
                                                              :rbeams 0
                                                              :lbeams 0
                                                              :dots 0
                                                              :xoffset 0 ]
                                                           [GSHARP-BUFFER:CLUSTER
                                                              :stem-direction :AUTO
                                                              :notes ([GSHARP-BUFFER:NOTE
                                                                         :pitch 31
                                                                         :staff #1#
                                                                         :head :FILLED
                                                                         :accidentals :DOUBLE-SHARP
                                                                         :dots 0 ])
                                                              :notehead :WHOLE
                                                              :rbeams 0
                                                              :lbeams 0
                                                              :dots 0
                                                              :xoffset 0 ]
                                                           [GSHARP-BUFFER:CLUSTER
                                                              :stem-direction :AUTO
                                                              :notes ([GSHARP-BUFFER:NOTE
                                                                         :pitch 34
                                                                         :staff #1#
                                                                         :head :FILLED
                                                                         :accidentals :NATURAL
                                                                         :dots 0 ])
                                                              :notehead :WHOLE
                                                              :rbeams 0
                                                              :lbeams 0
                                                              :dots 0
                                                              :xoffset 0 ]) ]
                                             [GSHARP-BUFFER:MELODY-BAR
                                                :elements ([GSHARP-BUFFER:CLUSTER
                                                              :stem-direction :AUTO
                                                              :notes ([GSHARP-BUFFER:NOTE
                                                                         :pitch 28
                                                                         :staff #1#
                                                                         :head :FILLED
                                                                         :accidentals :SEMISHARP
                                                                         :dots 0 ])
                                                              :notehead :FILLED
                                                              :rbeams 0
                                                              :lbeams 0
                                                              :dots 0
                                                              :xoffset 0 ]
                                                           [GSHARP-BUFFER:CLUSTER
                                                              :stem-direction :AUTO
                                                              :notes ([GSHARP-BUFFER:NOTE
                                                                         :pitch 29
                                                                         :staff #1#
                                                                         :head :FILLED
                                                                         :accidentals :SESQUISHARP
                                                                         :dots 0 ])
                                                              :notehead :FILLED
                                                              :rbeams 0
                                                              :lbeams 0
                                                              :dots 0
                                                              :xoffset 0 ]
                                                           [GSHARP-BUFFER:CLUSTER
                                                              :stem-direction :AUTO
                                                              :notes ([GSHARP-BUFFER:NOTE
                                                                         :pitch 30
                                                                         :staff #1#
                                                                         :head :FILLED
                                                                         :accidentals :SEMIFLAT
                                                                         :dots 0 ])
                                                              :notehead :FILLED
                                                              :rbeams 0
                                                              :lbeams 0
                                                              :dots 0
                                                              :xoffset 0 ]
                                                           [GSHARP-BUFFER:CLUSTER
                                                              :stem-direction :AUTO
                                                              :notes ([GSHARP-BUFFER:NOTE
                                                                         :pitch 31
                                                                         :staff #1#
                                                                         :head :FILLED
                                                                         :accidentals :SESQUIFLAT
                                                                         :dots 0 ])
                                                              :notehead :FILLED
                                                              :rbeams 0
                                                              :lbeams 0
                                                              :dots 0
                                                              :xoffset 0 ]) ]) ]
                             :tail [GSHARP-BUFFER:SLICE
                                      :bars ([GSHARP-BUFFER:MELODY-BAR
                                                :elements COMMON-LISP:NIL ]) ]
                             :name "default layer" ])
                 :tempo 128
                 :tuning [GSHARP-BUFFER:12-EDO
                            :master-pitch-note [GSHARP-BUFFER:NOTE
                                                  :pitch 33
                                                  :staff [GSHARP-BUFFER:STAFF
                                                            :name "default staff" ]
                                                  :head COMMON-LISP:NIL
                                                  :accidentals :NATURAL
                                                  :dots COMMON-LISP:NIL ]
                            :master-pitch-freq 440 ] ]) ]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/assorted_accidentals.xml	2007/10/18 15:02:58	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/assorted_accidentals.xml	2007/10/18 15:02:58	1.1
<?xml version="1.0" encoding="UTF-8" standalone="no"?>
<!DOCTYPE score-partwise PUBLIC
    "-//Recordare//DTD MusicXML 1.1 Partwise//EN"
    "http://www.musicxml.org/dtds/partwise.dtd">
<score-partwise version="1.1">
  <part-list>
    <score-part id="P1">
	  <part-name>Music</part-name>
    </score-part>
  </part-list>
  <part id="P1">
    <measure number="1">
      <attributes>
        <divisions>1</divisions>
        <key>
          <fifths>-1</fifths>
        </key>
        <clef>
          <sign>G</sign>
          <line>2</line>
        </clef>
      </attributes>
      <note>
        <pitch>
          <step>C</step>
		  <alter>-1</alter>
          <octave>4</octave>
        </pitch>
        <duration>4</duration>
        <type>whole</type>
		<accidental>flat</accidental>
      </note>
      <note>
        <pitch>
          <step>D</step>
		  <alter>-2</alter>
          <octave>4</octave>
        </pitch>
        <duration>4</duration>
        <type>whole</type>
		<accidental>flat-flat</accidental>
      </note>
      <note>
        <pitch>
          <step>E</step>
		  <alter>1</alter>
          <octave>4</octave>
        </pitch>
        <duration>4</duration>
        <type>whole</type>
		<accidental>sharp</accidental>
      </note>
      <note>
        <pitch>
          <step>F</step>
		  <alter>2</alter>
          <octave>4</octave>
        </pitch>
        <duration>4</duration>
        <type>whole</type>
		<accidental>double-sharp</accidental>
      </note>
      <note>
        <pitch>
          <step>B</step>
          <octave>4</octave>
        </pitch>
        <duration>4</duration>
        <type>whole</type>
		<accidental>natural</accidental>
      </note>
    </measure>
  </part>
</score-partwise>
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/bars.gsh	2007/10/18 15:02:58	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/bars.gsh	2007/10/18 15:02:58	1.1
G#V4

[GSHARP-BUFFER:BUFFER
   :min-width 17
   :spacing-style 0.4
   :right-edge 700
   :left-offset 30
   :left-margin 20
   :staves (#1=[GSHARP-BUFFER:FIVELINE-STAFF
                  :clef [GSHARP-BUFFER:CLEF :lineno 2 :name :TREBLE ]
                  :keysig [GSHARP-BUFFER:KEY-SIGNATURE
                             :staff #1#
                             :alterations #(:NATURAL :NATURAL :NATURAL :NATURAL
                                            :NATURAL :NATURAL :NATURAL)
                             :xoffset 0 ]
                  :name #2="default staff" ])
   :segments ([GSHARP-BUFFER:SEGMENT
                 :layers ([GSHARP-BUFFER:MELODY-LAYER
                             :staves (#1#)
                             :head [GSHARP-BUFFER:SLICE
                                      :bars ([GSHARP-BUFFER:MELODY-BAR
                                                :elements COMMON-LISP:NIL ]) ]
                             :body [GSHARP-BUFFER:SLICE
                                      :bars ([GSHARP-BUFFER:MELODY-BAR
                                                :elements ([GSHARP-BUFFER:CLUSTER
                                                              :stem-direction :AUTO
                                                              :notes ([GSHARP-BUFFER:NOTE
                                                                         :pitch 33
                                                                         :staff #1#
                                                                         :head :FILLED
                                                                         :accidentals :NATURAL
                                                                         :dots 0 ])
                                                              :notehead :FILLED
                                                              :rbeams 0
                                                              :lbeams 0
                                                              :dots 0
                                                              :xoffset 0 ]) ]
                                             [GSHARP-BUFFER:MELODY-BAR
                                                :elements ([GSHARP-BUFFER:CLUSTER
                                                              :stem-direction :AUTO
                                                              :notes ([GSHARP-BUFFER:NOTE
                                                                         :pitch 34
                                                                         :staff #1#
                                                                         :head :FILLED
                                                                         :accidentals :NATURAL
                                                                         :dots 0 ])
                                                              :notehead :FILLED
                                                              :rbeams 0
                                                              :lbeams 0
                                                              :dots 0
                                                              :xoffset 0 ]) ]) ]
                             :tail [GSHARP-BUFFER:SLICE
                                      :bars ([GSHARP-BUFFER:MELODY-BAR
                                                :elements COMMON-LISP:NIL ]) ]
                             :name "default layer" ])
                 :tempo 128
                 :tuning [GSHARP-BUFFER:12-EDO
                            :master-pitch-note [GSHARP-BUFFER:NOTE
                                                  :pitch 33
                                                  :staff [GSHARP-BUFFER:STAFF
                                                            :name #2# ]
                                                  :head COMMON-LISP:NIL
                                                  :accidentals :NATURAL
                                                  :dots COMMON-LISP:NIL ]
                            :master-pitch-freq 440 ] ]) ]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/bars.xml	2007/10/18 15:02:58	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/bars.xml	2007/10/18 15:02:58	1.1
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE score-partwise PUBLIC "-//Recordare//DTD MusicXML 1.1 Partwise//EN" "http://www.musicxml.org/dtds/partwise.dtd">

<score-partwise version="1.1">
  <part-list>
    <score-part id="P1">
      <part-name>P1</part-name>
    </score-part>
  </part-list>
  <part id="P1">
    <measure number="1">
      <attributes>
        <divisions>1</divisions>
        <key>
          <fifths>0</fifths>
        </key>
        <clef>
          <sign>G</sign>
          <line>2</line>
        </clef>
      </attributes>
      <note>
        <pitch>
          <step>A</step>
          <octave>4</octave>
        </pitch>
        <duration>4</duration>
        <type>whole</type>
      </note>
    </measure>
    <measure number="2">
      <note>
        <pitch>
          <step>B</step>
          <octave>4</octave>
        </pitch>
        <duration>4</duration>
        <type>whole</type>
      </note>
    </measure>
  </part>

[1 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/clefs.gsh	2007/10/18 15:02:58	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/clefs.gsh	2007/10/18 15:02:58	1.1

[76 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/clefs.xml	2007/10/18 15:02:58	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/clefs.xml	2007/10/18 15:02:58	1.1

[120 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/durations.gsh	2007/10/18 15:02:58	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/durations.gsh	2007/10/18 15:02:58	1.1

[324 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/durations.xml	2007/10/18 15:02:58	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/durations.xml	2007/10/18 15:02:58	1.1

[458 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/flags.gsh	2007/10/18 15:02:58	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/flags.gsh	2007/10/18 15:02:58	1.1

[522 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/forced_naturals.gsh	2007/10/18 15:02:58	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/forced_naturals.gsh	2007/10/18 15:02:58	1.1

[655 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/forced_naturals.xml	2007/10/18 15:02:58	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/forced_naturals.xml	2007/10/18 15:02:58	1.1

[752 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/funny_durations.gsh	2007/10/18 15:02:58	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/funny_durations.gsh	2007/10/18 15:02:58	1.1

[956 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/hellochord.gsh	2007/10/18 15:02:58	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/hellochord.gsh	2007/10/18 15:02:58	1.1

[1047 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/hellochord.xml	2007/10/18 15:02:58	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/hellochord.xml	2007/10/18 15:02:58	1.1

[1144 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/helloworld.gsh	2007/10/18 15:02:58	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/helloworld.gsh	2007/10/18 15:02:58	1.1

[1186 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/helloworld.xml	2007/10/18 15:02:58	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/helloworld.xml	2007/10/18 15:02:58	1.1

[1219 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/just_voices.xml	2007/10/18 15:02:58	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/just_voices.xml	2007/10/18 15:02:58	1.1

[1266 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/keychange.gsh	2007/10/18 15:02:58	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/keychange.gsh	2007/10/18 15:02:58	1.1

[1514 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/keysigs_on_staves.gsh	2007/10/18 15:03:04	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/keysigs_on_staves.gsh	2007/10/18 15:03:04	1.1

[1580 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/keysigs_on_staves.xml	2007/10/18 15:03:04	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/keysigs_on_staves.xml	2007/10/18 15:03:04	1.1

[1632 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/lyrics-test.gsh	2007/10/18 15:03:04	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/lyrics-test.gsh	2007/10/18 15:03:04	1.1

[1761 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/lyrics.gsh	2007/10/18 15:03:04	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/lyrics.gsh	2007/10/18 15:03:04	1.1

[1882 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/lyrics.xml	2007/10/18 15:03:04	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/lyrics.xml	2007/10/18 15:03:04	1.1

[1942 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/other_voices.gsh	2007/10/18 15:03:04	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/other_voices.gsh	2007/10/18 15:03:04	1.1

[2277 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/other_voices.xml	2007/10/18 15:03:04	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/other_voices.xml	2007/10/18 15:03:04	1.1

[2628 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/overlapping_layers.gsh	2007/10/18 15:03:05	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/overlapping_layers.gsh	2007/10/18 15:03:05	1.1

[2761 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/parts.xml	2007/10/18 15:03:06	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/parts.xml	2007/10/18 15:03:06	1.1

[2836 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/position.lisp	2007/10/18 15:03:06	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/position.lisp	2007/10/18 15:03:06	1.1

[2854 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/rests.gsh	2007/10/18 15:03:06	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/rests.gsh	2007/10/18 15:03:06	1.1

[2940 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/rests.xml	2007/10/18 15:03:06	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/rests.xml	2007/10/18 15:03:06	1.1

[3011 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/segments.gsh	2007/10/18 15:03:06	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/segments.gsh	2007/10/18 15:03:06	1.1

[3097 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/staves.gsh	2007/10/18 15:03:06	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/staves.gsh	2007/10/18 15:03:06	1.1

[3249 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/staves.xml	2007/10/18 15:03:06	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/staves.xml	2007/10/18 15:03:06	1.1

[3292 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/tie.gsh	2007/10/18 15:03:06	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/tie.gsh	2007/10/18 15:03:06	1.1

[3358 lines skipped]
--- /project/gsharp/cvsroot/gsharp/Mxml/tests/tie.xml	2007/10/18 15:03:06	NONE
+++ /project/gsharp/cvsroot/gsharp/Mxml/tests/tie.xml	2007/10/18 15:03:06	1.1

[3417 lines skipped]


From mjonsson at common-lisp.net  Sat Oct 20 18:41:26 2007
From: mjonsson at common-lisp.net (mjonsson)
Date: Sat, 20 Oct 2007 14:41:26 -0400 (EDT)
Subject: [gsharp-cvs] CVS gsharp
Message-ID: <20071020184126.0C050481D4@common-lisp.net>

Update of /project/gsharp/cvsroot/gsharp
In directory clnet:/tmp/cvs-serv1017

Modified Files:
	play.lisp 
Log Message:
Report an error to the user if the midi-player fails (sbcl only)

--- /project/gsharp/cvsroot/gsharp/play.lisp	2007/06/28 12:58:17	1.9
+++ /project/gsharp/cvsroot/gsharp/play.lisp	2007/10/20 18:41:25	1.10
@@ -77,6 +77,16 @@
 		      (incf time (* *tempo* duration))))
 		  (bars slice) durations))))
 
+(define-condition midi-player-failed (gsharp-condition)
+  ((midi-player :initarg :midi-player)
+   (exit-code :initarg :exit-code))
+  (:report
+   (lambda (condition stream)
+     (with-slots (midi-player exit-code) condition
+     (format stream
+             "Midi player ~S returned exit code ~S, indicating that an error occurred."
+             midi-player exit-code)))))
+
 (defun play-tracks (tracks)
   (let ((midifile (make-instance 'midifile
 		     :format 1
@@ -88,10 +98,16 @@
                      (append *midi-player-arguments*
                              (list *midi-temp-file*)))
     #+sbcl
-    (sb-ext:run-program *midi-player*
-                        (append *midi-player-arguments*
-                                (list *midi-temp-file*))
-                        :search t)
+    (let ((process
+           (sb-ext:run-program *midi-player*
+                               (append *midi-player-arguments*
+                                       (list *midi-temp-file*))
+                               :search t)))
+      (sb-ext:process-wait process)
+      (when (not (zerop (sb-ext:process-exit-code process)))
+        (error 'midi-player-failed
+               :midi-player *midi-player*
+               :exit-code (sb-ext:process-exit-code process))))
     #+clisp
     (ext:run-program *midi-player*
                      :arguments (append *midi-player-arguments*



From rstrandh at common-lisp.net  Mon Oct 22 07:13:50 2007
From: rstrandh at common-lisp.net (rstrandh)
Date: Mon, 22 Oct 2007 03:13:50 -0400 (EDT)
Subject: [gsharp-cvs] CVS gsharp
Message-ID: <20071022071350.5C5DD44055@common-lisp.net>

Update of /project/gsharp/cvsroot/gsharp
In directory clnet:/tmp/cvs-serv1519

Modified Files:
	buffer.lisp 
Log Message:
Implemented a simplified I/O mechanism with less redundancy. 


--- /project/gsharp/cvsroot/gsharp/buffer.lisp	2007/09/18 21:19:03	1.53
+++ /project/gsharp/cvsroot/gsharp/buffer.lisp	2007/10/22 07:13:50	1.54
@@ -12,24 +12,25 @@
 (set-syntax-from-char #\] #\) *gsharp-readtable-v3*)
 (set-syntax-from-char #\] #\) *gsharp-readtable-v4*)
 
-(defclass gsharp-object () ())
+(defgeneric slots-to-be-saved (object)
+  (:method-combination append :most-specific-last))
 
-(defgeneric print-gsharp-object (obj stream)
-  (:method-combination progn))
+(defun save-object (object stream)
+  (pprint-logical-block (stream nil :prefix "[" :suffix "]")
+    (format stream "~s ~2i" (class-name (class-of object)))
+    (loop for slot-name in (slots-to-be-saved object)
+	  do (let ((slot (find slot-name (sb-mop:class-slots (class-of object))
+			       :key #'sb-mop:slot-definition-name
+			       :test #'eq)))
+	       (format stream "~_~W ~W "
+		       (car (sb-mop:slot-definition-initargs slot))
+		       (slot-value object (sb-mop:slot-definition-name slot)))))))
 
-(defmethod print-gsharp-object :around ((obj gsharp-object) stream)
-  (format stream "~s ~2i" (class-name (class-of obj)))
-  (call-next-method))
-
-;;; (defmethod print-object :around ((obj gsharp-object) stream)
-;;;  (format stream "[~a " (slot-value obj 'print-character))
-;;;   (call-next-method)
-;;;   (format stream "] "))
+(defclass gsharp-object () ())
 
 (defmethod print-object ((obj gsharp-object) stream)
   (if *print-circle*
-      (pprint-logical-block (stream nil :prefix "[" :suffix "]")
-        (print-gsharp-object obj stream))
+      (save-object obj stream)
       (print-unreadable-object (obj stream :type t :identity t))))
 
 (defgeneric name (obj))
@@ -37,8 +38,8 @@
 (defclass name-mixin ()
   ((name :initarg :name :accessor name)))
 
-(defmethod print-gsharp-object progn ((obj name-mixin) stream)
-  (format stream "~_:name ~W " (name obj)))
+(defmethod slots-to-be-saved append ((obj name-mixin))
+  '(name))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
@@ -73,8 +74,8 @@
             (:percussion 3))))
   (make-instance 'clef :name name :lineno lineno))
 
-(defmethod print-gsharp-object progn ((c clef) stream)
-  (format stream "~_:lineno ~W " (lineno c)))
+(defmethod slots-to-be-saved append ((c clef))
+  '(lineno))
 
 (defun read-clef-v3 (stream char n)
   (declare (ignore char n))
@@ -139,8 +140,8 @@
   (declare (ignore name clef keysig))
   (apply #'make-instance 'fiveline-staff args))
 
-(defmethod print-gsharp-object progn ((s fiveline-staff) stream)
-  (format stream "~_:clef ~W ~_:keysig ~W " (clef s) (keysig s)))
+(defmethod slots-to-be-saved append ((s fiveline-staff))
+  '(clef %keysig))
 
 (defun read-fiveline-staff-v3 (stream char n)
   (declare (ignore char n))
@@ -240,12 +241,8 @@
            (ignore head accidentals dots))
   (apply #'make-instance 'note :pitch pitch :staff staff args))
 
-(defmethod print-gsharp-object progn ((n note) stream)
-  (with-slots (pitch staff head accidentals dots %tie-right %tie-left) n
-    (format stream
-            "~_:pitch ~W ~_:staff ~W ~_:head ~W ~_:accidentals ~W ~_:dots ~W ~
-             ~@[~_:tie-right ~W ~]~@[~_:tie-left ~W ~]"
-            pitch staff head accidentals dots %tie-right %tie-left)))
+(defmethod slots-to-be-saved append ((n note))
+  '(pitch staff head accidentals dots %tie-right %tie-left))
 
 (defun read-note-v3 (stream char n)
   (declare (ignore char n))
@@ -279,9 +276,8 @@
                       :initarg :master-pitch-freq
                       :accessor master-pitch-freq)))
 
-(defmethod print-gsharp-object progn ((tuning tuning) stream)
-  (format stream "~_:master-pitch-note ~W ~_:master-pitch-freq ~W "
-          (master-pitch-note tuning) (master-pitch-freq tuning)))
+(defmethod slots-to-be-saved append ((tuning tuning))
+  '(master-pitch-note master-pitch-freq))
 
 ;;; Returns how a note should be tuned in a given tuning
 ;;; in terms of a cent value.
@@ -293,9 +289,8 @@
 (defclass 12-edo (tuning)
   ())
 
-(defmethod print-gsharp-object progn ((tuning 12-edo) stream)
-  ;; no parameters to save
-  )
+(defmethod slots-to-be-saved append ((tuning 12-edo))
+  '())
 
 (defmethod note-cents ((note note) (tuning 12-edo))
   (multiple-value-bind (octave pitch) (floor (pitch note) 7)
@@ -322,9 +317,8 @@
    ;; TODO: Add cent sizes of various microtonal accidentals, perhaps in an alist?
    ))
 
-(defmethod print-gsharp-object progn ((tuning regular-temperament) stream)
-  (format stream "~_:octave-cents ~W ~_:fifth-cents ~W "
-          (octave-cents tuning) (fifth-cents tuning)))
+(defmethod slots-to-be-saved append ((tuning regular-temperament))
+  '(octave-cents fifth-cents))
 
 (defmethod note-cents ((note note) (tuning regular-temperament))
   (let ((octaves 1)
@@ -371,10 +365,8 @@
   ((bar :initform nil :initarg :bar :accessor bar)
    (xoffset :initform 0 :initarg :xoffset :accessor xoffset)))
 
-(defmethod print-gsharp-object progn ((e element) stream)
-  (with-slots (notehead rbeams lbeams dots xoffset) e
-    (format stream
-            "~_:xoffset ~W " xoffset)))
+(defmethod slots-to-be-saved append ((e element))
+  '(xoffset))
 
 (defmethod duration ((element element)) 0)
 (defmethod rbeams ((element element)) 0)
@@ -410,11 +402,8 @@
    (lbeams :initform 0 :initarg :lbeams :accessor lbeams)
    (dots :initform 0 :initarg :dots :accessor dots)))
    
-(defmethod print-gsharp-object progn ((e rhythmic-element) stream)
-  (with-slots (notehead rbeams lbeams dots) e
-    (format stream
-            "~_:notehead ~W ~_:rbeams ~W ~_:lbeams ~W ~_:dots ~W "
-            notehead rbeams lbeams dots)))
+(defmethod slots-to-be-saved append ((e rhythmic-element))
+  '(notehead rbeams lbeams dots))
 
 (defmethod undotted-duration ((element rhythmic-element))
   (ecase (notehead element)
@@ -467,10 +456,8 @@
            (ignore alterations))
   (apply #'make-instance 'key-signature :staff staff args))
 
-(defmethod print-gsharp-object progn ((k key-signature) stream)
-  (with-slots (%staff %alterations) k
-    (format stream
-            "~_:staff ~W ~_:alterations ~W " %staff %alterations)))
+(defmethod slots-to-be-saved append ((k key-signature))
+  '(%staff %alterations))
 
 (defmethod more-sharps ((sig key-signature) &optional (n 1))
   (let ((alt (alterations sig)))
@@ -551,9 +538,8 @@
            (ignore notehead lbeams rbeams dots xoffset notes stem-direction))
   (apply #'make-instance 'cluster args))
 
-(defmethod print-gsharp-object progn ((c cluster) stream)
-  (with-slots (stem-direction notes) c
-    (format stream "~_:stem-direction ~W ~_:notes ~W " stem-direction notes)))
+(defmethod slots-to-be-saved append ((c cluster))
+  '(stem-direction notes))
 
 (defun read-cluster-v3 (stream char n)
   (declare (ignore char n))
@@ -637,9 +623,8 @@
   (apply #'make-instance 'rest
          :staff staff args))
 
-(defmethod print-gsharp-object progn ((s rest) stream)
-  (with-slots (staff staff-pos) s
-    (format stream "~_:staff ~W ~_:staff-pos ~W " staff staff-pos)))
+(defmethod slots-to-be-saved append ((s rest))
+  '(staff staff-pos))
 
 (defun read-rest-v3 (stream char n)
   (declare (ignore char n))
@@ -683,9 +668,8 @@
   (apply #'make-instance 'lyrics-element
          :staff staff args))
 
-(defmethod print-gsharp-object progn ((elem lyrics-element) stream)
-  (with-slots (staff text) elem
-     (format stream "~_:staff ~W ~_:text ~W " staff text)))
+(defmethod slots-to-be-saved append ((elem lyrics-element))
+  '(staff text))
 
 (defun read-lyrics-element-v3 (stream char n)
   (declare (ignore char n))
@@ -738,8 +722,8 @@
   (loop for element in (elements b)
         do (setf (bar element) b)))
 
-(defmethod print-gsharp-object progn ((b bar) stream)
-  (format stream "~_:elements ~W " (elements b)))
+(defmethod slots-to-be-saved append ((b bar))
+  '(elements))
 
 ;;; The duration of a bar is simply the sum of durations
 ;;; of its elements.  We might want to improve on the 
@@ -888,8 +872,8 @@
            (ignore bars))
   (apply #'make-instance 'slice args))
 
-(defmethod print-gsharp-object progn ((s slice) stream)
-  (format stream "~_:bars ~W " (bars s)))
+(defmethod slots-to-be-saved append ((s slice))
+  '(bars))
 
 (defun read-slice-v3 (stream char n)
   (declare (ignore char n))
@@ -994,10 +978,8 @@
         (layer (body l)) l
         (layer (tail l)) l))
 
-(defmethod print-gsharp-object progn ((l layer) stream)
-  (with-slots (head body tail staves) l
-    (format stream "~_:staves ~W ~_:head ~W ~_:body ~W ~_:tail ~W "
-            staves head body tail)))
+(defmethod slots-to-be-saved append ((l layer))
+  '(staves head body tail))
 
 (defgeneric make-layer-for-staff (staff &rest args &key staves head body tail &allow-other-keys))
 
@@ -1128,9 +1110,8 @@
     (loop for layer in layers
           do (setf (segment layer) s))))
 
-(defmethod print-gsharp-object progn ((s segment) stream)
-  (format stream "~_:layers ~W ~_:tempo ~W ~_:tuning ~W "
-          (layers s) (tempo s) (tuning s)))
+(defmethod slots-to-be-saved append ((s segment))
+  '(layers tempo tuning))
 
 (defun read-segment-v3 (stream char n)
   (declare (ignore char n))
@@ -1247,11 +1228,8 @@
     (loop for segment in segments
           do (setf (buffer segment) b))))
 
-(defmethod print-gsharp-object progn ((b buffer) stream)
-  (with-slots (staves segments min-width spacing-style right-edge left-offset left-margin) b
-    (format stream 
-            "~_:min-width ~W ~_:spacing-style ~W ~_:right-edge ~W ~_:left-offset ~W ~_:left-margin ~W ~_:staves ~W ~_:segments ~W "
-            min-width spacing-style right-edge left-offset left-margin staves segments )))
+(defmethod slots-to-be-saved append ((b buffer))
+  '(min-width spacing-style right-edge left-offset left-margin staves segments))
 
 (defun read-buffer-v3 (stream char n)
   (declare (ignore char n))



From rstrandh at common-lisp.net  Mon Oct 22 09:39:23 2007
From: rstrandh at common-lisp.net (rstrandh)
Date: Mon, 22 Oct 2007 05:39:23 -0400 (EDT)
Subject: [gsharp-cvs] CVS gsharp
Message-ID: <20071022093923.8DA222826E@common-lisp.net>

Update of /project/gsharp/cvsroot/gsharp
In directory clnet:/tmp/cvs-serv32104

Modified Files:
	buffer.lisp gsharp.asd 
Added Files:
	lyrics.lisp 
Log Message:
Factored out lyrics from buffer.lisp to a new file.



--- /project/gsharp/cvsroot/gsharp/buffer.lisp	2007/10/22 07:13:50	1.54
+++ /project/gsharp/cvsroot/gsharp/buffer.lisp	2007/10/22 09:39:23	1.55
@@ -151,23 +151,6 @@
   #'read-fiveline-staff-v3
   *gsharp-readtable-v3*)
 
-;;; lyric
-
-(defclass lyrics-staff (staff)
-  ((print-character :allocation :class :initform #\L)))
-
-(defun make-lyrics-staff (&rest args &key name)
-  (declare (ignore name))
-  (apply #'make-instance 'lyrics-staff args))
-
-(defun read-lyrics-staff-v3 (stream char n)
-  (declare (ignore char n))
-  (apply #'make-instance 'lyrics-staff (read-delimited-list #\] stream t)))
-
-(set-dispatch-macro-character #\[ #\L
-  #'read-lyrics-staff-v3
-  *gsharp-readtable-v3*)
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
 ;;; Note
@@ -636,58 +619,6 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
-;;; Lyrics element
-
-(defclass lyrics-element (rhythmic-element)
-  ((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)
-   (%tie-right :initform nil :initarg :tie-right :accessor tie-right)
-   (%tie-left :initform nil :initarg :tie-left :accessor tie-left)))
-
-(defmethod initialize-instance :after ((elem lyrics-element) &rest args)
-  (declare (ignore args))
-  (with-slots (text) elem
-     (unless (adjustable-array-p text)
-       (let ((length (length text)))
-         (setf text (make-array length :adjustable t :element-type 'fixnum
-                                :fill-pointer length :initial-contents text))))))
-
-(defun make-lyrics-element (staff &rest args
-                            &key (notehead :filled) (lbeams 0) (rbeams 0)
-                            (dots 0) (xoffset 0))
-  (declare (type staff staff)
-           (type (member :long :breve :whole :half :filled) notehead)
-           (type (integer 0 5) lbeams)
-           (type (integer 0 5) rbeams)
-           (type (integer 0 3) dots)
-           (type number xoffset)
-           (ignore notehead lbeams rbeams dots xoffset))
-  (apply #'make-instance 'lyrics-element
-         :staff staff args))
-
-(defmethod slots-to-be-saved append ((elem lyrics-element))
-  '(staff text))
-
-(defun read-lyrics-element-v3 (stream char n)
-  (declare (ignore char n))
-  (apply #'make-instance 'lyrics-element (read-delimited-list #\] stream t)))
-
-(set-dispatch-macro-character #\[ #\A
-  #'read-lyrics-element-v3
-  *gsharp-readtable-v3*)
-
-(defmethod append-char ((elem lyrics-element) char)
-  (vector-push-extend char (text elem)))
-
-(defmethod erase-char ((elem lyrics-element))
-  (unless (zerop (fill-pointer (text elem)))
-    (decf (fill-pointer (text elem)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
 ;;; Bar
 
 ;;; It is recommended that the concept of a bar be hidden from the
@@ -815,26 +746,6 @@
   #'read-melody-bar-v3
   *gsharp-readtable-v3*)
 
-(defclass lyrics-bar (bar)
-  ((print-character :allocation :class :initform #\C)))
-
-(defun make-lyrics-bar (&rest args &key elements)
-  (declare (type list elements)
-           (ignore elements))
-  (apply #'make-instance 'lyrics-bar args))
-
-(defmethod make-bar-for-staff ((staff lyrics-staff) &rest args &key elements)
-  (declare (ignore elements))
-  (apply #'make-instance 'lyrics-bar args))
-
-(defun read-lyrics-bar-v3 (stream char n)
-  (declare (ignore char n))
-  (apply #'make-instance 'lyrics-bar (read-delimited-list #\] stream t)))
-
-(set-dispatch-macro-character #\[ #\C
-  #'read-lyrics-bar-v3
-  *gsharp-readtable-v3*)
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
 ;;; Slice
@@ -918,16 +829,6 @@
         (add-bar (make-melody-bar) slice 0)))
     (setf slice nil)))
 
-(defmethod remove-bar ((bar lyrics-bar))
-  (with-slots (slice) bar
-    (assert slice () 'bar-not-in-slice)
-    (with-slots (bars) slice
-      (setf bars (delete bar bars :test #'eq))
-      (unless bars
-        ;; make sure there is one bar left
-        (add-bar (make-lyrics-bar) slice 0)))
-    (setf slice nil)))
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
 ;;; Layer
@@ -1006,23 +907,6 @@
   (declare (ignore staves head body tail))
   (apply #'make-instance 'melody-layer args))
 
-;;; lyrics layer
-
-(defclass lyrics-layer (layer)
-  ((print-character :allocation :class :initform #\M)))
-
-(defun read-lyrics-layer-v3 (stream char n)
-  (declare (ignore char n))
-  (apply #'make-instance 'lyrics-layer (read-delimited-list #\] stream t)))
-
-(set-dispatch-macro-character #\[ #\M
-  #'read-lyrics-layer-v3
-  *gsharp-readtable-v3*)
-
-(defmethod make-layer-for-staff ((staff lyrics-staff) &rest args &key staves head body tail &allow-other-keys)
-  (declare (ignore staves head body tail))
-  (apply #'make-instance 'lyrics-layer args))
-
 (defmethod slices ((layer layer))
   (with-slots (head body tail) layer
     (list head body tail)))
--- /project/gsharp/cvsroot/gsharp/gsharp.asd	2007/10/18 15:02:47	1.17
+++ /project/gsharp/cvsroot/gsharp/gsharp.asd	2007/10/22 09:39:23	1.18
@@ -27,6 +27,7 @@
    "sdl"
    "score-pane"
    "buffer"
+   "lyrics"
    "numbering"
    "Obseq/obseq"
    "measure"

--- /project/gsharp/cvsroot/gsharp/lyrics.lisp	2007/10/22 09:39:23	NONE
+++ /project/gsharp/cvsroot/gsharp/lyrics.lisp	2007/10/22 09:39:23	1.1
(in-package :gsharp-buffer)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; staff

(defclass lyrics-staff (staff)
  ((print-character :allocation :class :initform #\L)))

(defun make-lyrics-staff (&rest args &key name)
  (declare (ignore name))
  (apply #'make-instance 'lyrics-staff args))

(defun read-lyrics-staff-v3 (stream char n)
  (declare (ignore char n))
  (apply #'make-instance 'lyrics-staff (read-delimited-list #\] stream t)))

(set-dispatch-macro-character #\[ #\L
  #'read-lyrics-staff-v3
  *gsharp-readtable-v3*)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Lyrics element

(defclass lyrics-element (rhythmic-element)
  ((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)
   (%tie-right :initform nil :initarg :tie-right :accessor tie-right)
   (%tie-left :initform nil :initarg :tie-left :accessor tie-left)))

(defmethod initialize-instance :after ((elem lyrics-element) &rest args)
  (declare (ignore args))
  (with-slots (text) elem
     (unless (adjustable-array-p text)
       (let ((length (length text)))
         (setf text (make-array length :adjustable t :element-type 'fixnum
                                :fill-pointer length :initial-contents text))))))

(defun make-lyrics-element (staff &rest args
                            &key (notehead :filled) (lbeams 0) (rbeams 0)
                            (dots 0) (xoffset 0))
  (declare (type staff staff)
           (type (member :long :breve :whole :half :filled) notehead)
           (type (integer 0 5) lbeams)
           (type (integer 0 5) rbeams)
           (type (integer 0 3) dots)
           (type number xoffset)
           (ignore notehead lbeams rbeams dots xoffset))
  (apply #'make-instance 'lyrics-element
         :staff staff args))

(defmethod slots-to-be-saved append ((elem lyrics-element))
  '(staff text))

(defun read-lyrics-element-v3 (stream char n)
  (declare (ignore char n))
  (apply #'make-instance 'lyrics-element (read-delimited-list #\] stream t)))

(set-dispatch-macro-character #\[ #\A
  #'read-lyrics-element-v3
  *gsharp-readtable-v3*)

(defmethod append-char ((elem lyrics-element) char)
  (vector-push-extend char (text elem)))

(defmethod erase-char ((elem lyrics-element))
  (unless (zerop (fill-pointer (text elem)))
    (decf (fill-pointer (text elem)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Lyrics bar

(defclass lyrics-bar (bar)
  ((print-character :allocation :class :initform #\C)))

(defun make-lyrics-bar (&rest args &key elements)
  (declare (type list elements)
           (ignore elements))
  (apply #'make-instance 'lyrics-bar args))

(defmethod make-bar-for-staff ((staff lyrics-staff) &rest args &key elements)
  (declare (ignore elements))
  (apply #'make-instance 'lyrics-bar args))

(defun read-lyrics-bar-v3 (stream char n)
  (declare (ignore char n))
  (apply #'make-instance 'lyrics-bar (read-delimited-list #\] stream t)))

(set-dispatch-macro-character #\[ #\C
  #'read-lyrics-bar-v3
  *gsharp-readtable-v3*)

(defmethod remove-bar ((bar lyrics-bar))
  (with-slots (slice) bar
    (assert slice () 'bar-not-in-slice)
    (with-slots (bars) slice
      (setf bars (delete bar bars :test #'eq))
      (unless bars
        ;; make sure there is one bar left
        (add-bar (make-lyrics-bar) slice 0)))
    (setf slice nil)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Lyrics layer

(defclass lyrics-layer (layer)
  ((print-character :allocation :class :initform #\M)))

(defun read-lyrics-layer-v3 (stream char n)
  (declare (ignore char n))
  (apply #'make-instance 'lyrics-layer (read-delimited-list #\] stream t)))

(set-dispatch-macro-character #\[ #\M
  #'read-lyrics-layer-v3
  *gsharp-readtable-v3*)

(defmethod make-layer-for-staff ((staff lyrics-staff) &rest args &key staves head body tail &allow-other-keys)
  (declare (ignore staves head body tail))
  (apply #'make-instance 'lyrics-layer args))



From rstrandh at common-lisp.net  Mon Oct 22 10:03:40 2007
From: rstrandh at common-lisp.net (rstrandh)
Date: Mon, 22 Oct 2007 06:03:40 -0400 (EDT)
Subject: [gsharp-cvs] CVS gsharp
Message-ID: <20071022100340.7EA605C17D@common-lisp.net>

Update of /project/gsharp/cvsroot/gsharp
In directory clnet:/tmp/cvs-serv7742

Modified Files:
	buffer.lisp lyrics.lisp 
Log Message:
Got rid of the print-character slot which was used in the old I/O
mechanism.


--- /project/gsharp/cvsroot/gsharp/buffer.lisp	2007/10/22 09:39:23	1.55
+++ /project/gsharp/cvsroot/gsharp/buffer.lisp	2007/10/22 10:03:40	1.56
@@ -58,8 +58,7 @@
 (defgeneric bottom-line (clef))
 
 (defclass clef (gsharp-object name-mixin)
-  ((print-character :allocation :class :initform #\K)
-   (lineno :reader lineno :initarg :lineno
+  ((lineno :reader lineno :initarg :lineno
            :type (or (integer 0 8) null))))
 
 (defun make-clef (name &key lineno)
@@ -123,8 +122,7 @@
 (defgeneric clef (fiveline-staff))
 
 (defclass fiveline-staff (staff)
-  ((print-character :allocation :class :initform #\=)
-   (clef :accessor clef :initarg :clef :initform (make-clef :treble))
+  ((clef :accessor clef :initarg :clef :initform (make-clef :treble))
    (%keysig :accessor keysig :initarg :keysig
             :initform (make-array 7 :initial-element :natural))
    (key-signatures :accessor key-signatures :initform nil)))
@@ -196,8 +194,7 @@
 ;;; number of dots in the usual way. 
 
 (defclass note (gsharp-object)
-  ((print-character :allocation :class :initform #\N)
-   (cluster :initform nil :initarg :cluster :accessor cluster)
+  ((cluster :initform nil :initarg :cluster :accessor cluster)
    (pitch :initarg :pitch :reader pitch :type (integer 0 127))
    (staff :initarg :staff :reader staff :type staff)
    (head :initform nil :initarg :head :reader head
@@ -499,8 +496,7 @@
 (defgeneric remove-note (note))
 
 (defclass cluster (melody-element)
-  ((print-character :allocation :class :initform #\%)
-   (notes :initform '() :initarg :notes :accessor notes)
+  ((notes :initform '() :initarg :notes :accessor notes)
    (stem-direction :initform :auto :initarg :stem-direction :accessor stem-direction)))
 
 (defmethod initialize-instance :after ((c cluster) &rest args)
@@ -588,8 +584,7 @@
 ;;; Rest
 
 (defclass rest (melody-element)
-  ((print-character :allocation :class :initform #\-)
-   (staff :initarg :staff :reader staff)
+  ((staff :initarg :staff :reader staff)
    (staff-pos :initarg :staff-pos :initform 4 :reader staff-pos)))
 
 (defun make-rest (staff &rest args
@@ -726,8 +721,7 @@
 (defmethod remove-element :before ((element element) (bar bar))
   (maybe-update-key-signatures bar))
 
-(defclass melody-bar (bar)
-  ((print-character :allocation :class :initform #\|)))
+(defclass melody-bar (bar) ())
 
 (defun make-melody-bar (&rest args &key elements)
   (declare (type list elements)
@@ -769,8 +763,7 @@
 (defgeneric remove-bar (bar))
 
 (defclass slice (gsharp-object)
-  ((print-character :allocation :class :initform #\/)
-   (layer :initform nil :initarg :layer :accessor layer)
+  ((layer :initform nil :initarg :layer :accessor layer)
    (bars :initform '() :initarg :bars :accessor bars)))
 
 (defmethod initialize-instance :after ((s slice) &rest args)
@@ -892,8 +885,7 @@
 
 ;;; melody layer
 
-(defclass melody-layer (layer)
-  ((print-character :allocation :class :initform #\_)))
+(defclass melody-layer (layer) ())
 
 (defun read-melody-layer-v3 (stream char n)
   (declare (ignore char n))
@@ -978,8 +970,7 @@
 (defgeneric remove-layer (layer))
 
 (defclass segment (gsharp-object)
-  ((print-character :allocation :class :initform #\S)
-   (buffer :initform nil :initarg :buffer :accessor buffer)
+  ((buffer :initform nil :initarg :buffer :accessor buffer)
    (layers :initform '() :initarg :layers :accessor layers)
    (tempo :initform 128 :initarg :tempo :accessor tempo)
    (tuning :initform (make-instance '12-edo)
@@ -1080,8 +1071,7 @@
 (defvar *default-left-margin* 20)
 
 (defclass buffer (gsharp-object esa-buffer-mixin)
-  ((print-character :allocation :class :initform #\B)
-   (segments :initform '() :initarg :segments :accessor segments)
+  ((segments :initform '() :initarg :segments :accessor segments)
    (staves :initform (list (make-fiveline-staff))
            :initarg :staves :accessor staves)
    ;; the min width determines the preferred geographic distance after the
--- /project/gsharp/cvsroot/gsharp/lyrics.lisp	2007/10/22 09:39:23	1.1
+++ /project/gsharp/cvsroot/gsharp/lyrics.lisp	2007/10/22 10:03:40	1.2
@@ -4,8 +4,7 @@
 ;;;
 ;;; staff
 
-(defclass lyrics-staff (staff)
-  ((print-character :allocation :class :initform #\L)))
+(defclass lyrics-staff (staff) ())
 
 (defun make-lyrics-staff (&rest args &key name)
   (declare (ignore name))
@@ -24,8 +23,7 @@
 ;;; Lyrics element
 
 (defclass lyrics-element (rhythmic-element)
-  ((print-character :allocation :class :initform #\A)
-   (staff :initarg :staff :reader staff)
+  ((staff :initarg :staff :reader staff)
    (text :initarg :text
          :initform (make-array 5 :adjustable t :element-type 'fixnum :fill-pointer 0)
          :reader text)
@@ -75,8 +73,7 @@
 ;;;
 ;;; Lyrics bar
 
-(defclass lyrics-bar (bar)
-  ((print-character :allocation :class :initform #\C)))
+(defclass lyrics-bar (bar) ())
 
 (defun make-lyrics-bar (&rest args &key elements)
   (declare (type list elements)
@@ -109,8 +106,7 @@
 ;;;
 ;;; Lyrics layer
 
-(defclass lyrics-layer (layer)
-  ((print-character :allocation :class :initform #\M)))
+(defclass lyrics-layer (layer) ())
 
 (defun read-lyrics-layer-v3 (stream char n)
   (declare (ignore char n))



From rstrandh at common-lisp.net  Mon Oct 22 11:45:37 2007
From: rstrandh at common-lisp.net (rstrandh)
Date: Mon, 22 Oct 2007 07:45:37 -0400 (EDT)
Subject: [gsharp-cvs] CVS gsharp
Message-ID: <20071022114537.5E9B71B01A@common-lisp.net>

Update of /project/gsharp/cvsroot/gsharp
In directory clnet:/tmp/cvs-serv25693

Modified Files:
	buffer.lisp gsharp.asd 
Added Files:
	melody.lisp 
Log Message:
I moved melody-related functionality from buffer.lisp to a new file. 


--- /project/gsharp/cvsroot/gsharp/buffer.lisp	2007/10/22 10:03:40	1.56
+++ /project/gsharp/cvsroot/gsharp/buffer.lisp	2007/10/22 11:45:36	1.57
@@ -33,6 +33,8 @@
       (save-object obj stream)
       (print-unreadable-object (obj stream :type t :identity t))))
 
+(define-condition gsharp-condition (error) ())
+
 (defgeneric name (obj))
 
 (defclass name-mixin ()
@@ -43,296 +45,12 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
-;;; 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))
-
-;;; for key signature drawing calcluations.  FIXME: in fact the layout
-;;; of key signatures isn't the same across all clefs.
-(defgeneric b-position (clef))
-(defgeneric f-position (clef))
-
-;;; the note number of the bottom line of this clef.
-(defgeneric bottom-line (clef))
-
-(defclass clef (gsharp-object name-mixin)
-  ((lineno :reader lineno :initarg :lineno
-           :type (or (integer 0 8) null))))
-
-(defun make-clef (name &key lineno)
-  (declare (type (member :treble :treble8 :bass :c :percussion) name)
-           (type (or (integer 0 8) null) lineno))
-  (when (null lineno)
-    (setf lineno
-          (ecase name
-            ((:treble :treble8) 2)
-            (:bass 6)
-            (:c 4)
-            (:percussion 3))))
-  (make-instance 'clef :name name :lineno lineno))
-
-(defmethod slots-to-be-saved append ((c clef))
-  '(lineno))
-
-(defun read-clef-v3 (stream char n)
-  (declare (ignore char n))
-  (apply #'make-instance 'clef (read-delimited-list #\] stream t)))
-
-(set-dispatch-macro-character #\[ #\K
-  #'read-clef-v3
-  *gsharp-readtable-v3*)
-
-;;; given a clef, return the staff step of the B that should have
-;;; the first flat sign in key signatures with flats
-(defmethod b-position ((clef clef))
-  (ecase (name clef)
-    (:bass (- (lineno clef) 4))
-    ((:treble :treble8) (+ (lineno clef) 2))
-    (:c (- (lineno clef) 1))))
-
-
-;;; given a clef, return the staff step of the F that should have
-;;; the first sharp sign in key signatures with sharps
-(defmethod f-position ((clef clef))
-  (ecase (name clef)
-    (:bass (lineno clef))
-    ((:treble :treble8) (+ (lineno clef) 6))
-    (:c (+ (lineno clef) 3))))
-
-(defmethod bottom-line ((clef clef))
-  (- (ecase (name clef)
-       (:treble 32)
-       (:bass 24)
-       (:c 28)
-       (:treble8 25))
-     (lineno clef)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
 ;;; Staff
 
 (defclass staff (gsharp-object name-mixin)
   ((buffer :initarg :buffer :accessor buffer))
   (:default-initargs :name "default staff"))
 
-;;; fiveline
-
-(defgeneric clef (fiveline-staff))
-
-(defclass fiveline-staff (staff)
-  ((clef :accessor clef :initarg :clef :initform (make-clef :treble))
-   (%keysig :accessor keysig :initarg :keysig
-            :initform (make-array 7 :initial-element :natural))
-   (key-signatures :accessor key-signatures :initform nil)))
-           
-(defmethod initialize-instance :after ((obj fiveline-staff) &rest args)
-  (declare (ignore args))
-  (with-slots (%keysig) obj
-    (when (vectorp %keysig)
-      (setf %keysig
-            (make-instance 'key-signature :staff obj :alterations %keysig)))))
-
-(defun make-fiveline-staff (&rest args &key name clef keysig)
-  (declare (ignore name clef keysig))
-  (apply #'make-instance 'fiveline-staff args))
-
-(defmethod slots-to-be-saved append ((s fiveline-staff))
-  '(clef %keysig))
-
-(defun read-fiveline-staff-v3 (stream char n)
-  (declare (ignore char n))
-  (apply #'make-instance 'fiveline-staff (read-delimited-list #\] stream t)))
-
-(set-dispatch-macro-character #\[ #\=
-  #'read-fiveline-staff-v3
-  *gsharp-readtable-v3*)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Note
-
-;;; Notes are immutable objets.  If you want to alter (say) the staff
-;;; or the pitch of a note, you have to delete it and add a new note
-;;; with the right characteristics.
-
-;;; Return the pitch of the note. 
-(defgeneric pitch (note))
-
-;;; Return the accidentals of the note.  The value returned is one of
-;;; :natural :flat :double-flat :sharp or :double-sharp.
-(defgeneric accidentals (note))
-
-;;; Return a non-negative integer indicating the number of dots of the
-;;; note.  The value nil is returned whenever the note takes its
-;;; number of dots from the cluster to which it belongs.
-(defgeneric dots (note))
-
-;;; Returns the cluster to which the note belongs, or nil if the note
-;;; currently does not belong to any cluster. 
-(defgeneric cluster (note))
-
-;;; The pitch is a number from 0 to 128
-;;; 
-;;; The staff is a staff object. 
-;;; 
-;;; Head can be :long, :breve, :whole, :half, :filled, or nil.  A
-;;; value of nil means that the notehead is determined by that of the
-;;; cluster to which the note belongs.
-;;; 
-;;; Accidentals can be :natural :flat :double-flat :sharp or :double-sharp.
-;;; The default is :natural.  Whether a note is actually displayed
-;;; preceded by one of the corresponding signs is a matter of context and
-;;; display style. 
-;;; 
-;;; The number of dots can be an integer or nil, meaning that the number
-;;; of dots is taken from the cluster.  The default value is nil.
-;;; 
-;;; The actual duration of the note is computed from the note head, the
-;;; number of beams of the cluster to which the note belongs, and the
-;;; number of dots in the usual way. 
-
-(defclass note (gsharp-object)
-  ((cluster :initform nil :initarg :cluster :accessor cluster)
-   (pitch :initarg :pitch :reader pitch :type (integer 0 127))
-   (staff :initarg :staff :reader staff :type staff)
-   (head :initform nil :initarg :head :reader head
-         :type (or (member :long :breve :whole :half :filled) null))
-   (accidentals :initform :natural :initarg :accidentals :reader accidentals
-		;; FIXME: we want :TYPE ACCIDENTAL here but need to
-		;; sort out order of definition for that to be useful.
-		#+nil #+nil 
-                :type (member :natural :flat :double-flat :sharp :double-sharp))
-   (dots :initform nil :initarg :dots :reader dots
-         :type (or (integer 0 3) null))
-   (%tie-right :initform nil :initarg :tie-right :accessor tie-right)
-   (%tie-left :initform nil :initarg :tie-left :accessor tie-left)))
-
-(defun make-note (pitch staff &rest args &key head (accidentals :natural) dots)
-  (declare (type (integer 0 127) pitch)
-           (type staff staff)
-           (type (or (member :long :breve :whole :half :filled) null) head)
-	   ;; FIXME: :TYPE ACCIDENTAL
-	   #+nil #+nil
-           (type (member :natural :flat :double-flat :sharp :double-sharp)
-                 accidentals)
-           (type (or (integer 0 3) null) dots)
-           (ignore head accidentals dots))
-  (apply #'make-instance 'note :pitch pitch :staff staff args))
-
-(defmethod slots-to-be-saved append ((n note))
-  '(pitch staff head accidentals dots %tie-right %tie-left))
-
-(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-v3
-  *gsharp-readtable-v3*)
-
-;;; Return true if note1 is considered less than note2.
-(defun note-less (note1 note2)
-  (< (pitch note1) (pitch note2)))
-
-;;; Return true if note1 is considered equal to note2.
-(defun note-equal (note1 note2)
-  (= (pitch note1) (pitch note2)))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Tuning (support for microtonal and historical tunings/temperaments)
-
-;;; FIXME: add name-mixin also?
-(defclass tuning (gsharp-object)
-  ((master-pitch-note :initform (make-instance 'note :pitch 33 ; a above middle c
-                                                     :staff (make-instance 'staff))
-                      :initarg :master-pitch-note
-                      :type note
-                      :accessor master-pitch-note)
-   (master-pitch-freq :initform 440
-                      :initarg :master-pitch-freq
-                      :accessor master-pitch-freq)))
-
-(defmethod slots-to-be-saved append ((tuning tuning))
-  '(master-pitch-note master-pitch-freq))
-
-;;; Returns how a note should be tuned in a given tuning
-;;; in terms of a cent value.
-(defgeneric note-cents (note tuning))
-
-;;; 12-edo is provided for efficiency only. It is a 
-;;; special case of a regular temperament. Perhaps it
-;;; should be removed?
-(defclass 12-edo (tuning)
-  ())
-
-(defmethod slots-to-be-saved append ((tuning 12-edo))
-  '())
-
-(defmethod note-cents ((note note) (tuning 12-edo))
-  (multiple-value-bind (octave pitch) (floor (pitch note) 7)
-    (+ (* 1200 (1+ octave))
-       (ecase pitch (0 0) (1 200) (2 400) (3 500) (4 700) (5 900) (6 1100))
-       (ecase (accidentals note)
-         (:double-flat -200)
-	 (:sesquiflat -150)
-         (:flat -100)
-	 (:semiflat -50)
-         (:natural 0)
-	 (:semisharp 50)
-         (:sharp 100)
-	 (:sesquisharp 150)
-         (:double-sharp 200)))))
-
-;;; regular temperaments are temperaments that
-;;; retain their interval sizes regardless of modulation, as opposed to
-;;; irregular temperaments.
-(defclass regular-temperament (tuning)
-  ((octave-cents :initform 1200 :initarg :octave-cents :accessor octave-cents)
-   (fifth-cents :initform 700 :initarg :fifth-cents :accessor fifth-cents)
-   (quartertone-cents :initform 50 :initarg :quartertone-cents :accessor quartertone-cents)
-   ;; TODO: Add cent sizes of various microtonal accidentals, perhaps in an alist?
-   ))
-
-(defmethod slots-to-be-saved append ((tuning regular-temperament))
-  '(octave-cents fifth-cents))
-
-(defmethod note-cents ((note note) (tuning regular-temperament))
-  (let ((octaves 1)
-        (fifths 0)
-        (sharps 0) ;; short for 7 fifths up and 4 octaves down
-        (quartertones 0))
-    (incf octaves (floor (pitch note) 7))
-    (ecase (mod (pitch note) 7)
-      (0 (progn))
-      (1 (progn (incf octaves -1) (incf fifths 2)))
-      (2 (progn (incf octaves -2) (incf fifths 4)))
-      (3 (progn (incf octaves 1) (incf fifths -1)))
-      (4 (progn (incf fifths 1)))
-      (5 (progn (incf octaves -1) (incf fifths 3)))
-      (6 (progn (incf octaves -2) (incf fifths 5))))
-    (ecase (accidentals note)
-      (:double-flat (incf sharps -2))
-      (:sesquiflat (incf sharps -1) (incf quartertones -1))
-      (:flat (incf sharps -1))
-      (:semiflat (incf quartertones -1))
-      (:natural)
-      (:semisharp (incf quartertones 1))
-      (:sharp (incf sharps 1))
-      (:sesquisharp (incf sharps 1) (incf quartertones 1))
-      (:double-sharp (incf sharps 2)))
-    (incf octaves (* -4 sharps))
-    (incf fifths (* 7 sharps))
-    (+ (* octaves (octave-cents tuning))
-       (* fifths (fifth-cents tuning))
-       (* quartertones (quartertone-cents tuning)))))
- 
-;;; TODO: (defclass irregular-temperament ...)
- 
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
 ;;; Element
@@ -404,216 +122,6 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
-;;; Melody element
-
-(defclass melody-element (rhythmic-element) ())
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Key signature
-
-(defgeneric alterations (key-signature)
-  (:documentation "return the alterations in the form of a 
-7-element array where each element is either :natural,
-:sharp, or :flat according to how each staff position 
-should be altered"))
-
-(defgeneric more-sharps (key-signature &optional n)
-  (:documentation "make the key signature N alterations
-sharper by removing some flats and/or adding some sharps"))
-
-(defgeneric more-flats (key-signature &optional n)
-  (:documentation "make the key signature N alterations
-flatter by removing some sharps and/or adding some flats"))
-
-(defclass key-signature (element)
-  ((%staff :initarg :staff :reader staff)
-   (%alterations :initform (make-array 7 :initial-element :natural) 
-                 :initarg :alterations :reader alterations)))
-
-(defun make-key-signature (staff &rest args &key alterations)
-  (declare (type (or null (simple-vector 7)) alterations)
-           (ignore alterations))
-  (apply #'make-instance 'key-signature :staff staff args))
-
-(defmethod slots-to-be-saved append ((k key-signature))
-  '(%staff %alterations))
-
-(defmethod more-sharps ((sig key-signature) &optional (n 1))
-  (let ((alt (alterations sig)))
-    (loop repeat n
-          do (cond ((eq (aref alt 3) :flat) (setf (aref alt 3) :natural))
-                   ((eq (aref alt 0) :flat) (setf (aref alt 0) :natural))
-                   ((eq (aref alt 4) :flat) (setf (aref alt 4) :natural))
-                   ((eq (aref alt 1) :flat) (setf (aref alt 1) :natural))
-                   ((eq (aref alt 5) :flat) (setf (aref alt 5) :natural))
-                   ((eq (aref alt 2) :flat) (setf (aref alt 2) :natural))
-                   ((eq (aref alt 6) :flat) (setf (aref alt 6) :natural))
-                   ((eq (aref alt 3) :natural) (setf (aref alt 3) :sharp))
-                   ((eq (aref alt 0) :natural) (setf (aref alt 0) :sharp))
-                   ((eq (aref alt 4) :natural) (setf (aref alt 4) :sharp))
-                   ((eq (aref alt 1) :natural) (setf (aref alt 1) :sharp))
-                   ((eq (aref alt 5) :natural) (setf (aref alt 5) :sharp))
-                   ((eq (aref alt 2) :natural) (setf (aref alt 2) :sharp))
-                   ((eq (aref alt 6) :natural) (setf (aref alt 6) :sharp))))))
-
-(defmethod more-flats ((sig key-signature) &optional (n 1))
-  (let ((alt (alterations sig)))
-    (loop repeat n
-          do (cond ((eq (aref alt 6) :sharp) (setf (aref alt 6) :natural))
-                   ((eq (aref alt 2) :sharp) (setf (aref alt 2) :natural))
-                   ((eq (aref alt 5) :sharp) (setf (aref alt 5) :natural))
-                   ((eq (aref alt 1) :sharp) (setf (aref alt 1) :natural))
-                   ((eq (aref alt 4) :sharp) (setf (aref alt 4) :natural))
-                   ((eq (aref alt 0) :sharp) (setf (aref alt 0) :natural))
-                   ((eq (aref alt 3) :sharp) (setf (aref alt 3) :natural))
-                   ((eq (aref alt 6) :natural) (setf (aref alt 6) :flat))
-                   ((eq (aref alt 2) :natural) (setf (aref alt 2) :flat))
-                   ((eq (aref alt 5) :natural) (setf (aref alt 5) :flat))
-                   ((eq (aref alt 1) :natural) (setf (aref alt 1) :flat))
-                   ((eq (aref alt 4) :natural) (setf (aref alt 4) :flat))
-                   ((eq (aref alt 0) :natural) (setf (aref alt 0) :flat))
-                   ((eq (aref alt 3) :natural) (setf (aref alt 3) :flat))))))
-                                                                              
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Cluster
-
-;;; Return a list of the notes of the cluster
-(defgeneric notes (cluster))
-
-;;; Add a note to the cluster.  It is an error if there is already a
-;;; note in the cluster with the same staff and the same pitch.
-(defgeneric add-note (cluster note))
-
-;;; Find a note in a cluster.  The comparison is made using only the 
-;;; pitch of the supplied note.  If the note does not exist nil is returned.
-(defgeneric find-note (cluster note))
-
-;;; Delete a note from the cluster to which it belongs.  It is an
-;;; error to call this function if the note currently does not belong

[199 lines skipped]
--- /project/gsharp/cvsroot/gsharp/gsharp.asd	2007/10/22 09:39:23	1.18
+++ /project/gsharp/cvsroot/gsharp/gsharp.asd	2007/10/22 11:45:37	1.19
@@ -27,6 +27,7 @@
    "sdl"
    "score-pane"
    "buffer"
+   "melody"
    "lyrics"
    "numbering"
    "Obseq/obseq"

--- /project/gsharp/cvsroot/gsharp/melody.lisp	2007/10/22 11:45:37	NONE
+++ /project/gsharp/cvsroot/gsharp/melody.lisp	2007/10/22 11:45:37	1.1
(in-package :gsharp-buffer)

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

;;; for key signature drawing calcluations.  FIXME: in fact the layout
;;; of key signatures isn't the same across all clefs.
(defgeneric b-position (clef))
(defgeneric f-position (clef))

;;; the note number of the bottom line of this clef.
(defgeneric bottom-line (clef))

(defclass clef (gsharp-object name-mixin)
  ((lineno :reader lineno :initarg :lineno
           :type (or (integer 0 8) null))))

(defun make-clef (name &key lineno)
  (declare (type (member :treble :treble8 :bass :c :percussion) name)
           (type (or (integer 0 8) null) lineno))
  (when (null lineno)
    (setf lineno
          (ecase name
            ((:treble :treble8) 2)
            (:bass 6)
            (:c 4)
            (:percussion 3))))
  (make-instance 'clef :name name :lineno lineno))

(defmethod slots-to-be-saved append ((c clef))
  '(lineno))

(defun read-clef-v3 (stream char n)
  (declare (ignore char n))
  (apply #'make-instance 'clef (read-delimited-list #\] stream t)))

(set-dispatch-macro-character #\[ #\K
  #'read-clef-v3
  *gsharp-readtable-v3*)

;;; given a clef, return the staff step of the B that should have
;;; the first flat sign in key signatures with flats
(defmethod b-position ((clef clef))
  (ecase (name clef)
    (:bass (- (lineno clef) 4))
    ((:treble :treble8) (+ (lineno clef) 2))
    (:c (- (lineno clef) 1))))


;;; given a clef, return the staff step of the F that should have
;;; the first sharp sign in key signatures with sharps
(defmethod f-position ((clef clef))
  (ecase (name clef)
    (:bass (lineno clef))
    ((:treble :treble8) (+ (lineno clef) 6))
    (:c (+ (lineno clef) 3))))

(defmethod bottom-line ((clef clef))
  (- (ecase (name clef)
       (:treble 32)
       (:bass 24)
       (:c 28)
       (:treble8 25))
     (lineno clef)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Fiveline staff

(defgeneric clef (fiveline-staff))

(defclass fiveline-staff (staff)
  ((clef :accessor clef :initarg :clef :initform (make-clef :treble))
   (%keysig :accessor keysig :initarg :keysig
            :initform (make-array 7 :initial-element :natural))
   (key-signatures :accessor key-signatures :initform nil)))
           
(defmethod initialize-instance :after ((obj fiveline-staff) &rest args)
  (declare (ignore args))
  (with-slots (%keysig) obj
    (when (vectorp %keysig)
      (setf %keysig
            (make-instance 'key-signature :staff obj :alterations %keysig)))))

(defun make-fiveline-staff (&rest args &key name clef keysig)
  (declare (ignore name clef keysig))
  (apply #'make-instance 'fiveline-staff args))

(defmethod slots-to-be-saved append ((s fiveline-staff))
  '(clef %keysig))

(defun read-fiveline-staff-v3 (stream char n)
  (declare (ignore char n))
  (apply #'make-instance 'fiveline-staff (read-delimited-list #\] stream t)))

(set-dispatch-macro-character #\[ #\=
  #'read-fiveline-staff-v3
  *gsharp-readtable-v3*)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Note

;;; Notes are immutable objets.  If you want to alter (say) the staff
;;; or the pitch of a note, you have to delete it and add a new note
;;; with the right characteristics.

;;; Return the pitch of the note. 
(defgeneric pitch (note))

;;; Return the accidentals of the note.  The value returned is one of
;;; :natural :flat :double-flat :sharp or :double-sharp.
(defgeneric accidentals (note))

;;; Return a non-negative integer indicating the number of dots of the
;;; note.  The value nil is returned whenever the note takes its
;;; number of dots from the cluster to which it belongs.
(defgeneric dots (note))

;;; Returns the cluster to which the note belongs, or nil if the note
;;; currently does not belong to any cluster. 
(defgeneric cluster (note))

;;; The pitch is a number from 0 to 128
;;; 
;;; The staff is a staff object. 
;;; 
;;; Head can be :long, :breve, :whole, :half, :filled, or nil.  A
;;; value of nil means that the notehead is determined by that of the
;;; cluster to which the note belongs.
;;; 
;;; Accidentals can be :natural :flat :double-flat :sharp or :double-sharp.
;;; The default is :natural.  Whether a note is actually displayed
;;; preceded by one of the corresponding signs is a matter of context and
;;; display style. 
;;; 
;;; The number of dots can be an integer or nil, meaning that the number
;;; of dots is taken from the cluster.  The default value is nil.
;;; 
;;; The actual duration of the note is computed from the note head, the
;;; number of beams of the cluster to which the note belongs, and the
;;; number of dots in the usual way. 

(defclass note (gsharp-object)
  ((cluster :initform nil :initarg :cluster :accessor cluster)
   (pitch :initarg :pitch :reader pitch :type (integer 0 127))
   (staff :initarg :staff :reader staff :type staff)
   (head :initform nil :initarg :head :reader head
         :type (or (member :long :breve :whole :half :filled) null))
   (accidentals :initform :natural :initarg :accidentals :reader accidentals
		;; FIXME: we want :TYPE ACCIDENTAL here but need to
		;; sort out order of definition for that to be useful.
		#+nil #+nil 
                :type (member :natural :flat :double-flat :sharp :double-sharp))
   (dots :initform nil :initarg :dots :reader dots
         :type (or (integer 0 3) null))
   (%tie-right :initform nil :initarg :tie-right :accessor tie-right)
   (%tie-left :initform nil :initarg :tie-left :accessor tie-left)))

(defun make-note (pitch staff &rest args &key head (accidentals :natural) dots)
  (declare (type (integer 0 127) pitch)
           (type staff staff)
           (type (or (member :long :breve :whole :half :filled) null) head)
	   ;; FIXME: :TYPE ACCIDENTAL
	   #+nil #+nil
           (type (member :natural :flat :double-flat :sharp :double-sharp)
                 accidentals)
           (type (or (integer 0 3) null) dots)
           (ignore head accidentals dots))
  (apply #'make-instance 'note :pitch pitch :staff staff args))

(defmethod slots-to-be-saved append ((n note))
  '(pitch staff head accidentals dots %tie-right %tie-left))

(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-v3
  *gsharp-readtable-v3*)

;;; Return true if note1 is considered less than note2.
(defun note-less (note1 note2)
  (< (pitch note1) (pitch note2)))

;;; Return true if note1 is considered equal to note2.
(defun note-equal (note1 note2)
  (= (pitch note1) (pitch note2)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Tuning (support for microtonal and historical tunings/temperaments)

;;; FIXME: add name-mixin also?
(defclass tuning (gsharp-object)
  ((master-pitch-note :initform (make-instance 'note :pitch 33 ; a above middle c
                                                     :staff (make-instance 'staff))
                      :initarg :master-pitch-note
                      :type note
                      :accessor master-pitch-note)
   (master-pitch-freq :initform 440
                      :initarg :master-pitch-freq
                      :accessor master-pitch-freq)))

(defmethod slots-to-be-saved append ((tuning tuning))
  '(master-pitch-note master-pitch-freq))

;;; Returns how a note should be tuned in a given tuning
;;; in terms of a cent value.
(defgeneric note-cents (note tuning))

;;; 12-edo is provided for efficiency only. It is a 
;;; special case of a regular temperament. Perhaps it
;;; should be removed?
(defclass 12-edo (tuning)
  ())

(defmethod slots-to-be-saved append ((tuning 12-edo))
  '())

(defmethod note-cents ((note note) (tuning 12-edo))
  (multiple-value-bind (octave pitch) (floor (pitch note) 7)
    (+ (* 1200 (1+ octave))
       (ecase pitch (0 0) (1 200) (2 400) (3 500) (4 700) (5 900) (6 1100))
       (ecase (accidentals note)
         (:double-flat -200)
	 (:sesquiflat -150)
         (:flat -100)
	 (:semiflat -50)
         (:natural 0)
	 (:semisharp 50)
         (:sharp 100)
	 (:sesquisharp 150)
         (:double-sharp 200)))))

;;; regular temperaments are temperaments that
;;; retain their interval sizes regardless of modulation, as opposed to
;;; irregular temperaments.
(defclass regular-temperament (tuning)
  ((octave-cents :initform 1200 :initarg :octave-cents :accessor octave-cents)
   (fifth-cents :initform 700 :initarg :fifth-cents :accessor fifth-cents)
   (quartertone-cents :initform 50 :initarg :quartertone-cents :accessor quartertone-cents)
   ;; TODO: Add cent sizes of various microtonal accidentals, perhaps in an alist?
   ))

(defmethod slots-to-be-saved append ((tuning regular-temperament))
  '(octave-cents fifth-cents))

(defmethod note-cents ((note note) (tuning regular-temperament))
  (let ((octaves 1)
        (fifths 0)
        (sharps 0) ;; short for 7 fifths up and 4 octaves down
        (quartertones 0))
    (incf octaves (floor (pitch note) 7))
    (ecase (mod (pitch note) 7)
      (0 (progn))
      (1 (progn (incf octaves -1) (incf fifths 2)))
      (2 (progn (incf octaves -2) (incf fifths 4)))
      (3 (progn (incf octaves 1) (incf fifths -1)))
      (4 (progn (incf fifths 1)))
      (5 (progn (incf octaves -1) (incf fifths 3)))
      (6 (progn (incf octaves -2) (incf fifths 5))))
    (ecase (accidentals note)
      (:double-flat (incf sharps -2))
      (:sesquiflat (incf sharps -1) (incf quartertones -1))
      (:flat (incf sharps -1))
      (:semiflat (incf quartertones -1))
      (:natural)
      (:semisharp (incf quartertones 1))
      (:sharp (incf sharps 1))
      (:sesquisharp (incf sharps 1) (incf quartertones 1))
      (:double-sharp (incf sharps 2)))
    (incf octaves (* -4 sharps))
    (incf fifths (* 7 sharps))
    (+ (* octaves (octave-cents tuning))
       (* fifths (fifth-cents tuning))
       (* quartertones (quartertone-cents tuning)))))
 
;;; TODO: (defclass irregular-temperament ...)
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Melody element

(defclass melody-element (rhythmic-element) ())

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Key signature

(defgeneric alterations (key-signature)
  (:documentation "return the alterations in the form of a 
7-element array where each element is either :natural,
:sharp, or :flat according to how each staff position 
should be altered"))

(defgeneric more-sharps (key-signature &optional n)
  (:documentation "make the key signature N alterations
sharper by removing some flats and/or adding some sharps"))

(defgeneric more-flats (key-signature &optional n)
  (:documentation "make the key signature N alterations
flatter by removing some sharps and/or adding some flats"))

(defclass key-signature (element)
  ((%staff :initarg :staff :reader staff)
   (%alterations :initform (make-array 7 :initial-element :natural) 
                 :initarg :alterations :reader alterations)))

(defun make-key-signature (staff &rest args &key alterations)
  (declare (type (or null (simple-vector 7)) alterations)
           (ignore alterations))
  (apply #'make-instance 'key-signature :staff staff args))

(defmethod slots-to-be-saved append ((k key-signature))
  '(%staff %alterations))

(defmethod more-sharps ((sig key-signature) &optional (n 1))
  (let ((alt (alterations sig)))
    (loop repeat n
          do (cond ((eq (aref alt 3) :flat) (setf (aref alt 3) :natural))
                   ((eq (aref alt 0) :flat) (setf (aref alt 0) :natural))
                   ((eq (aref alt 4) :flat) (setf (aref alt 4) :natural))
                   ((eq (aref alt 1) :flat) (setf (aref alt 1) :natural))
                   ((eq (aref alt 5) :flat) (setf (aref alt 5) :natural))
                   ((eq (aref alt 2) :flat) (setf (aref alt 2) :natural))
                   ((eq (aref alt 6) :flat) (setf (aref alt 6) :natural))
                   ((eq (aref alt 3) :natural) (setf (aref alt 3) :sharp))
                   ((eq (aref alt 0) :natural) (setf (aref alt 0) :sharp))
                   ((eq (aref alt 4) :natural) (setf (aref alt 4) :sharp))
                   ((eq (aref alt 1) :natural) (setf (aref alt 1) :sharp))
                   ((eq (aref alt 5) :natural) (setf (aref alt 5) :sharp))
                   ((eq (aref alt 2) :natural) (setf (aref alt 2) :sharp))
                   ((eq (aref alt 6) :natural) (setf (aref alt 6) :sharp))))))

(defmethod more-flats ((sig key-signature) &optional (n 1))
  (let ((alt (alterations sig)))
    (loop repeat n
          do (cond ((eq (aref alt 6) :sharp) (setf (aref alt 6) :natural))
                   ((eq (aref alt 2) :sharp) (setf (aref alt 2) :natural))
                   ((eq (aref alt 5) :sharp) (setf (aref alt 5) :natural))
                   ((eq (aref alt 1) :sharp) (setf (aref alt 1) :natural))
                   ((eq (aref alt 4) :sharp) (setf (aref alt 4) :natural))
                   ((eq (aref alt 0) :sharp) (setf (aref alt 0) :natural))
                   ((eq (aref alt 3) :sharp) (setf (aref alt 3) :natural))
                   ((eq (aref alt 6) :natural) (setf (aref alt 6) :flat))
                   ((eq (aref alt 2) :natural) (setf (aref alt 2) :flat))
                   ((eq (aref alt 5) :natural) (setf (aref alt 5) :flat))
                   ((eq (aref alt 1) :natural) (setf (aref alt 1) :flat))
                   ((eq (aref alt 4) :natural) (setf (aref alt 4) :flat))
                   ((eq (aref alt 0) :natural) (setf (aref alt 0) :flat))
                   ((eq (aref alt 3) :natural) (setf (aref alt 3) :flat))))))
                                                                              
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Cluster

;;; Return a list of the notes of the cluster
(defgeneric notes (cluster))

;;; Add a note to the cluster.  It is an error if there is already a
;;; note in the cluster with the same staff and the same pitch.
(defgeneric add-note (cluster note))

;;; Find a note in a cluster.  The comparison is made using only the 
;;; pitch of the supplied note.  If the note does not exist nil is returned.
(defgeneric find-note (cluster note))

;;; Delete a note from the cluster to which it belongs.  It is an
;;; error to call this function if the note currently does not belong
;;; to any cluster. 
(defgeneric remove-note (note))

(defclass cluster (melody-element)
  ((notes :initform '() :initarg :notes :accessor notes)
   (stem-direction :initform :auto :initarg :stem-direction :accessor stem-direction)))

(defmethod initialize-instance :after ((c cluster) &rest args)
  (declare (ignore args))
  (loop for note in (notes c)
        do (setf (cluster note) c)))

(defun make-cluster (&rest args

[156 lines skipped]


From mjonsson at common-lisp.net  Sat Oct 27 02:10:55 2007
From: mjonsson at common-lisp.net (mjonsson)
Date: Fri, 26 Oct 2007 22:10:55 -0400 (EDT)
Subject: [gsharp-cvs] CVS gsharp
Message-ID: <20071027021055.6946D250ED@common-lisp.net>

Update of /project/gsharp/cvsroot/gsharp
In directory clnet:/tmp/cvs-serv24656

Modified Files:
	gui.lisp play.lisp 
Log Message:
Implemented play-buffer and made play-layer available in play menu

--- /project/gsharp/cvsroot/gsharp/gui.lisp	2007/09/18 21:19:03	1.87
+++ /project/gsharp/cvsroot/gsharp/gui.lisp	2007/10/27 02:10:55	1.88
@@ -534,7 +534,11 @@
  'play-command-table
  :errorp nil
  :menu '(("Buffer" :command com-play-buffer)
-         ("Segment" :command com-play-segment)))
+         ("Segment" :command com-play-segment)
+         ("Layer" :command com-play-layer)))
+
+(define-gsharp-command (com-play-buffer :name t) ()
+  (play-buffer (buffer (current-cursor))))
 
 (define-gsharp-command (com-play-segment :name t) ()
   (play-segment (segment (current-cursor))))
--- /project/gsharp/cvsroot/gsharp/play.lisp	2007/10/20 18:41:25	1.10
+++ /project/gsharp/cvsroot/gsharp/play.lisp	2007/10/27 02:10:55	1.11
@@ -19,12 +19,12 @@
 
 (defun measure-durations (slices)
   (let ((durations (mapcar (lambda (slice)
-			     (mapcar #'duration
-				     (bars slice)))
-			   slices)))
+                             (mapcar #'duration
+                                     (bars slice)))
+                           slices)))
     (loop while durations
-	  collect (reduce #'max durations :key #'car)
-	  do (setf durations (remove nil (mapcar #'cdr durations))))))
+       collect (reduce #'max durations :key #'car)
+       do (setf durations (remove nil (mapcar #'cdr durations))))))
 
 (defun average (list &key (key #'identity))
   (let ((sum 0)
@@ -68,14 +68,14 @@
 	      (incf time (* *tempo* (duration element)))))
 	  (elements bar)))
 
-(defun track-from-slice (slice channel durations)
-  (cons (make-instance 'program-change-message
-	  :time 0 :status  (+ #xc0 channel) :program 0)
-	(let ((time 0))
-	  (mapcan (lambda (bar duration)
-		    (prog1 (events-from-bar bar time channel)
-		      (incf time (* *tempo* duration))))
-		  (bars slice) durations))))
+(defun track-from-slice (slice channel durations &key (start-time 0))
+	(let ((time start-time))
+    (cons (make-instance 'program-change-message
+                         :time time :status  (+ #xc0 channel) :program 0)
+          (mapcan (lambda (bar duration)
+                    (prog1 (events-from-bar bar time channel)
+                      (incf time (* *tempo* duration))))
+                  (bars slice) durations))))
 
 (define-condition midi-player-failed (gsharp-condition)
   ((midi-player :initarg :midi-player)
@@ -115,20 +115,57 @@
     #-(or cmu sbcl clisp)
     (error "write compatibility layer for RUN-PROGRAM")))
 
-(defun play-segment (segment)
-  (let* ((slices (mapcar #'body (layers segment)))
-	 (durations (measure-durations slices))
-         (*tempo* (tempo segment))
-         (*tuning* (gsharp-buffer:tuning segment))
-	 (tracks (loop for slice in slices
-		       for i from 0
-		       collect (track-from-slice slice i durations))))
-    (play-tracks tracks)))
-
 (defun play-layer (layer)
   (let* ((slice (body layer))
-	 (durations (measure-durations (list slice)))
+         (durations (measure-durations (list slice)))
          (*tempo* (tempo (segment layer)))
          (*tuning* (gsharp-buffer:tuning (segment layer)))
-	 (tracks (list (track-from-slice slice 0 durations))))
-    (play-tracks tracks)))
\ No newline at end of file
+         (tracks (list (track-from-slice slice 0 durations))))
+    (play-tracks tracks)))
+
+(defun segment-tracks (segment &key (start-time 0))
+  (let* ((slices (mapcar #'body (layers segment)))
+         (durations (measure-durations slices))
+         (*tempo* (tempo segment))
+         (*tuning* (gsharp-buffer:tuning segment)))
+    (values (loop
+               for slice in slices
+               for i from 0
+               collect (track-from-slice slice i durations :start-time start-time))
+            (reduce #'+ durations))))
+  
+(defun play-segment (segment)
+  (play-tracks (segment-tracks segment)))
+
+; TODO: There is a short pause between segments?
+(defun play-buffer (buffer)
+  (let* ((time 0)
+         (num-tracks (loop :for segment :in (segments buffer)
+                           :maximize (length (layers segment))))
+         (tracks (loop :for i :from 0 :below num-tracks :collect nil)))
+
+    ; Collect snippets from each segment that should go to different tracks
+    (dolist (segment (segments buffer))
+      (let ((*tempo* (tempo segment))
+            (*tuning* (tuning segment)))
+        (multiple-value-bind (track-addendums segment-duration)
+            (segment-tracks segment :start-time time)
+          (format t "~S" segment-duration)
+
+          (incf time segment-duration)
+
+          (loop :for track-addendum :in track-addendums
+                :for tracks-tail :on tracks                
+                :do (push track-addendum (car tracks-tail))))))
+
+    ; Concatenate each track's snippets
+    (loop :for tracks-tail :on tracks
+       :do (setf (car tracks-tail)
+                 (reduce (lambda (result snippet)
+                           (nconc snippet result))
+                         (car tracks-tail)
+                         :from-end t))) 
+
+    (play-tracks tracks)))
+
+