;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;

;; An example demonstrating the generation of a

;; musicxml document. this code is a very basic

;; musicxml implementation and is provided to give you 

;; some ideas for your own enhancement/use.

;;

;; there is some optional code at the end 

;; which will convert the musicxml score to

;; lilypond format, generate a png file

;; and display the score in a canvas.  You will

;; need to download and install lilypond before

;; running this optional code.

;;

;; You can find an osx build of lilypond on apples

;; audio download pages.

;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(define *l-pitch-map*

   '((0 . "C")

     (2 . "D")

     (4 . "E")

     (5 . "F")

     (7 . "G")

     (9 . "A")

     (11 . "B")))


(define *rhythm-type*

   (list (cons (* 24 0.125) "32nd")

         (cons (* 24 0.25) "16th")

         (cons (* 24 (/ 1 3)) "eighth")

         (cons (* 24 0.5) "eighth")         

         (cons (+ (* 24 0.5)

                  (* 24 0.25)) "eighth")

         (cons (* 24 (/ 2 3)) "quarter")

         (cons (* 24 1.0) "quarter")

         (cons (+ (* 24 1.0)

                  (* 24 0.5)) "quarter")

         (cons (* 24 2.0) "half")

         (cons (+ (* 24 2.0)

                  (* 24 1.0)) "half")

         (cons (* 24 4.0) "whole")))


(define *rhythm-triplet*

   (list (* 24 (/ 1 3))))


(define *rhythm-dotted*

   (list (+ (* 24 0.5)

            (* 24 0.25))

         (+ (* 24 1.0)

            (* 24 0.5))

         (+ (* 24 2.0)

            (* 24 1.0))))

   

(define remove-all

   (lambda (obj lst)

      (cond ((null? lst)

             '())

            ((list? (car lst))

             (cons (remove-all obj (car lst))

                   (remove-all obj (cdr lst))))

            ((equal? obj (car lst))

             (remove-all obj (cdr lst)))

            (else (cons (car lst) (remove-all obj (cdr lst)))))))


(define make-note

   (lambda (pitch duration voice div . args)      

      (let* ((tmp (assoc (fmod pitch 12) *l-pitch-map*))

             (alter (if tmp 0 1))

             (type (cdr (assoc (* duration div) *rhythm-type*)))

             (step (if tmp 

                       (cdr tmp)

                       (if (positive? pitch)

                           (cdr (assoc (fmod (- pitch 1) 12) *l-pitch-map*))

                           0)))

             (octave (- (floor (/ pitch 12)) 1)))

         (remove-all 'none `(note ,(if (= -1 pitch)

                                       (list 'rest)

                                       (list 'pitch

                                             (list 'step step)

                                             (list 'octave octave)

                                             (list 'alter alter)))

                                  (duration ,(* duration div))

                                  (type ,type)

                                  ,(if (member (* duration div) *rhythm-triplet*) 

                                       (list 'time-modification

                                             (list 'actual-notes 3)

                                             (list 'normal-notes 2))

                                       'none)

                                  ,(if (not (null? args))

                                       (list 'notations 

                                             (cond ((member 'start-tie args)

                                                    '(tied (type . "start")))

                                                   ((member 'stop-tie args)

                                                    '(tied (type . "stop")))

                                                   (else 'none)))

                                       'none)                                             

                                  ,(if (member (* duration div) *rhythm-dotted*) (list 'dot) 'none)

                                  (voice ,voice))))))


(define make-measure 

   (lambda (num div fifths mode beats beat-type sign line notes)

      (remove-all 'none `(measure (number . ,num)

                                  (attributes (divisions ,div)

                                              ,(if (not (null? fifths))

                                                   `(key (fifths ,fifths)

                                                         (mode ,mode))

                                                   'none)

                                              ,(if (not (null? beats))

                                                   `(time (beats ,beats)

                                                          (beat-type ,beat-type))

                                                   'none)

                                              ,(if (not (null? sign))

                                                   `(clef (sign ,sign)

                                                          (line ,line))

                                                   'none))

                                  ,@notes))))


(define make-part

   (lambda (name id measures)

      (cons `(score-part (id . ,id)

                         (part-name ,name))

            `(part (id . ,id)

                   ,@measures))))


(define make-score

   (lambda (title composer rights parts)

      `(score-partwise (version . "1.1")

                       (work (work-title ,title))

                       (identification (creator (type . "composer") ,composer)

                                       (rights ,rights))

                       (part-list ,@(map (lambda (part)

                                            (car part))

                                         parts))

                       ,@(map (lambda (part)

                                 (cdr part))

                              parts))))


(define list->measures

   (lambda (num den clef line plst rlst)

      (let ((bar (* num (/ 4 den))))

         (let loop ((pl plst)

                    (rl rlst)

                    (i 1)

                    (carry 0.0)

                    (pitch 0)

                    (cnt 0)

                    (measures '()))

            (cond ((> i (length pl))

                   (reverse measures))

                  ((>= (+ carry (apply + (cl:butnthcdr i rl))) bar)

                   (let* ((newpl (cl:nthcdr i pl))

                          (newrl (cl:nthcdr i rl))

                          (newi 1)

                          (measurepl (if (> carry 0)

                                         (cons pitch (cl:butnthcdr i pl))

                                         (cl:butnthcdr i pl)))

                          (measurerl (if (> carry 0)

                                         (cons carry (cl:butnthcdr i rl))

                                         (cl:butnthcdr i rl)))

                          (newcarry (- (+ carry (apply + (cl:butnthcdr i rl))) bar))

                          (newpitch (if (= (length pl) i) 0 (list-ref pl (- i 1))))

                          (newcnt (+ cnt 1)))

                      (if (> newcarry 0)

                          (set-cdr! (cl:nthcdr (- (length measurerl) 2) measurerl) 

                                    (list (- (list-ref measurerl (- (length measurerl) 1)) newcarry))))

                      (loop newpl newrl newi newcarry newpitch newcnt

                            (cons (make-measure cnt 24 

                                                (if (= cnt 0) 0 '())

                                                "major" 

                                                (if (= cnt 0) num '())

                                                den

                                                (if (= cnt 0) clef '())

                                                line

                                                (let loop2 ((plist measurepl)

                                                            (rlist measurerl)

                                                            (notes '()))

                                                   (cond ((null? plist)

                                                          (reverse notes))

                                                         ((= (length plist) (length measurepl))

                                                          (loop2 (cdr plist) 

                                                                 (cdr rlist)

                                                                 (cons (if (> carry 0)

                                                                           (make-note (car plist) (car rlist) 1 24 'stop-tie)

                                                                           (make-note (car plist) (car rlist) 1 24))                                                                       

                                                                       notes)))

                                                         ((= (length plist) 1)

                                                          (loop2 (cdr plist)

                                                                 (cdr rlist)

                                                                 (cons (if (> newcarry 0)

                                                                           (make-note (car plist) (car rlist) 1 24 'start-tie)

                                                                           (make-note (car plist) (car rlist) 1 24))

                                                                       notes)))

                                                         (else (loop2 (cdr plist)

                                                                      (cdr rlist)

                                                                      (cons (make-note (car plist) (car rlist) 1 24)

                                                                            notes))))))

                                  measures))))

            (else (loop pl rl (+ i 1) carry pitch cnt measures)))))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; create a random score with three monophonic parts

(define p1 (make-list-with-proc 50 (lambda (i) (if (> (random) 0.1)

                                                   (random 72 84)

                                                   -1))))

(define r1 (make-list-with-proc 50 (lambda (i) (random '(0.5 1.0 1.5 2.0)))))

(define p2 (make-list-with-proc 50 (lambda (i) (if (> (random) 0.1)

                                                   (random 60 72)

                                                   -1))))

(define r2 (make-list-with-proc 50 (lambda (i) (random (list 0.5 1.0 1.5 2.0)))))

(define p3 (make-list-with-proc 50 (lambda (i) (if (> (random) 0.1)

                                                   (random 48 60)

                                                   -1))))

(define r3 (make-list-with-proc 50 (lambda (i) (random '(0.5 1.0 1.5 2.0)))))


; create score 

(define score (make-score "Impromptu" "Impromptu" "(c) 2006"

                          (list (make-part "Flute" "Fl" (list->measures 3 4 "G" 2 p1 r1))

                                (make-part "Oboe" "Ob" (list->measures 3 4 "G" 2 p2 r2))

                                (make-part "Bassoon" "Bn" (list->measures 3 4 "F" 4 p3 r3)))))


; convert score to xml

(define xmlscore (xml:tree->xml score))

(define xmltext (xml:document->string xmlscore))

(print xmltext)


; output to xml file 

(io:delete-file "/tmp/score.xml")

(define output-port (open-output-file "/tmp/score.xml"))

(display xmltext output-port)

(close-port output-port)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; optional code to call out to lilypond

;; run one line at a time 

;; make sure you give the task calls a few seconds

;; as they do not block.

;;

;; Assumes that lilypond is installed in /Applications

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(io:cwd "/tmp")

(define lilypond-bin "/Applications/Lilypond.app/Contents/Resources/bin/")

(define args1 (list->objc '("score.xml")))

(define args2 (list->objc '("--png" "score.ly")))

(objc:call "NSTask" "launchedTaskWithLaunchPath:arguments:" 

           (string-append lilypond-bin "musicxml2ly") args1)

(objc:call "NSTask" "launchedTaskWithLaunchPath:arguments:" 

           (string-append lilypond-bin "lilypond") args2)

(define canvas (gfx:make-canvas '(500 500 600 800)))

(define image (gfx:load-image "/tmp/score.png"))

(gfx:draw-image (now) canvas image 1.0)