;; -*- lisp -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;**************************************************************************************************
;; FOMUS
;; backend_ly.lisp
;;**************************************************************************************************

(in-package :fomus)
(compile-settings)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; LILYPOND VIEWER

#+sbcl (eval-when (:compile-toplevel :load-toplevel :execute) (require :sb-posix))

(eval-when (:load-toplevel :execute)
  (defparameter *lilypond-exe*
    (or #+darwin (find-exe "lilypond" "LilyPond.app/Contents/Resources/bin")
	#+darwin (find-exe "lilypond.sh" "LilyPond.app")
	#+(or mswindows win32) (find-exe "lilypond.exe" "LilyPond")
	#-(or mswindows win32) (find-exe "lilypond" "LilyPond") 
	#+darwin "lilypond.sh"
	#+(or mswindows win32) "lilypond.exe"
	#-(or mswindows win32) "lilypond"))
  (defparameter *lilypond-view-exe* #-(or mswindows win32) +ghostview-exe+ #+(or mswindows win32) +acroread-exe+))

(defparameter *lilypond-opts* #-(or darwin mswindows win32) '("--ps") #+(or darwin mswindows win32) '("--pdf"))
(defparameter *lilypond-out-ext* #-(or darwin mswindows win32) "ps" #+(or darwin mswindows win32) "pdf")
(defparameter *lilypond-view-opts* #-darwin nil #+darwin '("/Applications/Preview.app"))

(defun view-lilypond (filename options view)
  (when (>= *verbose* 1) (out (if view ";; Compiling/opening ~S for viewing...~%" ";; Compiling ~S...~%") filename))
  (destructuring-bind (&key exe view-exe opts view-opts out-ext &allow-other-keys) options
    (flet ((er (str)
	     (format t ";; ERROR: Error ~A LilyPond file~%" str)
	     (return-from view-lilypond)))
      (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 #+allegro excl:chdir #+lispworks hcl:change-directory #+clisp ext:cd
	     (change-filename filename :name nil :ext nil))
      (if #+(or cmu sbcl openmcl) (ignore-errors
				    (#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program
					   (or exe *lilypond-exe*)
					   (append (or opts *lilypond-opts*) (list filename))
					   :wait t))
	  #+clisp (eql (ignore-errors
			 (ext:run-program
			  (or exe *lilypond-exe*)
			  :arguments (append (or opts *lilypond-opts*) (list filename))
			  :output nil
			  :wait t))
		       0)
	  #+lispworks (ignore-errors
			(system:call-system (format nil "~A~{ ~A~}" 
						    (or exe *lilypond-exe*)
						    (append (or opts *lilypond-opts*) (list filename))
						    :wait t)))
	  #+allegro (eql (run-allegro-cmd (apply #'vector (cons (or exe *lilypond-exe*)
								(cons (or exe *lilypond-exe*)
								      (append (or 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 #+(or cmu sbcl openmcl) (ignore-errors
						(#+cmu extensions:run-program #+sbcl sb-ext:run-program #+openmcl ccl:run-program
						       (or view-exe *lilypond-view-exe*)
						       (append (or view-opts *lilypond-view-opts*)
							       (list (change-filename filename :ext (or out-ext *lilypond-out-ext*))))
						       :wait nil))
		      #+clisp (eql (ignore-errors
				     (ext:run-program
				      (or view-exe *lilypond-view-exe*)
				      :arguments (append (or view-opts *lilypond-view-opts*)
							 (list (change-filename filename :ext (or out-ext *lilypond-out-ext*))))
				      :output nil
				      :wait nil))
				   0)
		      #+lispworks (ignore-errors
				    (system:call-system (format nil "~A~{ ~A~}" 
								(or view-exe *lilypond-view-exe*)
								(append (or view-opts *lilypond-view-opts*)
									(list (change-filename filename :ext (or out-ext *lilypond-out-ext*))))
								:wait nil)))
		      #+allegro (eql (run-allegro-cmd
				      (apply #'vector (cons (or view-exe *lilypond-view-exe*)
							    (cons (or view-exe *lilypond-view-exe*)
								  (append (or view-opts *lilypond-view-opts*)
									  (list (change-filename filename :ext (or out-ext *lilypond-out-ext*))))))) nil nil)
				     0)
		      (er "viewing"))))
	  (er "compiling")))))

(defparameter *lilypond-version* nil)
(defparameter *lilyvers* t)
(defun lilypond-version (options usrv)
  (let ((v (or usrv *lilypond-version*)))
    (if v
	(let ((ve (ignore-errors
		    (+ (* 100 (parse-integer v :junk-allowed t))
		       (parse-integer v :start (1+ (position #\. v)) :junk-allowed t)))))
	  (if (and (>= ve 204) (<= ve 209)) ve
	      (progn (format t ";; WARNING: Unknown LilyPond version--assuming version 2.8~%") 208)))
	(if (truep *lilyvers*)
	    (setf *lilyvers*
		  (destructuring-bind (&key exe &allow-other-keys) options
		    (flet ((er () (format t ";; WARNING: Can't determine LilyPond version--assuming version 2.8~%") 208))
		      (let ((os #+(or cmu sbcl openmcl lispworks) (make-string-output-stream)
				#+allegro (nth-value 1 (run-allegro-cmd (vector (or exe *lilypond-exe*) (or exe *lilypond-exe*) "-v")))
				#+clisp (ignore-errors
					  (ext:run-program
					   (or exe *lilypond-exe*)
					   :arguments (list "-v") :wait t :output :stream))))
			#+(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))
			#+lispworks (ignore-errors
				      (system:call-system-showing-output
				       (format nil "~A~{ ~A~}"
					       (or exe *lilypond-exe*)
					       (list "-v"))
				       :prefix "" :show-cmd nil
				       :output-stream os
				       :wait t))
			(if os
			    (let* ((out #+(or cmu sbcl openmcl lispworks) (get-output-stream-string os) #+(or clisp allegro) (read-line os))
				   (p (search "LilyPond " out)))
			      (if 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)))
				  (er)))
			    (er))))))
	    *lilyvers*))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; LILYPOND BACKEND

(defparameter +lilypond-comment+ "% LilyPond score file~%% ~A v~A.~A.~A~%~%")

(defparameter +lilypond-vers+ "\\version \"~A.~A\"~%")
(defparameter +lilypond-defs+
  '("octUp = #(set-octavation 1)"
    "octReset = #(set-octavation 0)"
    "octDown = #(set-octavation -1)"
    "markAccIn = \\once \\override TextScript #'script-priority = #-100"
    "markOrnIn = \\once \\override Script #'script-priority = #-100"))
(defparameter +lilypond-defs-24+
  '("beamL = #(def-music-function (loc num) (number?) #{\\set stemLeftBeamCount = #$num #})"
    "beamR = #(def-music-function (loc num) (number?) #{\\set stemRightBeamCount = #$num #})"
    "beamLR = #(def-music-function (loc numl numr) (number? number?) #{\\set stemLeftBeamCount = #$numl \\set stemRightBeamCount = #$numr #})" 
    "textSpan = #(def-music-function (loc dir str) (number? string?) #{\\override TextSpanner #'direction = #$dir \\override TextSpanner #'edge-text = #(cons $str \"\") #})" 
    "noteHead = #(def-music-function (loc sty) (symbol?) #{\\once \\override NoteHead #'style = #$sty #})"
    ))
(defparameter +lilypond-defs-26+
  '("beamL = #(def-music-function (par loc num) (number?) #{\\set stemLeftBeamCount = #$num #})"
    "beamR = #(def-music-function (par loc num) (number?) #{\\set stemRightBeamCount = #$num #})"
    "beamLR = #(def-music-function (par loc numl numr) (number? number?) #{\\set stemLeftBeamCount = #$numl \\set stemRightBeamCount = #$numr #})" 
    "textSpan = #(def-music-function (par loc dir str) (number? string?) #{\\override TextSpanner #'direction = #$dir \\override TextSpanner #'edge-text = #(cons $str \"\") #})" 
    "noteHead = #(def-music-function (par loc sty) (symbol?) #{\\once \\override NoteHead #'style = #$sty #})"
    ))
(defparameter +lilypond-defs-28+
  '("beamL = #(define-music-function (par loc num) (number?) #{\\set stemLeftBeamCount = #$num #})"
    "beamR = #(define-music-function (par loc num) (number?) #{\\set stemRightBeamCount = #$num #})"
    "beamLR = #(define-music-function (par loc numl numr) (number? number?) #{\\set stemLeftBeamCount = #$numl \\set stemRightBeamCount = #$numr #})" 
    "textSpan = #(define-music-function (par loc dir str) (number? string?) #{\\override TextSpanner #'direction = #$dir \\override TextSpanner #'edge-text = #(cons $str \"\") #})" 
    "noteHead = #(define-music-function (par loc sty) (symbol?) #{\\once \\override NoteHead #'style = #$sty #})"
    ))

(defparameter +lilypond-num-note+ (vector "c" nil "d" nil "e" "f" nil "g" nil "a" nil "b"))
(defparameter +lilypond-num-acc+ (vector "eses" "es" "" "is" "isis"))
(defparameter +lilypond-num-accq+ (vector (vector nil "eses") (vector "eseh" "es" "eh") (vector "eh" "" "ih") (vector "ih" "is" "isih") (vector nil "isis")))
(defparameter +lilypond-barlines+ '((:single . "|") (:double . "||") (:final . "|.") (:repeatleft . ":|") (:repeatright . "|:") (:repeatleftright . ":|:") (:invisible . "")))

(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")
    (:stopped . "-+") (:pizz . "^\"pizz.\"") (:arco . "^\"arco\"") ((:breath :after) . " \\breathe") ((:glissando :after) . "\\glissando")
    ((:portamento :after) . "\\glissando") ((:fermata :short) . "\\shortfermata") (:fermata . "\\fermata")
    ((:fermata :long) . "\\longfermata") ((:fermata :verylong) . "\\verylongfermata")))

(defparameter +lilypond-trmarks+
  '((:trill . "\\trill") (:startlongtrill- . "\\startTrillSpan") (:prall . "\\prall") (:mordent . "\\mordent")))

(defparameter *lilypond-text-markup* "\\markup{\\italic{~A}}")
(defparameter *lilypond-textdyn-markup* "\\markup{\\dynamic{\\italic{\\bold{~A}}}}")
(defparameter *lilypond-texttempo-markup* "\\markup{\\bold{\\huge{~A}}}")
(defparameter *lilypond-textnote-markup* "\\markup{\\italic{~A}}")
(defparameter *lilypond-textacc-markup* "\\markup{\\tiny{~A}}") ;; not user defined yet

(defparameter +lilypond-dyns+
  `((:pppppp . ,(list (format nil *lilypond-textdyn-markup* "pppppp"))) (:ppppp . ,(list (format nil *lilypond-textdyn-markup* "ppppp")))
    (:pppp . "\\pppp") (:ppp . "\\ppp") (:pp . "\\pp") (:p . "\\p") (:mp . "\\mp")
    (:mf . "\\mf") (:f . "\\f") (:ff . "\\ff") (:fff . "\\fff") (:ffff . "\\ffff")
    (:fffff . ,(list (format nil *lilypond-textdyn-markup* "fffff"))) (:ffffff . ,(list (format nil *lilypond-textdyn-markup* "ffffff")))
    (:fp . "\\fp") (:sf . "\\sf") (:sff . "\\sff") (:sp . "\\sp") (:spp . "\\spp") (:sfz . "\\sfz") (:rfz . "\\rfz")))

(defparameter +lilypond-noteheads+
  '((:harmonic . "harmonic") (:diamond . "diamond") (:x . "cross") (:xcircle . "xcircle") (:triangle . "triangle") (:slash . "slash")))

(defparameter +lilypond-clefs+
  '((:subbass-8dn . "\"subbass_8\"") (:bass-8dn . "\"bass_8\"") (:c-baritone-8dn . "\"baritone_8\"") (:f-baritone-8dn . "\"varbaritone_8\"") (:tenor-8dn . "\"tenor_8\"")
    (:subbass . "subbass") (:alto-8dn . "\"alto_8\"") (:bass . "bass") (:mezzosoprano-8dn . "\"mezzosoprano_8\"") (:c-baritone . "baritone") (:f-baritone . "varbaritone")
    (:soprano-8dn . "\"soprano_8\"") (:tenor . "tenor") (:subbass-8up . "\"subbass^8\"") (:treble-8dn . "\"treble_8\"") (:alto . "alto") (:bass-8up . "\"bass^8\"")
    (:mezzosoprano . "mezzosoprano") (:c-baritone-8up . "\"baritone^8\"") (:f-baritone-8up . "\"varbaritone^8\"") (:soprano . "soprano") (:tenor-8up . "\"tenor^8\"")
    (:treble . "treble") (:alto-8up . "\"alto^8\"") (:mezzosoprano-8up . "\"mezzosoprano^8\"") (:soprano-8up . "\"soprano^8\"") (:treble-8up . "\"treble^8\"")
    (:percussion . "percussion")))

(defparameter +lilypond-keysigs+
  '((:cmaj . "c \\major") (:amin . "a \\minor")
    (:gmaj . "g \\major") (:emin . "e \\minor")
    (:dmaj . "d \\major") (:bmin . "b \\minor")
    (:amaj . "a \\major") (:f+min . "fis \\minor")
    (:emaj . "e \\major") (:c+min . "cis \\minor") 
    (:bmaj . "b \\major") (:g+min . "gis \\minor") (:c-maj . "ces \\major") (:a-min . "aes \\minor")
    (:f+maj . "fis \\major") (:d+min . "dis \\minor") (:g-maj . "ges \\major") (:e-min . "ees \\minor")
    (:c+maj . "cis \\major") (:a+min . "ais \\minor") (:d-maj . "des \\major") (:b-min . "bes \\minor")
    (:a-maj . "aes \\major") (:fmin . "f \\minor")
    (:e-maj . "ees \\major") (:cmin . "c \\minor")
    (:b-maj . "bes \\major") (:gmin . "g \\minor")
    (:fmaj . "f \\major") (:dmin . "d \\minor")))

(defparameter *lilypond-filehead* nil)
(defparameter *lilypond-scorehead* nil)

(defun save-lilypond (parts header filename options process view)
  (when (>= *verbose* 1) (out ";; Saving LilyPond file ~S...~%" filename))
  (with-open-file (f filename :direction :output :if-exists :supersede)
    (destructuring-bind (&key filehead scorehead text-markup textdyn-markup texttempo-markup textnote-markup textacc-markup version &allow-other-keys) options
      (let ((ve (lilypond-version options version)))
	(format f "~A" header)
	(format f +lilypond-vers+ (floor ve 100) (mod ve 100))
	(let ((fh (or filehead *lilypond-filehead*)))
	  (when fh (loop for e in (force-list fh) do (format f "~A~%" e) finally (format f "~%")))) ;; user header
	(loop for e in (append +lilypond-defs+
			       (cond
				 ((>= ve 207) +lilypond-defs-28+)
				 ((>= ve 205) +lilypond-defs-26+)
				 (t +lilypond-defs-24+)))
	      do (format f "~A~%" e) finally (format f "~%")) ;; definitions
	(let ((de 0) (nms nil) (twrn nil))
	  (flet ((lynote (wnum acc1 acc2 caut show)
		   (let ((rs (let ((g (- (truncate wnum 12) 4)))
			       (cond ((< g 0) (make-string (- g) :initial-element #\,))
				     ((> g 0) (make-string g :initial-element #\'))
				     (t "")))))
		     (if *quartertones*
			 (conc-strings
			  (svref +lilypond-num-note+ (mod wnum 12))
			  (svref (svref +lilypond-num-accq+ (+ acc1 2)) (1+ (* acc2 2)))
			  rs
			  (when caut "?")
			  (when show "!"))
			 (conc-strings
			  (svref +lilypond-num-note+ (mod wnum 12))
			  (svref +lilypond-num-acc+ (+ acc1 2))
			  rs
			  (when caut "?")
			  (when show "!")))))
		 (lyname (p)
                   (incf de)
                   (conc-strings
                    (string-downcase
                     (conc-stringlist (when (part-name p)
                                        (loop for x across (part-name p)
                                           when (alpha-char-p x)
                                           collect (string x)))))
                    (string (code-char (+ 64 de)))))
		 (lyclef (c)
		   (lookup c +lilypond-clefs+)))
	    (loop
	     for p in parts 
	     do (destructuring-bind (&key (lily-partname (lyname p))
					  lily-parthead	;; extra header information for part (list of strings)
					  &allow-other-keys) (part-opts p) 
		  (let ((ns (instr-staves (part-instr p))))
		    (push lily-partname nms)
		    (format f "~A = {~%" lily-partname)
		    (when (part-name p) (format f "  \\set Staff.instrument = ~S~%" (part-name p)))
		    (when (part-abbrev p) (format f "  \\set Staff.instr = ~S~%" (part-abbrev p)))
		    (when (or (null *timesig-style*) (eq *timesig-style* :fraction))
		      (if (> ns 1)
			  (loop for s from 1 to ns do
				(format f "  \\change Staff = ~A \\override Staff.TimeSignature #'style = #'()~%" (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~%")
		    (if *acc-throughout-meas*
			(format f "  #(set-accidental-style 'default)~%")
			(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))) (lyclef cl)))
			(format f "  \\clef ~A~%" (lyclef (second (getprop p :clef)))))
		    (loop for e in lily-parthead do (format f "  ~A~%" e))
		    (format f "~%") 
		    (loop with nvce = (mloop for e in (part-meas p) maximize (length (meas-voices e)))
			  initially (format f "  << ")
			  for vce from 0 below nvce do
			  (format f "{")
			  (loop
			   with cdi = :u
			   for (m . nxm) on (part-meas p) and mn from 1
			   for ts = (meas-timesig m) do
			   (when (getprop m :startkey)
			     (let ((x (lookup (second (getprop ts :keysig)) +lilypond-keysigs+)))
			       (when x (if (> ns 1)
					   (loop for s from 1 to ns do
						 (format f "\\change Staff = ~A \\key ~A " (code-char (+ 64 s)) x))
					   (format f "\\key ~A " x)))))
			   (when (getprop m :startsig) (format f "\\time ~A/~A " (timesig-num ts) (timesig-den ts)))
			   (loop
			    for (pre e nxe) on (cons nil (or (nth vce (meas-voices m))
							     (list (make-restex nil :inv t :off (meas-off m) :dur (- (meas-endoff m) (meas-off m)) :marks '(:measrest)))))
			    while e
			    do (let ((fm (getmark e :measrest))
				     (trf (and (>= (or (nth-value 1 (event-writtendur* e ts)) 0) 2) (< ve 209))))
				 (when (getmark e '(:starttext- 2)) (setf twrn t))
				 (format f "~A "
					 (conc-strings
					  (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)))) ""))
					  (let ((c (getmark e :clef)))
					    (if (and c (null (fourth c))) (format nil "\\clef ~A " (lyclef (second c)))
						""))
					  (cond ((or (getmark e :start8up-) (getmark e :8up)) "\\octUp ")
						((or (getmark e :start8down-) (getmark e :8down)) "\\octDown "))
					  (let ((m (getmark e '(:starttext- 1)))) ; can't have more than one at once
					    (if m (format nil "\\textSpan #~A #\"~A \" " (ecase (third m) (:up 1) (:down -1)) (fourth m)) ""))
					  (let ((uu (sort (getmarks e :starttup) #'< :key #'second)))
					    (conc-stringlist
					     (loop for u in uu for r = (third u)
						   collect (format nil "\\times ~A/~A {" (cdr r) (car r)))))
					  (let ((z (getmark e :notehead)))
					    (if z (let ((y (lookup (second z) +lilypond-noteheads+)))
						    (if y (format nil "\\noteHead #'~A " y) ""))
						""))
					  (let ((g (event-grace e)))
					    (if g
						(let ((g1 (getmark e :startgrace))
						      (gs (getmark e :startgraceslur-)))
						  (cond ((and g1 (getmark e :endgrace))
							 (if (and gs (not (or (getmark e :slur-) (getmark e :startslur-))))
							     (if (< g 0) "\\acciaccatura " "\\appoggiatura ") "\\grace "))
							(g1 (if (and gs (not (or (getmark e :slur-) (getmark e :startslur-))))
								(if (< g 0) "\\acciaccatura {" "\\appoggiatura {") "\\grace {"))))
						""))
					  (cond ((getmark e '(:arpeggio :up)) "\\arpeggioUp ")
						((getmark e '(:arpeggio :down)) "\\arpeggioDown ")
						((getmark e :arpeggio) "\\arpeggioNeutral ")
						(t ""))
					  (if (some (lambda (aa) (let ((x (getmarks e (car aa))))
								   (some (lambda (z) (and z (listp z) (if (member (first z) +marks-long+) (fifth z) (third z)))) x)))
						    +lilypond-trmarks+)
					      (if (eq cdi :d) "\\markAccIn " "\\markOrnIn ")
					      "")
					  (let ((l (and (notep e) (notep pre) (> (event-beamlt e) 0) (/= (min (event-nbeams e ts) (event-nbeams pre ts)) (event-beamlt e))))
						(r (and (notep e) (notep nxe) (> (event-beamrt e) 0) (/= (min (event-nbeams e ts) (event-nbeams nxe ts)) (event-beamrt e)))))
					    (cond ((and l r) (format nil "\\beamLR #~A #~A " (event-beamlt e) (event-beamrt e)))
						  (l (format nil "\\beamL #~A " (event-beamlt e)))
						  (r (format nil "\\beamR #~A " (event-beamrt e)))
						  (t "")))
					  (let ((m (or (getmark e :tremolo) (getmark e :starttremolo)))) ;; (format nil "\\markup{~A}" (conc-stringlist (loop repeat (second m) collect "/")))
					    (if (and m (not trf))
						(format nil "\\repeat \"tremolo\" ~A ~A" (second m)
							(if (eq (first m) :tremolo) "" "{"))
						"")) ; stuff before 
					  (if (notep e)
					      (if (chordp e)
						  (format nil "<~A>" (conc-stringlist
								      (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 (lynote w a a2 (getmark e (list :cautacc n)) (getmark e (list :showacc n)))
								       when ha collect "\\harmonic"
								       when hs collect "^\\flageolet"
								       when nn collect " ")))
						  (lynote (event-writtennote e) (event-acc e) (event-addacc e) ; 8/9/06
							  (getmark e (list :cautacc (event-note* e)))
							  (getmark e (list :showacc (event-note* e))))
						  #|(conc-strings ; 8/9/06
						   (lynote (event-writtennote e) (event-acc e) (event-addacc e)
							   (getmark e (list :cautacc (event-note* e)))
							   (getmark e (list :showacc (event-note* e))))
						   (let ((ha (getmark e :harmonic)))
						     (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)
											(getmark e :starttremolo)
											(getmark e :endtremolo))))
									     (if (and m (not trf))
										 (values (third m) 0)
										 (event-writtendur* e ts)))
						(let ((du (case wd
							    (2 "\\breve")
							    (4 "\\longa")
							    (otherwise (/ wd)))))
						  (ecase ds
						    (0 (format nil "~A" du))
						    (1 (format nil "~A." du))
						    (2 (format nil "~A.." du))))))
					  (if (chordp e) "" ; 8/9/06
					      (let ((ha (getmark e :harmonic)))
						(or (when ha (ecase (second ha) (:touched "\\harmonic") (:sounding "^\\flageolet"))) "")))
					  (if (getmark e :arpeggio) "\\arpeggio" "")
					  (conc-stringlist
					   (loop
					    for xxx in (delete-if (lambda (x) (/= (second x) 2)) (getmarks e :startslur-))
					    collect "\\("))
					  (conc-stringlist
					   (loop
					    for xxx in (delete-if (lambda (x) (/= (second x) 1)) (getmarks e :startslur-))
					    collect "("))
					  (conc-stringlist
					   (loop
					    for xxx in (delete-if (lambda (x) (/= (second x) 1)) (getmarks e :endslur-))
					    collect ")"))
					  (conc-stringlist
					   (loop
					    for xxx in (delete-if (lambda (x) (/= (second x) 2)) (getmarks e :endslur-))
					    collect "\\)"))
					  (if (and (notep e) (= (event-beamlt e) 0) (> (event-beamrt e) 0)) "[" "")
					  (if (and (notep e) (> (event-beamlt e) 0) (= (event-beamrt e) 0)) "]" "")
					  (if (and (notep e) (or-list (force-list (event-tiert e)))) "\~" "")
					  (conc-stringlist
					   (loop for i in
						 (sort (delete-duplicates
							(loop for (a1 . a2) in +lilypond-marks+
							      nconc (mapcar (lambda (x) (cons a2 (force-list x))) (getmarks e a1)))
							:key #'cdr :test #'equal)
						       (lambda (x y) (cond
								       ((find (cadr x) +marks-withacc+) nil)
								       ((find (cadr y) +marks-withacc+) t)
								       (t (let ((x2 (caddr x)) (y2 (caddr y)))
									    (cond ((and (numberp x2) (numberp y2)) (< x2 y2))
										  (x2 t)))))))
						 collect (car i)))
					  (conc-stringlist
					   (loop for i in
						 (delete-duplicates
						  (loop for (a1 . a2) in +lilypond-trmarks+
							nconc (mapcar (lambda (x) (let ((f (force-list x)))
										    (cons a2 (if (member (first f) +marks-long+) (fifth f) (third f)))))
								      (getmarks e a1)))
						  :key #'cdr :test #'equal)
						 when (eq cdi :u) collect "^" and collect (car i)
						 when (cdr i) collect (ecase cdi (:u "^") (:d "_")) and
						 collect (format nil (or textacc-markup *lilypond-textacc-markup*)
								 (ecase (cdr i)
								   (-2 "\\doubleflat")
								   (-3/2 "\\sesquiflat")
								   (-1 "\\flat")
								   (-1/2 "\\semiflat")
								   (0 "\\natural")
								   (1/2 "\\semisharp")
								   (1 "\\sharp")
								   (3/2 "\\sesquisharp")
								   (2 "\\doublesharp")))
						 when (eq cdi :d) collect "_" and collect (car i)))
					  (cond ((or (getmark e :endwedge<) (getmark e :endwedge>)) "\\!")
						(t ""))
					  (conc-stringlist
					   (loop for i in
						 (loop for a in +lilypond-dyns+ nconc (mapcar #'force-list (getmarks e (car a))))
						 for l = (lookup (first i) +lilypond-dyns+)
						 if (listp l) collect (conc-strings (if (<= nvce 1) "_" (ecase vce ((0 2) "^") ((1 3) "_"))) (car l)) else collect l))
					  (cond ((getmark e :startwedge<) "\\< ")
						((getmark e :startwedge>) "\\> ") 
						(t "")) 
					  (conc-stringlist
					   (loop for x in '(:text :textdyn :texttempo :textnote)
						 and m in (list (or text-markup *lilypond-text-markup*)
								(or textdyn-markup *lilypond-textdyn-markup*)
								(or texttempo-markup *lilypond-texttempo-markup*)
								(or textnote-markup *lilypond-textnote-markup*))
						 nconc (loop for (xxx di str) in (getmarks e x)
							     collect (conc-strings
								      (ecase di (:up "^") (:down "_"))
								      (format nil m str)))))
					  (let ((m (getmark e '(:starttext- 1))))
					    (if m "\\startTextSpan" ""))
					  (let ((m (getmark e '(:endtext- 1))))
					    (if m "\\stopTextSpan" ""))	; the actual note w/ attachments
					  (let ((m (getmark e '(:endlongtrill- 1))))
					    (if m "\\stopTrillSpan" ""))
					  (let ((m (or (getmark e :tremolo) (getmark e :starttremolo)))) ;; 
					    (if (and m trf)
						(format nil "^\\markup{\"~A~A\"}"
							(conc-stringlist (loop repeat (- (roundint (log (third m) 1/2)) 2) collect "/"))
							(if (getmark e :starttremolo) "-" "")) 
						"")) 
					  (if (and (getmark e :endtremolo) (not trf))
					      "}" "")
					  (if (and (event-grace e) (getmark e :endgrace) (not (getmark e :startgrace))) "}" "")
					  (let ((uu (getmarks e :endtup)))
					    (conc-stringlist
					     (loop repeat (length uu) collect "}")))
					  (cond ((or (getmark e :end8up-) (getmark e :8up)) " \\octReset")
						((or (getmark e :end8down-) (getmark e :8down)) " \\octReset"))))))
			   (let ((b (getprop m :barline)))
			     (when b (format f "\\bar \"~A\" " (lookup (second b) +lilypond-barlines+))))
			   (format f "| %~A~%     ~A" mn (if nxm " " "")))
			  (if (< vce (1- nvce)) (format f "} \\\\~%     ") (format f "}~%  >>~%")))
		    (format f "}~%~%")
		    (if (> ns 1) 
			(format f "~A = {~%  ~A~%}~%~%"
				(conc-strings lily-partname "S") 
				(conc-stringlist
				 (loop with nu = 0
				       for n = nil then (timesig-num (meas-timesig m))
				       and d = nil then (timesig-den (meas-timesig m))
				       for m in (part-meas p)
				       when (and (getprop m :startsig) (> nu 0))
				       collect (format nil "\\skip 1*~A/~A*~A " n d nu) into re and do (setf nu 0)
				       do (incf nu)
				       finally (return (nconc re (list (format nil "\\skip 1*~A/~A*~A" n d nu))))))))))) ;)
	    (when (or *title* *subtitle* *composer*)
	      (format f "\\header {~%")
	      (when *title* (format f "  title = ~S~%" *title*))
	      (when *subtitle* (format f "  subtitle = ~S~%" *subtitle*))
	      (when *composer* (format f "  composer = ~S~%" *composer*))
	      (format f "}~%~%"))
	    (format f "\\score {~%") ;; score block
	    (loop for e in (force-list (or scorehead *lilypond-scorehead*)) do (format f "  ~A~%" e))
	    (loop
	     with in = 2
	     for p in parts and nm in (nreverse nms) do
	     (loop
	      for (xxx nu ty) in (sort (getprops p :startgroup) #'< :key #'second) do
	      (if ty
		  (ecase ty 
		    ((:group :choirgroup) (format f "~A\\new ~A <<~%" (make-string in :initial-element #\space)
						  (ecase ty
						    (:group (if (<= nu 1) "StaffGroup" "InnerStaffGroup"))
						    (:choirgroup (if (<= nu 1) "ChoirStaff" "InnerChoirStaff")))))
		    (:grandstaff (format f "~A\\new PianoStaff <<~%" (make-string in :initial-element #\space))))
		  (format f "~A<<~%" (make-string in :initial-element #\space)))
	      (incf in 2))
	     (let ((ns (instr-staves (part-instr p))))
	       (if (<= ns 1)
		   (format f "~A\\new Staff \\~A~%" (make-string in :initial-element #\space) nm)
		   (progn
		     (loop for s from 1 to ns do (format f "~A\\context Staff = ~A \\~A~%"
							 (make-string in :initial-element #\space)
							 (code-char (+ 64 s))
							 (conc-strings nm "S")))
		     (format f "~A\\context Staff = A \\new Voice \\~A~%" (make-string in :initial-element #\space) nm))))
	     (loop
	      for xxx in (getprops p :endgroup)
	      do (decf in 2) (format f "~A>>~%" (make-string in :initial-element #\space))))
	    (format f "}~%"))
	  (when twrn (format t ";; WARNING: Some string spanners are excluded~%"))))))
  (when process (view-lilypond filename options view)))

