Update of /project/fomus/cvsroot/fomus In directory common-lisp:/tmp/cvs-serv29848 Modified Files: accidentals.lisp backend_cmn.lisp backend_ly.lisp classes.lisp data.lisp main.lisp marks.lisp misc.lisp postproc.lisp staves.lisp version.lisp voices.lisp Log Message: more fixes Date: Wed Jan 18 18:02:35 2006 Author: dpsenicka Index: fomus/accidentals.lisp diff -u fomus/accidentals.lisp:1.13 fomus/accidentals.lisp:1.14 --- fomus/accidentals.lisp:1.13 Tue Nov 15 19:26:30 2005 +++ fomus/accidentals.lisp Wed Jan 18 18:02:35 2006 @@ -67,15 +67,15 @@ ;; numbers to determine importance of accidentals (declaim (type (real 1) *max-acc-beat-dist-mul*)) (defparameter *max-acc-beat-dist-mul* 2) ; number of beats of rest before not caring about interval spelling -(declaim (type #-openmcl (float 0 1) #+openmcl float *acc-dist-score*)) +(declaim (type #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float *acc-dist-score*)) (defparameter *acc-dist-score* (float 1/3)) -(declaim (type #-openmcl (float (0)) #+openmcl float *acc-beat-dist* *acc-octave-dist*)) +(declaim (type #-(or openmcl allegro) (float (0)) #+(or openmcl allegro) float *acc-beat-dist* *acc-octave-dist*)) (defparameter *acc-beat-dist* (float 3/2)) ; number of beats where beat distance score = acc-dist-score (defparameter *acc-octave-dist* (float 2)) ; number of octaves where octave distance score = acc-dist-score (default is 1.0 octaves = 2 beats = 2/3 of total score) ;; don't need to check if beat distance is past max -(declaim (type #-openmcl (float 0 1) #+openmcl float *acc-beat-dist-sc* *acc-octave-dist-sc*)) +(declaim (type #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float *acc-beat-dist-sc* *acc-octave-dist-sc*)) (declaim (special *acc-beat-dist-sc* *acc-octave-dist-sc*)) (defun nokey-notedist (tie note1 off1 eoff1 note2 off2 eoff2) (declare (type boolean tie) (type rational note1 note2) (type (real 0) off1 eoff1 off2 eoff2)) @@ -91,7 +91,8 @@ (defparameter +nokey-penalty+ (vector '(1) '(-1 1) '(-1) '(1) '(-1 1) '(-1 1) '(-1))) (defparameter +nokey-harmints+ (vector 0 1 1 2 2 3 4 4 5 5 6 6)) -(declaim (type #-openmcl (float 0 1) #+openmcl float *acc-diatonic-int-score* *acc-aug-dim-int-score* *acc-spelling-penalty* *acc-good-unison-score* *acc-bad-unison-score* *acc-similar-qtone-score*)) +(declaim (type #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float + *acc-diatonic-int-score* *acc-aug-dim-int-score* *acc-spelling-penalty* *acc-good-unison-score* *acc-bad-unison-score* *acc-similar-qtone-score*)) (defparameter *acc-diatonic-int-score* (float 7/8)) (defparameter *acc-aug-dim-int-score* (float 1/2)) (defparameter *acc-spelling-penalty* (float 1/4)) @@ -157,7 +158,7 @@ ;; depth-first search branching down only top score group (same scores) ;; DESTRUCTIVE (defstruct (nokeynode (:copier nil) (:predicate nokeynodep)) - (sc 0.0 :type (float 0)) + (sc 0.0 :type #-allegro (float 0) #+allegro float) (ret nil :type list) (re 0 :type (integer 0)) (evs nil :type list) @@ -170,7 +171,7 @@ (type (function (rational (or (integer -2 2) (cons (integer -2 2) (rational -1/2 1/2)))) (values (or (integer 0 6) null) (or integer null))) spellfun) (type (function (boolean rational (or (integer -2 2) (cons (integer -2 2) (rational -1/2 1/2))) (rational 0) (rational 0) rational (or (integer -2 2) (cons (integer -2 2) (rational -1/2 1/2))) (rational 0) (rational 0)) - #-openmcl (float 0 1) #+openmcl float) intscorefun) + #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float) intscorefun) (type (or string null) name) (type (function ((or (cons (integer -2 2) (rational -1/2 1/2)) (integer -2 2))) cons) conv)) (let ((co 0) (mxd (* *acc-beat-dist* *max-acc-beat-dist-mul*)) @@ -179,7 +180,7 @@ (flet ((scorefun (no) ; optimistic score (declare (type nokeynode no)) (cons (+ (nokeynode-sc no) - (loop for e of-type (cons #-openmcl (float 0 1) #+openmcl float *) in (nokeynode-evd no) sum (car e)) + (loop for e of-type (cons #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float *) in (nokeynode-evd no) sum (car e)) (nokeynode-re no)) ; unexplored accidentals all scores of 1 (nokeynode-co no))) (expandfun (no) @@ -205,14 +206,14 @@ (s (nokeynode-sc no))) (let ((d (cons w (or (loop ; keep only relevant notes that will need rescoring (endoff > - ? beats) - for e of-type (cons #-openmcl (float 0) #+openmcl float note) in (nokeynode-evd no) ; e is (score . event) + for e of-type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float note) in (nokeynode-evd no) ; e is (score . event) if (> (event-endoff (cdr e)) oo) ; endoff will = offset for grace notes! collect (cdr e) ; collect just the events else do (incf s (car e))) - (let ((mx (loop for e of-type (cons #-openmcl (float 0) #+openmcl float note) in (nokeynode-evd no) + (let ((mx (loop for e of-type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float note) in (nokeynode-evd no) maximize (event-endoff (cdr e))))) (setf s (nokeynode-sc no)) - (loop for e of-type (cons #-openmcl (float 0) #+openmcl float note) in (nokeynode-evd no) + (loop for e of-type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float note) in (nokeynode-evd no) if (>= (event-endoff (cdr e)) mx) collect (cdr e) else do (incf s (car e))))))) @@ -229,7 +230,7 @@ (let* ((eua (event-useracc e)) (ne (event-note* e)) (su (- 1.0 (funcall penfun ne eua))) (di 1.0)) - (declare (type #-openmcl (float 0) #+openmcl float su di)) + (declare (type #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float su di)) (loop ; plus optimistic 1 scores for rest in range for e0 of-type noteex in lf while (<= (event-off e0) (event-off e)) @@ -252,9 +253,9 @@ e)) :re (1- (nokeynode-re no)) :ret (cons w (nokeynode-ret no)) :evs lf))))) - (scoregreaterfun (s1 s2) (declare (type (cons #-openmcl (float 0) #+openmcl float *) s1 s2)) (> (car s1) (car s2))) + (scoregreaterfun (s1 s2) (declare (type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float *) s1 s2)) (> (car s1) (car s2))) (remscoregreaterfun (r1 r2) - (declare (type (cons #-openmcl (float 0) #+openmcl float (integer 0)) r1 r2)) + (declare (type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float (integer 0)) r1 r2)) (if (= (cdr r1) (cdr r2)) (< (car r1) (car r2)) (< (cdr r1) (cdr r2)))) (solutfun (no) (declare (type nokeynode no)) (null (nokeynode-evs no)))) (nokeynode-ret @@ -262,13 +263,13 @@ (*acc-engine-heap* (max (roundint (* *acc-engine-heap* *quality*)) 1)) (*acc-beat-dist-sc* (expt *acc-dist-score* (/ *acc-beat-dist*))) (*acc-octave-dist-sc* (expt *acc-dist-score* (/ *acc-octave-dist*)))) - (a*-engine (list (make-nokeynode :re (length events) :evs events)) ; should be sorted already - #'scorefun - #'expandfun - #'solutfun - :heaplim *acc-engine-heap* - :scoregreaterfun #'scoregreaterfun - :remscoregreaterfun #'remscoregreaterfun)) + (bfs*-engine (list (make-nokeynode :re (length events) :evs events)) ; should be sorted already + #'scorefun + #'expandfun + #'solutfun + :heaplim *acc-engine-heap* + :scoregreaterfun #'scoregreaterfun + :remscoregreaterfun #'remscoregreaterfun)) (error "Cannot find valid note spellings for part ~S" name)))))) ; return events sorted (declaim (type boolean *use-double-accs*)) @@ -405,8 +406,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; POST PROCESSING -;; (defparameter *acc-throughout-meas* t) - ;; rests are removed already, after chords & ties ;; events are events in 1 measure (defun acc-nokey-postaccs (events) Index: fomus/backend_cmn.lisp diff -u fomus/backend_cmn.lisp:1.2 fomus/backend_cmn.lisp:1.3 --- fomus/backend_cmn.lisp:1.2 Fri Nov 11 16:03:16 2005 +++ fomus/backend_cmn.lisp Wed Jan 18 18:02:35 2006 @@ -10,20 +10,105 @@ (defparameter +cmn-comment+ ";;; CMN score file~%;;; ~A v~A.~A.~A~%~%") +(defparameter +cmn-num-note+ (vector "C" nil "D" nil "E" "F" nil "G" nil "A" nil "B")) +(defparameter +cmn-num-acc+ (vector 'double-flat 'flat 'natural 'sharp 'double-sharp)) +(defparameter +cmn-num-accq+ (vector (vector nil 'double-flat) (vector 'flat-down 'flat 'natural-down) (vector 'natural-down 'natural 'natural-up) + (vector 'natural-up 'sharp 'sharp-up) (vector nil 'double-sharp))) + +(defparameter +cmn-barlines+ '((nil . bar) (:single . bar) (:double . interior-double-bar) (:final . double-bar) + (:repeatleft . end-repeat-bar) (:repeatright . begin-repeat-bar) (:repeatleftright . begin-and-end-repeat-bar) + (:invisible . (bar invisible)))) + (defun save-cmn (parts header filename options process view) ;; (unless *cmn-exists* ;; for viewing only ;; (format t ";; ERROR: Common Music Notation required for CMN output~%") ;; (return-from save-cmn)) + #| (declare (ignore process view)) (when (>= *verbose* 1) (out ";; Saving CMN file ~S...~%" filename)) (with-open-file (f filename :direction :output :if-exists :supersede) (destructuring-bind (&key score-attr &allow-other-keys) options (format f "~A" header) + (let ((de 0) (phash (make-hash-table :test 'eq))) + (flet ((cmnnote (wnum acc1 acc2 wdur hide caut harmt harms) + (let ((acc (unless hide (if *quartertones* (svref (svref +cmn-num-accq+ (+ acc1 2)) (1+ (* acc2 2))) (svref +cmn-num-acc+ (+ acc1 2)))))) + (when (and acc caut) (setf acc (list acc 'in-parentheses))) + (list 'note + (intern (conc-strings (svref +cmn-num-note+ (mod wnum 12)) + (case acc (flat "F") (natural "N") (sharp "S") (otherwise "")) + (format nil "~D" (truncate wnum 12)))) + (svref wdur + + + + (if *quartertones* + (conc-strings + (svref +cmn-num-note+ (mod wnum 12)) + (svref (svref +cmn-num-accq+ (+ acc1 2)) (1+ (* acc2 2))) + (svref +cmn-num-reg+ (1- (truncate wnum 12))) + (when caut "?")) + (conc-strings + (svref +cmn-num-note+ (mod wnum 12)) + (svref +cmn-num-acc+ (+ acc1 2)) + (svref +cmn-num-reg+ (1- (truncate wnum 12))) + (when caut "?")))) + (cmnname (p) + (incf de) + (intern + (conc-strings + (string-upcase + (conc-stringlist (loop for x across (part-name p) + when (alpha-char-p x) + collect (string x)))) + "-" + (string (code-char (+ 64 de))))))) + (let ((cmp (loop for p in parts nconc + (destructuring-bind (&key (cmn-partname (cmnname p)) &allow-other-keys) (part-opts p) + (loop with nvce = (loop for e in (part-meas p) maximize (length (meas-voices e))) + for v in voices and vi from 1 ... + for pna = (format nil "~A~D" cmn-partname vi) nconc + (loop with ns = (instr-staves (part-instr p)) + and o = 0 + for s in ns and si from 1 collect + (setf (maphash p phash) + `(,(if (> ns 1) (format nil "~A~D" pna si) pna0) + (staff + ,@(when (part-name p) (staff-name (part-name p))) + ,@(when (> ns 1) (tied-to (format nil "~A1" pna))) + ,@(loop for m in (part-meas p) nconc + (loop for e in (meas-events m) collect + (let ((nch (if (chordp e) + (loop + for (n nn) on (event-notes* e) + and w in (event-writtennotes e) + and a in (event-accs e) + and a2 in (event-addaccs e) + for ha = (getmark e (list :harmonic :touched n)) + and hs = (getmark e (list :harmonic :sounding n)) + collect (cmnnote w a a2 + (getmark e (list :cautacc n)) + (getmark e (list :harmonic :touched n)) + (getmark e (list :harmonic :sounding n)))) + (cmnnote (event-writtennote e) (event-acc e) (event-addacc e) + (getmark e (list :cautacc (event-note* e))) + (getmark e (list :harmonic :touched n)) + (getmark e (list :harmonic :sounding n)))))))) + collect (let ((b (getprop m :barline))) (lookup (second b) +cmn-barlines+)) + + + + (write `(cmn ,score-attr + (let , + + + + + ,@(labels ((pfn (pps &optional (grp 1)) - (loop for e = (pop pps) - for gr = (delete-if (lambda (x) (< (second x) grp)) (getprops e :startgroup)) + (loop for e = (pop pps) ; e = part + for gr = (delete-if (lambda (x) (< (second x) grp)) (getprops e :startgroup)) if gr nconc (let* ((gl (second (first (sort gr #'< :key #'second)))) (ps (pfn (loop for i = e then (pop pps) collect i until (getprop e (list :endgroup gl))) (1+ gl)))) (ecase (third gr) @@ -33,4 +118,4 @@ (loop )))) (pfn parts))) :stream f - :escape nil)))) \ No newline at end of file + :escape nil)))|#) \ No newline at end of file Index: fomus/backend_ly.lisp diff -u fomus/backend_ly.lisp:1.21 fomus/backend_ly.lisp:1.22 --- fomus/backend_ly.lisp:1.21 Sat Nov 12 14:42:46 2005 +++ fomus/backend_ly.lisp Wed Jan 18 18:02:35 2006 @@ -13,6 +13,12 @@ #+sbcl (eval-when (:compile-toplevel :load-toplevel :execute) (require :sb-posix)) +#+allegro +(defun run-allegro-cmd (cmd) + (multiple-value-bind (ostr istr p) (excl:run-shell-command cmd :input :stream :output :stream :error-output :stream :wait nil) + (sys:os-wait nil p) + ostr)) + #+(or linux darwin unix) (defun find-exe (filename) (namestring* @@ -43,31 +49,51 @@ (flet ((er (str) (format t ";; ERROR: Error ~A lilypond file~%" str) (return-from view-lilypond))) - #+(and (or cmu sbcl openmcl) (or linux darwin unix)) + #+(and (or cmu sbcl openmcl allegro) (or linux darwin unix)) (progn (ignore-errors (delete-file (change-filename filename :ext (or out-ext +lilypond-out-ext+)))) - (#+cmu unix:unix-chdir #+sbcl sb-posix:chdir #+openmcl ccl:cwd (change-filename filename :name nil :ext nil)) - (if (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program (or exe +lilypond-exe+) - (append (or exe-opts +lilypond-opts+) (list filename)) :wait t #|:output *standard-output*|#) + (#+cmu unix:unix-chdir #+sbcl sb-posix:chdir #+openmcl ccl:cwd #+allegro excl:chdir + (change-filename filename :name nil :ext nil)) + (if #+(or cmu sbcl openmcl) (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program + (or exe +lilypond-exe+) + (append (or exe-opts +lilypond-opts+) (list filename)) + :wait t) + #+allegro (= (run-allegro-cmd (apply #'vector (cons (or exe +lilypond-exe+) + (cons (or exe +lilypond-exe+) + (append (or exe-opts +lilypond-opts+) (list filename)))))) 0) (progn (unless (probe-file (change-filename filename :ext (or out-ext +lilypond-out-ext+))) (er "compiling")) + (ignore-errors (delete-file (change-filename filename :ext "log"))) + (unless (string= (or out-ext +lilypond-out-ext+) "tex") (ignore-errors (delete-file (change-filename filename :ext "tex")))) + (unless (string= (or out-ext +lilypond-out-ext+) "dvi") (ignore-errors (delete-file (change-filename filename :ext "dvi")))) + (unless (string= (or out-ext +lilypond-out-ext+) "ps") (ignore-errors (delete-file (change-filename filename :ext "ps")))) + (unless (string= (or out-ext +lilypond-out-ext+) "pdf") (ignore-errors (delete-file (change-filename filename :ext "pdf")))) (when view - (unless (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program (or view-exe +lilypond-view-exe+) - (append (or view-exe-opts +lilypond-view-opts+) (list (change-filename filename :ext (or out-ext +lilypond-out-ext+)))) - :wait nil #|:output *standard-output*|#) - (er "viewing")))) + (unless #+(or cmu sbcl openmcl) (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program + (or view-exe +lilypond-view-exe+) + (append (or view-exe-opts +lilypond-view-opts+) + (list (change-filename filename :ext (or out-ext +lilypond-out-ext+)))) + :wait nil) + #+allegro (= (run-allegro-cmd + (apply #'vector (cons (or view-exe +lilypond-view-exe+) + (cons (or view-exe +lilypond-view-exe+) + (append (or view-exe-opts +lilypond-view-opts+) + (list (change-filename filename :ext (or out-ext +lilypond-out-ext+)))))))) 0) + (er "viewing")))) (er "compiling"))) - #-(and (or cmu sbcl openmcl) (or linux darwin unix)) (format t ";; ERROR: Don't know how to compile/view lilypond file~%")))) + #-(and (or cmu sbcl openmcl allegro) (or linux darwin unix)) (format t ";; ERROR: Don't know how to compile/view lilypond file~%")))) (defparameter *lilypond-version* t) (defun lilypond-version (options) (if (truep *lilypond-version*) (setf *lilypond-version* (destructuring-bind (&key exe &allow-other-keys) options - (let ((os (make-string-output-stream))) - (ignore-errors (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program (or exe +lilypond-exe+) - (list "-v") :wait t :output os)) - (let* ((out (get-output-stream-string os)) + (let ((os #+(or cmu sbcl openmcl) (make-string-output-stream) + #+allegro (ignore-errors (run-allegro-cmd (vector (or exe +lilypond-exe+) (or exe +lilypond-exe+) "-v"))))) + #+(or cmu sbcl openmcl) (ignore-errors (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program + (or exe +lilypond-exe+) + (list "-v") :wait t :output os)) + (let* ((out #+(or cmu sbcl openmcl) (get-output-stream-string os) #+allegro (read-line os)) (p (search "LilyPond " out))) (when p (multiple-value-bind (n1 np) (parse-integer out :start (+ p 9) :junk-allowed t) (+ (* n1 100) (parse-integer out :start (1+ np) :junk-allowed t)))))))) @@ -106,14 +132,6 @@ (defparameter +lilypond-num-reg+ (vector ",,," ",," "," "" "'" "''" "'''" "''''" "'''''")) (defparameter +lilypond-barlines+ '((:single . "|") (:double . "||") (:final . "|.") (:repeatleft . ":|") (:repeatright . "|:") (:repeatleftright . ":|:") (:invisible . ""))) -;; sets and overrides -;;(defparameter +lilypond-set-acc-style-default+ "#(set-accidental-style 'default)") -;;(defparameter +lilypond-set-acc-style-forget+ "#(set-accidental-style 'forget)") -;;(defparameter +lilypond-set-timesig-style-frac+ "\\override Staff.TimeSignature #'style = #'()") -;;(defparameter +lilypond-set-tup-style-ratio+ "\\set tupletNumberFormatFunction = #fraction-tuplet-formatter") -;;(defparameter +lilypond-set-instrument+ "\\set Staff.instrument = ~S") -;;(defparameter +lilypond-set-instr+ "\\set Staff.instr = ~S") - (defparameter +lilypond-marks+ '((:accent . "->") (:marcato . "-^") (:staccatissimo . "-|") (:staccato . "-.") (:tenuto . "--") (:portato . "-_") (:upbow . "\\upbow") (:downbow . "\\downbow") (:thumb . "\\thumb") (:leftheel . "\\lheel") (:rightheel . "\\rheel") (:lefttoe . "\\ltoe") (:righttoe . "\\rtoe") (:open . "\\open") @@ -168,12 +186,12 @@ (conc-strings (svref +lilypond-num-note+ (mod wnum 12)) (svref (svref +lilypond-num-accq+ (+ acc1 2)) (1+ (* acc2 2))) - (svref +lilypond-num-reg+ (1- (truncate wnum 12))) #|(when force "!")|# + (svref +lilypond-num-reg+ (1- (truncate wnum 12))) (when caut "?")) (conc-strings (svref +lilypond-num-note+ (mod wnum 12)) (svref +lilypond-num-acc+ (+ acc1 2)) - (svref +lilypond-num-reg+ (1- (truncate wnum 12))) #|(when force "!")|# + (svref +lilypond-num-reg+ (1- (truncate wnum 12))) (when caut "?")))) (lyname (p) (incf de) @@ -198,7 +216,7 @@ (when (or (null *timesig-style*) (eq *timesig-style* :fraction)) (if (> ns 1) (loop for s from 1 to ns do - (format f " ~A\\override Staff.TimeSignature #'style = #'()~%" (format nil "\\change Staff = ~A " (code-char (+ 64 s))) #|(lystaff s)|#)) + (format f " ~A\\override Staff.TimeSignature #'style = #'()~%" (format nil "\\change Staff = ~A " (code-char (+ 64 s))))) (format f " \\override Staff.TimeSignature #'style = #'()~%"))) (when (eq *tuplet-style* :ratio) (format f " \\set tupletNumberFormatFunction = #fraction-tuplet-formatter~%")) (format f " \\autoBeamOff~%") @@ -207,7 +225,7 @@ (format f " #(set-accidental-style 'forget)~%")) (if (> ns 1) (loop for (xxx cl s) in (sort (getprops p :clef) #'< :key #'third) do - (format f " ~A\\clef ~A~%" (format nil "\\change Staff = ~A " (code-char (+ 64 s))) #|(lystaff s)|# (lyclef cl))) + (format f " ~A\\clef ~A~%" (format nil "\\change Staff = ~A " (code-char (+ 64 s))) (lyclef cl))) (format f " \\clef ~A~%" (lyclef (second (getprop p :clef))))) (loop for e in lily-parthead do (format f " ~A~%" e)) (format f "~%") @@ -228,20 +246,17 @@ (when (getmark e '(:starttext- 2)) (setf twrn t)) (format f "~A " (conc-strings -;; (if (list>1p (meas-events m)) - (let ((m (getmark e '(:voice :ord1324)))) - (if (and m (null (fourth m))) - (case (third m) - (1 (setf cdi :u) "\\voiceOne ") - (2 (setf cdi :d) "\\voiceTwo ") - (3 (setf cdi :u) "\\voiceThree ") - (4 (setf cdi :d) "\\voiceFour ") - (otherwise (setf cdi :u) "\\oneVoice ")) - "")) -;; "") + (let ((m (getmark e '(:voice :ord1324)))) + (if (and m (null (fourth m))) + (case (third m) + (1 (setf cdi :u) "\\voiceOne ") + (2 (setf cdi :d) "\\voiceTwo ") + (3 (setf cdi :u) "\\voiceThree ") + (4 (setf cdi :d) "\\voiceFour ") + (otherwise (setf cdi :u) "\\oneVoice ")) + "")) (let ((m (getmark e '(:staff :voice)))) - (if (and m (> ns 1) (null (fourth m))) (format nil "\\change Staff = ~A " (code-char (+ 64 (third m) #|(setf sa s)|#))) - #|(print (lystaff (third m)))|# "")) + (if (and m (> ns 1) (null (fourth m))) (format nil "\\change Staff = ~A " (code-char (+ 64 (third m)))) "")) (let ((c (getmark e :clef))) (if (and c (null (fourth c))) (format nil "\\clef ~A " (lyclef (second c))) "")) @@ -255,9 +270,10 @@ collect (format nil "\\times ~A/~A {" (cdr r) (car r))))) (let ((g (event-grace e))) (if g - (let ((g1 (getmark e :startgrace))) - (cond ((and g1 (getmark e :endgrace)) (if (< g 0) "\\acciaccatura " "\\appoggiatura ")) - (g1 (if (< g 0) "\\acciaccatura {" "\\appoggiatura {")))) + (let ((g1 (getmark e :startgrace)) + (gs (getmark e :startgraceslur-))) + (cond ((and g1 (getmark e :endgrace)) (if gs (if (< g 0) "\\acciaccatura " "\\appoggiatura ") "\\grace ")) + (g1 (if gs (if (< g 0) "\\acciaccatura {" "\\appoggiatura {") "\\grace {")))) "")) (cond ((and (getmark e :startwedge<) (getmark e :endwedge<)) "\\< ") ((and (getmark e :startwedge>) (getmark e :endwedge>)) "\\> ") @@ -299,7 +315,7 @@ (lynote (event-writtennote e) (event-acc e) (event-addacc e) (getmark e (list :cautacc (event-note* e)))) (let ((ha (getmark e :harmonic))) - (when ha (ecase (second ha) (:harmonic "\\harmonic") (:touched "^\\flageolet")))))) + (when ha (ecase (second ha) (:touched "\\harmonic") (:sounding "^\\flageolet")))))) (if fm (if (event-inv e) "\\skip " "R") (if (event-inv e) "s" "r"))) (if fm (format nil "1*~A/~A" (timesig-num ts) (timesig-den ts)) (multiple-value-bind (wd ds) (let ((m (or (getmark e :tremolo) Index: fomus/classes.lisp diff -u fomus/classes.lisp:1.14 fomus/classes.lisp:1.15 --- fomus/classes.lisp:1.14 Fri Nov 11 16:49:35 2005 +++ fomus/classes.lisp Wed Jan 18 18:02:35 2006 @@ -44,7 +44,11 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (sb-ext:with-unlocked-packages ("COMMON-LISP") (defclass rest (dur-base) ()))) ; only w/ xml in special cases--must not overlap a note-event!!! -#-sbcl +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (excl:without-package-locks + (defclass rest (dur-base) ()))) +#-(or sbcl allegro) (defclass rest (dur-base) ()) ; only w/ xml in special cases--must not overlap a note-event!!! (defclass part (fomusobj-base) @@ -67,7 +71,10 @@ (defprint timesig id (partid :partids) off time comp beat div repl props) (defprint mark id partid off voice marks) (defprint note id partid voice off dur note marks) -(defprint rest id partid voice off dur marks) +#+allegro (eval-when (:compile-toplevel :load-toplevel :execute) + (excl:without-package-locks + (defprint rest id partid voice off dur marks))) +#-allegro (defprint rest id partid voice off dur marks) (defprint part id partid name abbrev instr events opts) (defprint meas id off endoff timesig div events props) Index: fomus/data.lisp diff -u fomus/data.lisp:1.27 fomus/data.lisp:1.28 --- fomus/data.lisp:1.27 Sat Nov 12 14:42:46 2005 +++ fomus/data.lisp Wed Jan 18 18:02:35 2006 @@ -135,9 +135,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; INSTRUMENTS -(declaim (type list *percussion*)) -(defparameter *percussion* nil) - (defstruct (perc (:constructor make-perc-aux) (:copier nil) (:predicate percp)) (sym nil :type (or symbol real)) (staff 1 :type (integer 1)) Index: fomus/main.lisp diff -u fomus/main.lisp:1.19 fomus/main.lisp:1.20 --- fomus/main.lisp:1.19 Sat Nov 12 14:42:46 2005 +++ fomus/main.lisp Wed Jan 18 18:02:35 2006 @@ -205,10 +205,3 @@ r (rest xx) (or process view) play view))))) t) -;; #+allegro (excl:current-directory) -;; #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory) -;; #+(or cmu scl) (ext:default-directory) -;; #+sbcl (sb-unix:posix-getcwd/) -;; #+cormanlisp (ccl:get-current-directory) -;; #+lispworks (hcl:get-working-directory) -;; #+mcl (ccl:mac-default-directory) Index: fomus/marks.lisp diff -u fomus/marks.lisp:1.12 fomus/marks.lisp:1.13 --- fomus/marks.lisp:1.12 Sat Oct 22 15:43:06 2005 +++ fomus/marks.lisp Wed Jan 18 18:02:35 2006 @@ -48,7 +48,7 @@ ;; input level number only needs to be relative, with lower numbers = inner voices--mark arguments are mod then level ;; output level numbering starts at 1 (conforming to majority of output formats) ;; lower level is more inner -;; this will translate the user input format to a more rigid format for the backends +;; translate the user input format to a more well-defined format for the backends (defun clean-spanners (pts spanners) (loop for (startsym contsym endsym) of-type (symbol symbol symbol) in spanners do (loop for p of-type partex in pts do Index: fomus/misc.lisp diff -u fomus/misc.lisp:1.12 fomus/misc.lisp:1.13 --- fomus/misc.lisp:1.12 Wed Nov 30 17:51:37 2005 +++ fomus/misc.lisp Wed Jan 18 18:02:35 2006 @@ -135,6 +135,8 @@ (loop for e in initial-contents do (heap-ins e hp)) hp)) + + (declaim (inline list>1p list1p)) (defun list>1p (list) (declare (type list list)) @@ -309,10 +311,10 @@ data score (val t :type boolean)) ; val = valid ;; (defconstant +a*-purgeat+ 1000) -;; not necessarily used as A* algorithm +;; BFS algorithm w/ limited heap ;; scorefun must always return optimistic value! (larger is better)--may return two values (second is remscore) ;; if heaplim = a number, limits heap size (ceases to be optimal) -(defun a*-engine (init-nodes scorefun expandfun solutfun &key heaplim (scoregreaterfun #'>) (remscoregreaterfun #'<) retdefault) +(defun bfs*-engine (init-nodes scorefun expandfun solutfun &key heaplim (scoregreaterfun #'>) (remscoregreaterfun #'<) retdefault) (declare (type (function (t) t) scorefun solutfun) (type (function (t) list) expandfun) (type (or null (integer 0)) heaplim) (type (function (t t) t) scoregreaterfun remscoregreaterfun)) (let ((*a*-id* -1) Index: fomus/postproc.lisp diff -u fomus/postproc.lisp:1.16 fomus/postproc.lisp:1.17 --- fomus/postproc.lisp:1.16 Sat Jan 7 20:58:43 2006 +++ fomus/postproc.lisp Wed Jan 18 18:02:35 2006 @@ -335,10 +335,11 @@ (setf fx t) (car x)) e))) - (let ((sy (first ma))) ; number of divisions, written durational value of tremolo marking + (let ((sy (first ma)) + (dv (min (/ 1/8 w) (1+ (event-nbeams re (meas-timesig m)))))) ; number of divisions, written durational value of tremolo marking (declare (type symbol sy)) (if (or (not (chordp re)) (eq sy :tremolo)) - (progn (push re ee) (addmark re (list :tremolo d w))) + (progn (push re ee) (addmark re (list :tremolo (/ d dv) (* w dv)))) (loop for n0 of-type rational in (event-notes* re) and nn of-type (cons rational (or (integer -2 2) (cons (integer -2 2) (rational -1/2 1/2)))) in (event-note re) and lt of-type boolean in (event-tielt re) @@ -370,7 +371,7 @@ (push e1 ee) (push e2 ee) (setf fx t) (addmark e1 (list :starttremolo (/ d 2) w)) (addmark e2 (list :endtremolo (/ d 2) w)))) - (progn (push re ee) (addmark re (list :tremolo d w))))))))))) + (progn (push re ee) (addmark re (list :tremolo (/ d dv) (* w dv)))))))))))) (push e ee))) finally (setf (meas-events m) (sort ee #'sort-offdur)))) (loop for g of-type cons in (split-into-groups (loop for x of-type meas in (part-meas p) append (meas-events x)) #'event-voice*) do Index: fomus/staves.lisp diff -u fomus/staves.lisp:1.10 fomus/staves.lisp:1.11 --- fomus/staves.lisp:1.10 Tue Sep 13 16:39:14 2005 +++ fomus/staves.lisp Wed Jan 18 18:02:35 2006 @@ -22,7 +22,7 @@ (declaim (type (real 0) *clef-force-clef-change-dist*)) (defparameter *clef-force-clef-change-dist* 2) ; can be nil -(declaim (type (float 0 1) *clef-change-clef-penalty* *clef-change-staff-penalty* *clef-polyphony-perbeat-penalty* *clef-order-perbeat-penalty*)) +(declaim (type #-allegro (float 0 1) #+allegro float *clef-change-clef-penalty* *clef-change-staff-penalty* *clef-polyphony-perbeat-penalty* *clef-order-perbeat-penalty*)) (defparameter *clef-change-clef-penalty* (float 1)) (defparameter *clef-change-staff-penalty* (float 1/4)) ; should probably be less than change-clef-penalty @@ -55,7 +55,7 @@ (defparameter *staff-engine-heap* 50) (defstruct (clefnode (:copier nil) (:predicate clefnodep)) - (sc 0.0 :type (float 0)) + (sc 0.0 :type #-allegro (float 0) #+allegro float) (lo 0 :type (rational 0)) (lg 0 :type (rational 0)) (ics #() :type (vector symbol)) @@ -161,9 +161,9 @@ *clef-order-perbeat-penalty*)) (max (- o (clefnode-lo no)) (clefnode-lg no)))) (return (make-clefnode :sc sc :lo o :lg gd :ics ics :cs cs :lvs lvs :ret (nconc ret (clefnode-ret no)) :evs rs :o o :co nco))))))) ; ret is out of order - (scoregreaterfun (s1 s2) (declare (type (cons #-openmcl (float 0) #+openmcl float *) s1 s2)) (< (car s1) (car s2))) + (scoregreaterfun (s1 s2) (declare (type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float *) s1 s2)) (< (car s1) (car s2))) (remscoregreaterfun (r1 r2) - (declare (type (cons #-openmcl (float 0) #+openmcl float (integer 0)) r1 r2)) + (declare (type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float (integer 0)) r1 r2)) (if (= (cdr r1) (cdr r2)) (> (car r1) (car r2)) (< (cdr r1) (cdr r2)))) (solutfun (no) (declare (type clefnode no)) (null (clefnode-evs no)))) (let ((*clef-list* (force-list (instr-clefs instr)))) @@ -199,7 +199,7 @@ (cddr (last-element re)) nil) (return (values r re))) (let ((n (or (let ((*staff-engine-heap* (max (roundint (* *staff-engine-heap* *quality*)) 1))) - (a*-engine (list (make-clefnode :ics (make-array nst :initial-element nil) + (bfs*-engine (list (make-clefnode :ics (make-array nst :initial-element nil) :cs (make-array nst :initial-element nil) :lvs (make-array nst :initial-element nil) :evs events)) Index: fomus/version.lisp diff -u fomus/version.lisp:1.23 fomus/version.lisp:1.24 --- fomus/version.lisp:1.23 Sat Jan 7 20:58:43 2006 +++ fomus/version.lisp Wed Jan 18 18:02:35 2006 @@ -12,9 +12,9 @@ (declaim (type string +title+) (type cons +version+ +banner+)) (defparameter +title+ "FOMUS") -(defparameter +version+ '(0 1 28)) +(defparameter +version+ '(0 1 29)) (defparameter +banner+ `("Lisp music notation formatter" - "Copyright (c) 2005 David Psenicka, All Rights Reserved" + "Copyright (c) 2005, 2006 David Psenicka, All Rights Reserved" "See file \"COPYING\" for terms of use and distribution.")) Index: fomus/voices.lisp diff -u fomus/voices.lisp:1.10 fomus/voices.lisp:1.11 --- fomus/voices.lisp:1.10 Wed Aug 31 16:18:00 2005 +++ fomus/voices.lisp Wed Jan 18 18:02:35 2006 @@ -13,19 +13,20 @@ ;; user specifies a list of voices for voice parameter ;; algorithm decides which one to choose -(declaim (type #-openmcl (float 0 1) #+openmcl float *voice-high/low-penalty* *voice-simult-penalty* *voice-chord-score* *voice-leading-penalty* *voice-balance-penalty*)) +(declaim (type #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float + *voice-high/low-penalty* *voice-simult-penalty* *voice-chord-score* *voice-leading-penalty* *voice-balance-penalty*)) (defparameter *voice-high/low-penalty* (float 1/3)) ; voice 1 is higher than voice 2 (defparameter *voice-simult-penalty* (float 1)) ; vertical chords are balanced between voices (defparameter *voice-chord-score* (float 1/12)) ; incentive to group notes of same offset/dur into same voice (defparameter *voice-leading-penalty* (float 1/4)) ; close-together notes are in same voice (defparameter *voice-balance-penalty* (float 1/24)) ; notes are balanced/switched between voices over time -(declaim (type #-openmcl (float 0 1) #+openmcl float *voice-dist-score*)) +(declaim (type #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float *voice-dist-score*)) (defparameter *voice-dist-score* (float 1/3)) -(declaim (type #-openmcl (float 0) #+openmcl float *voice-octave-dist*)) +(declaim (type #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float *voice-octave-dist*)) (defparameter *voice-octave-dist* (float 1)) -(declaim (type #-openmcl (float 0) #+openmcl float *voice-high/low-beat-dist* *voice-leading-beat-dist* *voice-balance-beat-dist*)) +(declaim (type #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float *voice-high/low-beat-dist* *voice-leading-beat-dist* *voice-balance-beat-dist*)) (defparameter *voice-high/low-beat-dist* (float 1/2)) (defparameter *voice-leading-beat-dist* (float 4)) (defparameter *voice-balance-beat-dist* (float 12)) ; effectively the "distance" for maintaining balance between voices @@ -41,15 +42,16 @@ (declaim (inline auto-voices-fun)) (defun auto-voices-fun () (if (truep *auto-voices-mod*) :voices1 *auto-voices-mod*)) -(declaim (type #-openmcl (float 0 1) #+openmcl float *voice-high/low-beat-dist-sc* *voice-leading-beat-dist-sc* *voice-octave-dist-sc* *voice-full-beat-dist-sc*) - (type #-openmcl (float 0) #+openmcl float *voice-full-beat-dist*)) +(declaim (type #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float + *voice-high/low-beat-dist-sc* *voice-leading-beat-dist-sc* *voice-octave-dist-sc* *voice-full-beat-dist-sc*) + (type #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float *voice-full-beat-dist*)) (declaim (special *voice-high/low-beat-dist-sc* *voice-leading-beat-dist-sc* *voice-octave-dist-sc* *voice-full-beat-dist* *voice-full-beat-dist-sc*)) ; adj is 1 + lowest (farthest) value (defun voices-notedist-aux1 (note1 note2) ; by octave (declare (type rational note1 note2)) (expt *voice-octave-dist-sc* (/ (diff note1 note2) 12.0))) (defun voices-notedist-aux2 (off1 eoff1 off2 eoff2 beatdist sc) ; by offset - (declare (type (rational 0) off1 eoff1 off2 eoff2) (type (real 0) beatdist) (type #-openmcl (float 0 1) #+openmcl float sc)) + (declare (type (rational 0) off1 eoff1 off2 eoff2) (type (real 0) beatdist) (type #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float sc)) (let ((d (max (- (float off2) (float eoff1)) (- (float off1) (float eoff2)) 0.0))) (if (>= d (* *max-voice-beat-dist-mul* beatdist)) 0.0 (expt sc d)))) @@ -88,7 +90,7 @@ (defparameter *voice-engine-heap* 50) (defstruct (voicenode (:copier nil) (:predicate voicenodep)) - (sc 0.0 :type (float 0)) + (sc 0.0 :type #-allegro (float 0) #+allegro float) (ret nil :type list) (evs nil :type list) (evc nil :type list) @@ -102,7 +104,7 @@ (flet ((scorefun (no) (declare (type voicenode no)) (cons (+ (voicenode-sc no) - (loop for e of-type (cons #-openmcl (float 0 1) #+openmcl float *) in (voicenode-evd no) sum (car e))) + (loop for e of-type (cons #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float *) in (voicenode-evd no) sum (car e))) (voicenode-co no))) (expandfun (no) (declare (type voicenode no)) @@ -124,7 +126,7 @@ (s (voicenode-sc no))) (let ((d (cons w (loop ; keep only relevant notes that will need rescoring (endoff > - 8 beats) - for e of-type (cons #-openmcl (float 0 1) #+openmcl float note) in (voicenode-evd no) ; e is (score . event) + for e of-type (cons #-(or openmcl allegro) (float 0 1) #+(or openmcl allegro) float note) in (voicenode-evd no) ; e is (score . event) if (>= (event-off (cdr e)) oo) ; endoff will = offset for grace notes! collect (cdr e) ; collect just the events else do (incf s (car e))))) @@ -140,7 +142,8 @@ for e of-type noteex in d collect (cons (loop - with su of-type #-openmcl (float 0) #+openmcl float = 0.0 and di of-type #-openmcl (float 0) #+openmcl float = 0.0 + with su of-type #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float = 0.0 + and di of-type #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float = 0.0 for e0 of-type noteex in c unless (eq e e0) do (let ((d0 (voices-notedist (event-note* e) (event-off e) (event-endoff e) @@ -154,9 +157,9 @@ :ret (cons w (voicenode-ret no)) :evs lf :co nco)))) when xx collect xx))) - (scoregreaterfun (s1 s2) (declare (type (cons #-openmcl (float 0) #+openmcl float *) s1 s2)) (< (car s1) (car s2))) + (scoregreaterfun (s1 s2) (declare (type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float *) s1 s2)) (< (car s1) (car s2))) (remscoregreaterfun (r1 r2) - (declare (type (cons #-openmcl (float 0) #+openmcl float (integer 0)) r1 r2)) + (declare (type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float (integer 0)) r1 r2)) (if (= (cdr r1) (cdr r2)) (> (car r1) (car r2)) (< (cdr r1) (cdr r2)))) (solutfun (no) (declare (type voicenode no)) (null (voicenode-evs no)))) (voicenode-ret @@ -167,7 +170,7 @@ (*voice-leading-beat-dist-sc* (expt *voice-dist-score* (/ *voice-leading-beat-dist*))) (*voice-full-beat-dist-sc* (expt *voice-dist-score* (/ *voice-full-beat-dist*))) (*voice-octave-dist-sc* (expt *voice-dist-score* (/ *voice-octave-dist*)))) - (a*-engine (list (make-voicenode :evs events)) + (bfs*-engine (list (make-voicenode :evs events)) #'scorefun #'expandfun #'solutfun