[fomus-cvs] CVS update: fomus/accidentals.lisp fomus/backend_cmn.lisp fomus/backend_ly.lisp fomus/classes.lisp fomus/data.lisp fomus/main.lisp fomus/marks.lisp fomus/misc.lisp fomus/postproc.lisp fomus/staves.lisp fomus/version.lisp fomus/voices.lisp
David Psenicka
dpsenicka at common-lisp.net
Thu Jan 19 00:02:36 UTC 2006
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
More information about the Fomus-cvs
mailing list