-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathfomus.lisp
158 lines (143 loc) · 5.67 KB
/
fomus.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
;;; **********************************************************************
;;; Copyright (C) 2009 Heinrich Taube, <taube (at) uiuc (dot) edu>
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the Lisp Lesser Gnu Public License.
;;; See http://www.cliki.net/LLGPL for the text of this agreement.
;;; **********************************************************************
;;; generated by scheme->cltl from fomus.scm on 04-Aug-2009 14:11:46
(in-package :cm)
#|
(defstub obj-partid (x) :method)
(defstub fomus)
(defstub make-part)
(defstub make-note)
(defstub get-instr-syms)
(defstub fomus-file)
(defstub (special *parts*))
|#
(progn
(defclass fomus-file (event-file)
((parts :initarg :parts :initform '() :accessor fomus-file-parts)
(global :initarg :global :initform '() :accessor fomus-file-global)
(view :initarg :view :initform t :accessor fomus-file-view)
(play :initarg :play :initform nil :accessor fomus-file-play)
(tempo :initarg :tempo :initform 60 :accessor fomus-file-tempo))
#+metaclasses
(:metaclass io-class))
(defparameter <fomus-file> (find-class 'fomus-file))
(finalize-class <fomus-file>)
(setf (io-class-file-types <fomus-file>)
'("*.fms" "*.xml" "*.ly"))
(values))
(defmethod object-time ((obj event-base)) (event-off obj))
(defmethod open-io ((io fomus-file) dir &rest args)
args
(when (eq dir ':output)
(let ((parts (fomus-file-parts io))
(globs (fomus-file-global io)))
(if (not (consp parts))
(setf (fomus-file-parts io)
(if (null parts) (list) (list parts))))
(if (not (consp globs))
(setf (fomus-file-global io)
(if (null globs) (list) (list globs))))
(map nil
(lambda (p) (setf (part-events p) (list)))
(fomus-file-parts io))
(setf (io-open io) t)))
io)
(defmethod close-io ((io fomus-file) &rest mode)
(let ((err? (and (not (null mode)) (eq (car mode) ':error))))
(setf (io-open io) nil)
(unless err?
(let* ((args (event-stream-args io))
(bend (getf args ':output)))
(unless bend
(let* ((file (file-output-filename io))
(type (filename-type file)))
(cond ((equal type "ly")
(setf bend (list ':lilypond
:filename file
:view (fomus-file-view io))))
((equal type "xml")
(setf bend (list ':musicxml
:filename file
:view (fomus-file-view io))))
(t (setf bend (list ':fomus :filename file))))
(when (fomus-file-play io)
(setf bend
(list bend (list ':midi :play t
:filename (make-pathname :type "mid" :defaults file)
:tempo (fomus-file-tempo io)))))
(setf args (list* ':output bend args))))
(apply #'fomus
:parts (fomus-file-parts io)
:global (fomus-file-global io)
args)))))
(defun fomus-file-part (stream id)
(do ((tail (fomus-file-parts stream) (cdr tail)) (part nil))
((or (null tail) part)
(when (not part)
(setf part
(make-part :partid id :instr
(if (keyword? id) id nil)))
(setf (fomus-file-parts stream)
(cons part (fomus-file-parts stream))))
part)
(if (eq id (obj-partid (car tail))) (setf part (car tail)))))
(defmethod write-event ((obj event-base) (fil fomus-file) scoretime)
(let ((part (fomus-file-part fil (obj-partid obj))))
(setf (event-off obj) scoretime)
(setf (part-events part) (cons obj (part-events part)))
obj))
(defmethod write-event ((obj midi) (fil fomus-file) scoretime)
(let* ((myid (midi-channel obj))
(part (fomus-file-part fil myid))
(marks '()))
(setf (part-events part)
(cons (make-note :partid myid :off scoretime :note
(midi-keynum obj) :dur (midi-duration obj) :marks
marks)
(part-events part)))))
(defun partid->part (pid)
(loop for p in *parts* thereis (eq pid (obj-partid p))))
(defmethod schedule-object ((obj part) start sched)
(let ((mystart (+ start 0)))
(enqueue *qentry-seq* (cons obj (part-events obj)) mystart
mystart sched)))
(defmethod write-event ((obj note) (fil midi-file) scoretime)
(let* ((myid (obj-partid obj))
(part (partid->part myid))
(opts (if (not part) (list) (part-opts part)))
(chan nil)
(ampl 64))
opts
(unless chan (setf chan (if (integerp myid) myid 0)))
(write-event
(make-instance <midi>
:time (event-off obj)
:amplitude ampl
:keynum (event-note obj)
:duration (event-dur obj)
:channel chan)
fil scoretime)))
(defmethod import-events ((file fomus-file) &key (seq t))
(let ((fil (file-output-filename file)))
(cond ((or (not seq) (typep seq <seq>)) nil)
((eq seq t)
(setf seq
(make-instance
<seq>
:name
(format nil "~a-notes" (filename-name fil)))))
(t
(error "import-events: ~S is not a boolean or seq." seq)))
(multiple-value-bind (parts notes globs sets)
(fomus-file fil)
(setf (fomus-file-parts file) parts)
(setf (fomus-file-global file) globs)
(setf (event-stream-args file) sets)
(if seq
(progn (setf (container-subobjects seq) notes) seq)
notes))))