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

;;

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

(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 (objc:list->nsarray '("score.xml")))

(define args2 (objc:list->nsarray '("--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)