view clojure/com/aurellem/run/music.clj @ 553:0901694725f0

saving progress for the night.
author Robert McIntyre <rlm@mit.edu>
date Thu, 30 Aug 2012 14:11:11 -0500
parents b69a3dba8045
children
line wrap: on
line source
1 (ns com.aurellem.run.music
2 (:use (com.aurellem.gb saves gb-driver util constants
3 items vbm characters money
4 rlm-assembly))
5 (:use (com.aurellem.run util title save-corruption
6 bootstrap-0 bootstrap-1))
7 (:require clojure.string)
8 (:import [com.aurellem.gb.gb_driver SaveState])
9 (:import java.io.File))
11 (def pony
12 (File. user-home "/proj/vba-clojure/music/pony-title.mid"))
14 (def pony-csv
15 (File. user-home "proj/vba-clojure/music/pony-title.csv"))
17 (def sync-test
18 (File. user-home "proj/vba-clojure/music/sync-test.mid"))
20 (def drum-test
21 (File. user-home "proj/vba-clojure/music/drum-test.mid"))
23 (def regret
24 (File. user-home "proj/vba-clojure/music/ship-of-regret-and-sleep.mid"))
26 (def regret-csv
27 (File. user-home "proj/vba-clojure/music/ship-of-regret-and-sleep.csv"))
29 (def mother
30 (File. user-home "proj/vba-clojure/music/mother.mid"))
32 (def mother-csv
33 (File. user-home "proj/vba-clojure/music/mother.csv"))
36 (defn raw-midi-text [#^File midi-file]
37 (let [extention (apply str (take-last 3 (.getCanonicalPath
38 midi-file)))]
39 (cond (= "mid" extention)
40 (:out
41 (clojure.java.shell/sh
42 "midicsv"
43 (.getCanonicalPath midi-file)
44 "-"))
45 (= "csv" extention)
46 (slurp midi-file))))
48 (def command-line #"^(\d+), (\d+), ([^,]+)(.*)$")
50 (defmulti parse-command :command)
52 (defn discard-args [command] (dissoc command :args))
54 (defmethod parse-command :Start_track
55 [command] (discard-args command))
57 (defmethod parse-command :End_track
58 [command] (discard-args command))
60 (defmethod parse-command :default
61 [command] command)
63 (defn parse-number-list
64 [number-list-str]
65 (map #(Integer/parseInt %)
66 (clojure.string/split number-list-str #", ")))
68 (defmethod parse-command :Tempo
69 [command]
70 (update-in command [:args] #(Integer/parseInt %)))
72 (defn parse-midi-note-list
73 [midi-note-list-str]
74 (let [[channel note velocity]
75 (parse-number-list midi-note-list-str)]
76 {:channel channel :note note :velocity velocity}))
78 (defmethod parse-command :Note_on_c
79 [command]
80 (update-in command [:args] parse-midi-note-list))
82 (defmethod parse-command :Note_off_c
83 [command]
84 (update-in command [:args] parse-midi-note-list))
86 (defmethod parse-command :Header
87 [command]
88 (let [args (:args command)
89 [format num-tracks division] (parse-number-list args)]
90 (assoc command :args
91 {:format format
92 :num-tracks num-tracks
93 :division division})))
95 (defmethod parse-command :Program_c
96 [command]
97 (let [args (:args command)
98 [channel program-num] (parse-number-list args)]
99 (assoc command :args
100 {:channel channel
101 :program-num program-num})))
103 (defn parse-midi [#^File midi-file]
104 (map
105 (comp parse-command
106 (fn [line]
107 (let [[[_ channel time command args]]
108 (re-seq command-line line)]
109 {:channel (Integer/parseInt channel)
110 :time (Integer/parseInt time)
111 :command (keyword command)
112 :args (apply str (drop 2 args))})))
113 (drop-last
114 (clojure.string/split-lines
115 (raw-midi-text midi-file)))))
117 (def music-base new-kernel)
119 (defn store [n address]
120 (flatten
121 [0xF5
122 0xE5
124 0x3E
125 n
127 0x21
128 (reverse (disect-bytes-2 address))
130 0x77
132 0xE1
133 0xF1]))
135 (defn infinite-loop []
136 [0x18 0xFE])
138 (def divider-register 0xFF04)
140 (defrecord Bit-Note [frequency volume duration duty])
142 (defn clear-music-registers []
143 (flatten
144 [(store (Integer/parseInt "00000000" 2) 0xFF10) ;; sweep
145 (store (Integer/parseInt "00000000" 2) 0xFF11) ;; pattern duty
146 (store (Integer/parseInt "00000000" 2) 0xFF12) ;; volume
147 (store (Integer/parseInt "00000000" 2) 0xFF13) ;; frequency-low
148 (store (Integer/parseInt "00000000" 2) 0xFF14) ;; frequency-high
150 (store (Integer/parseInt "00000000" 2) 0xFF16) ;; pattern duty 000000
151 (store (Integer/parseInt "00000000" 2) 0xFF17) ;; volume 0000
152 (store (Integer/parseInt "00000000" 2) 0xFF18) ;; frequency-low
153 (store (Integer/parseInt "00000000" 2) 0xFF19) ;; 00000 frequency-high
155 (store (Integer/parseInt "00000000" 2) 0xFF1A)
156 (store (Integer/parseInt "00000000" 2) 0xFF1B)
157 (store (Integer/parseInt "00000000" 2) 0xFF1C)
158 (store (Integer/parseInt "00000000" 2) 0xFF1D)
159 (store (Integer/parseInt "00000000" 2) 0xFF1E)
161 (store (Integer/parseInt "00000000" 2) 0xFF20) ;; length
162 (store (Integer/parseInt "00000000" 2) 0xFF21) ;; volume
163 (store (Integer/parseInt "00000000" 2) 0xFF22) ;; noise-frequency
164 (store (Integer/parseInt "00000000" 2) 0xFF23) ;; control
165 ]))
168 ;; mini-midi syntax
170 ;; codes
171 ;; note-code == 0x00
172 ;; change-duty-code = 0x01
173 ;; silence-code = 0x02
175 ;; silence format
176 ;; 2 bytes
177 ;; [silence-code (0x02)]
178 ;; [duration-8-bits]
180 ;; note data format
181 ;; 4 bytes
182 ;; [note-code (0x00)]
183 ;; [volume-4-bits 0 frequency-high-3-bits]
184 ;; [frequengy-low-8-bits]
185 ;; [duration-8-bits]
187 ;; change-duty-format
188 ;; 2 bytes
189 ;; [change-duty-code (0x01)]
190 ;; [new-duty]
192 (def note-code 0x00)
193 (def change-duty-code 0x01)
194 (def silence-code 0x02)
196 (defn do-message
197 "Read the message which starts at the current value of HL and do
198 what it says. Duration is left in A, and HL is advanced
199 appropraitely."
200 ([] (do-message 0x16 1))
201 ([sound-base-address wave-duty]
202 (assert (<= 0 wave-duty 3))
203 (let [switch
204 [0x2A ;; load message code into A, increment HL
206 ;; switch on message
207 0xFE
208 note-code
210 0x20
211 :note-length]
213 play-note
214 [0x3E ;; set wave-duty
215 (bit-shift-left wave-duty 6)
216 0xE0
217 sound-base-address
218 0x2A ;; load volume/frequency-high info
219 0xF5 ;; push A
220 0xE6
221 (Integer/parseInt "11110000" 2) ;; volume mask
222 0xE0
223 (inc sound-base-address) ;;0x17 ;; set volume
224 0xF1 ;; pop A
225 0xE6
226 (Integer/parseInt "00000111" 2) ;; frequency-high mask
227 0xE0
228 (+ 3 sound-base-address) ;;0x19 ;; set frequency-high
230 0x2A ;; load frequency low-bits
231 0xE0
232 (+ 2 sound-base-address) ;;0x18 ;; set frequency-low-bits
233 0x2A]] ;; load duration
234 (replace
235 {:note-length (count play-note)}
236 (concat switch play-note)))))
238 (defn play-noise
239 "read [noise-code, volume, duration] and play the noise. Duration is left in
240 A, and HL is advanced appropraitely."
241 ([]
242 [0x2A ;; load noise-code into A
243 0xE0
244 0x22 ;; write noise-code
246 0x2A ;; load volume
247 0xE0
248 0x21 ;; write volume
250 0x2A] ;; load duration into A
251 ))
254 ;; (defn play-note
255 ;; "Play the note referenced by HL in the appropiate channel.
256 ;; Leaves desired-duration in A."
258 ;; [0x2A ;; load volume/frequency-high info
259 ;; 0xF5 ;; push A
260 ;; 0xE6
261 ;; (Integer/parseInt "11110000" 2) ;; volume mask
262 ;; 0xE0
263 ;; 0x17 ;; set volume
264 ;; 0xF1 ;; pop A
265 ;; 0xE6
266 ;; (Integer/parseInt "00000111" 2) ;; frequency-high mask
267 ;; 0xE0
268 ;; 0x19 ;; set frequency-high
270 ;; 0x2A ;; load frequency low-bits
271 ;; 0xE0
272 ;; 0x18 ;; set frequency-low-bits
274 ;; 0x2A ;; load duration
275 ;; ])
277 (defn music-step [sound-base-address wave-duty noise?]
278 ;; C == current-ticks
279 ;; A == desired-ticks
281 (flatten
282 [;; restore variables from stack
283 0xE1 ;; pop HL
284 0xC1 ;; pop CB
285 0xF1 ;; pop AF
288 0xF5 ;; push A
289 0xF0
290 0x05 ;; load current ticks from 0xF005
291 0xB8 ;;
292 0x30 ;; increment C only if last result caused carry
293 0x01
294 0x0C
296 0x47 ;; update sub-ticks (A->B)
298 0xF1 ;; pop AF, now A contains desired-ticks
300 0xB9 ;; compare with current ticks
302 ;; if desired-ticks = current ticks
303 ;; go to next note ; set current set ticks to 0.
305 (if noise?
306 [0x20
307 (+ 2 (count (play-noise)))
308 (play-noise)]
310 [0x20
311 (+ (count (do-message 0 0)) 2)
312 (do-message sound-base-address wave-duty)])
314 0x0E
315 0x00 ;; 0->C (current-ticks)
317 ;; save variables to stack
318 0xF5 ;; push AF
319 0xC5 ;; push CB
320 0xE5 ;; push HL
323 ]))
325 (def music-1 0x11)
326 (def music-2 0x16)
328 (defn music-kernel
329 [voice-1-address
330 voice-2-address
331 noise-address
332 voice-1-wave-duty
333 voice-2-wave-duty]
334 (flatten
335 [;; global initilization section
336 (clear-music-registers)
338 0x3E
339 0x01
340 0xE0
341 0x06 ;; set TMA to 0
343 0x3E
344 (Integer/parseInt "00000110" 2)
345 0xE0
346 0x07 ;; set TAC to 65536 Hz and activate timer
348 ;; initialize frame 1
349 0x21
350 (reverse (disect-bytes-2 voice-1-address))
351 ;; set HL to voice-1-address
352 0x0E
353 0x00 ;; 0->C
354 0x06
355 0x00 ;; 0->B
357 0xAF ;; 0->A
359 0xF5 ;; push AF
360 0xC5 ;; push CB
361 0xE5 ;; push HL
363 ;; initialize frame 2
364 0x21
365 (reverse (disect-bytes-2 voice-2-address))
366 ;; set HL to voice-2-address
368 0xF5 ;; push AF
369 0xC5 ;; push CB
370 0xE5 ;; push HL
373 ;; initialize frame 3 (noise)
374 0x21
375 (reverse (disect-bytes-2 noise-address))
376 ;; set HL to noise-address
378 0xF5 ;; push AF
379 0xC5 ;; push CB
380 0xE5 ;; push HL
382 ;; main music loop
384 0xE8 ;; SP + 12; activate frame 1
385 12
386 (music-step music-1 voice-1-wave-duty false)
388 0xE8 ;; SP - 6; activate frame 2
389 (->signed-8-bit -6)
390 (music-step music-2 voice-1-wave-duty false)
392 0xE8 ;; SP - 6; activate frame 3
393 (->signed-8-bit -6)
394 (music-step nil nil true)
396 0x18
397 (->signed-8-bit (+
398 ;; two music-steps
399 (- (* 2 (count (music-step 0 0 false))))
400 ;; one noise
401 (- (count (music-step nil nil true)))
402 -2 ;; this jump instruction
403 -2 ;; activate frame 1
404 -2 ;; activate frame 2
405 -2 ;; activate frame 3
406 ))]))
408 (defn frequency-code->frequency
409 [code]
410 (assert (<= 0 code 2047))
411 (/ 131072 (- 2048 code)))
413 (defn clamp [x low high]
414 (cond (> x high) high
415 (< x low) low
416 true x))
418 (defn frequency->frequency-code
419 [frequency]
420 (clamp
421 (Math/round
422 (float
423 (/ (- (* 2048 frequency) 131072) frequency)))
424 0x00 2048))
426 (defn note-codes [frequency volume duration]
427 (assert (<= 0 volume 0xF))
428 (if (<= duration 0xFF)
429 (let [frequency-code
430 (frequency->frequency-code frequency)
431 volume&high-frequency
432 (+ (bit-shift-left volume 4)
433 (bit-shift-right frequency-code 8))
434 low-frequency
435 (bit-and 0xFF frequency-code)]
436 [note-code
437 volume&high-frequency
438 low-frequency
439 duration])
440 (vec
441 (flatten
442 [(note-codes frequency volume 0xFF)
443 (note-codes frequency volume (- duration 0xFF))]))))
446 (defn midi-code->frequency
447 [midi-code]
448 (* 8.1757989156
449 (Math/pow 2 (* (float (/ 12)) midi-code))))
451 ;; division == clock-pulses / quarter-note
452 ;; tempo == microseconds / quarter-note
454 ;; have: clock-pulses
455 ;; want: seconds
458 (defn silent-note [length]
459 {:frequency 1
460 :duration length
461 :volume 0})
463 (defn commands
464 "return all events where #(= (:command %) command)"
465 [command s]
466 (filter #(= command (:command %)) s))
468 (defn track-info [#^File midi-file]
469 (let [events (parse-midi midi-file)
470 track-titles (commands :Title_t events)
471 track-info
472 (map #(read-string (read-string (:args %))) track-titles)
473 track-map
474 (zipmap track-info track-titles)]
475 track-map))
477 (defn target-tracks
478 "return the track-numbers in the form [voice-0 voice-1 noise]"
479 [#^File midi-file]
480 (let [track-data (track-info midi-file)
481 track-order
482 (zipmap (map :out (keys track-data))
483 (vals track-data))
484 channel-nums (map (comp :channel track-order) (range 3))]
485 channel-nums))
487 (defn midi-track->abstract-mini-midi
488 [#^File midi-file track-num]
489 (let [midi-events (parse-midi midi-file)
491 note-on-events (commands :Note_on_c midi-events)
492 note-off-events (commands :Note_off_c midi-events)
494 select-channel
495 (fn [n s]
496 (sort-by :time (filter #(= n (:channel %)) s)))
498 channel-on (select-channel track-num note-on-events)
500 channel-off (select-channel track-num note-off-events)
503 tempo (:args (first (commands :Tempo midi-events)))
504 division
505 (:division (:args (first (commands :Header midi-events))))
507 notes
508 (map
509 (fn [note-on note-off]
510 {:frequency (midi-code->frequency (:note (:args note-on)))
511 :midi-code (:note (:args note-on))
512 :duration
513 (/ (* (/ tempo division)
514 (- (:time note-off) (:time note-on)))
515 1e6) ;; convert clock-pulses into seconds
516 :volume (int (/ (:velocity (:args note-on)) 10))
517 :time-stamp (/ (* (/ tempo division)
518 (:time note-on)) 1e6)})
519 channel-on channel-off)
521 silences
522 (map (fn [note-1 note-2]
523 (let [note-1-space (- (:time-stamp note-2)
524 (:time-stamp note-1))
525 note-1-length (:duration note-1)]
526 (silent-note (- note-1-space note-1-length))))
527 ;; to handle silence at the beginning.
528 (concat [(assoc (silent-note 0)
529 :time-stamp 0)] notes)
530 notes)
532 notes-with-silence
533 (concat
534 (filter (comp not zero? :duration)
535 (interleave silences notes))
536 [(silent-note 3)])]
537 notes-with-silence))
539 (defn midi-track->mini-midi-voice [#^File midi-file track-num]
540 (let [abstract-mini-midi
541 (midi-track->abstract-mini-midi midi-file track-num)]
542 (map
543 (fn [note-event]
544 (note-codes (:frequency note-event)
545 (:volume note-event)
546 (int (* (:duration note-event) 0x100))))
547 abstract-mini-midi)))
549 (def midi-code->gb-noise-code
550 {nil 0xFF
551 35 90
552 38 20
553 39 0
554 })
556 (defn noise-codes [code volume duration]
557 (assert (<= 0 volume 0xF))
558 (if (<= duration 0xFF)
559 [(midi-code->gb-noise-code code code)
560 (bit-shift-left volume 4)
561 duration]
562 (vec
563 (flatten
564 [(noise-codes code volume 0xFF)
565 (noise-codes code volume (- duration 0xFF))]))))
567 (defn midi-track->mini-midi-noise [#^File midi-file track-num]
568 (let [abstract-mini-midi
569 (midi-track->abstract-mini-midi midi-file track-num)]
570 (map
571 (fn [noise-event]
572 (noise-codes (:midi-code noise-event)
573 (:volume noise-event)
574 (int (* (:duration noise-event) 0x100))))
575 abstract-mini-midi)))
578 (defn midi->mini-midi [#^File midi-file]
579 (let [targets (target-tracks midi-file)
580 duty-info (keys (track-info midi-file))]
582 {:voice-1 (midi-track->mini-midi-voice midi-file (nth targets 0))
583 :voice-2 (midi-track->mini-midi-voice midi-file (nth targets 1))
584 :noise (midi-track->mini-midi-noise midi-file (nth targets 2))
585 :duty (zipmap (map :out duty-info)
586 (map #(get % :duty 0) duty-info))}))
588 (defn midi-bytes
589 ([^File midi-file program-target
590 voice-1-target voice-2-target noise-target]
591 (let [mini-midi (midi->mini-midi midi-file)
592 long-silence (flatten (note-codes 20 0 3000))
593 long-noise-silence
594 (interleave (range 20) (repeat 0x00) (repeat 255))
595 voice-1 (flatten (:voice-1 mini-midi))
596 wave-duty-1 ((:duty mini-midi) 0 0)
598 voice-2 (flatten (:voice-2 mini-midi))
599 wave-duty-2 ((:duty mini-midi) 1 0)
601 noise (flatten (:noise mini-midi))
602 kernel (music-kernel
603 voice-1-target
604 voice-2-target
605 noise-target
606 wave-duty-1 wave-duty-2)]
608 {:voice-1 {:address voice-1-target
609 :data (concat voice-1 long-silence)}
610 :voice-2 {:address voice-2-target
611 :data (concat voice-2 long-silence)}
612 :noise {:address noise-target
613 :data (concat noise long-noise-silence)}
614 :kernel {:address program-target
615 :data kernel}}))
616 ([^File midi-file]
617 (midi-bytes midi-file 0xC000 0xC400 0xC800 0xCC00)))
619 (defn play-midi [^File midi-file]
620 (let [bytes (midi-bytes midi-file)]
621 (-> (second (music-base))
622 (set-memory-range
623 (:address (:voice-1 bytes)) (:data (:voice-1 bytes)))
624 (set-memory-range
625 (:address (:voice-2 bytes)) (:data (:voice-2 bytes)))
626 (set-memory-range
627 (:address (:noise bytes)) (:data (:noise bytes)))
628 (set-memory-range
629 (:address (:kernel bytes)) (:data (:kernel bytes)))
630 (PC! (:address (:kernel bytes))))))
632 (defn test-noise []
633 (let [noise-pattern
634 (concat (interleave (range 0x100) (repeat 0xF0) (repeat 255))
635 (interleave (range 10) (repeat 0x00) (repeat 255)))]
637 (-> (second (music-base))
638 (set-memory-range 0xA900 (flatten noise-pattern))
639 (set-memory-range 0xC000 (music-kernel 0 0))
640 (PC! 0xC000))))
642 (defn test-play-noise [noise-code]
643 (Thread/sleep 300)
644 (println "playing noise:" noise-code)
645 (run-moves
646 (let [noise-pattern
647 (interleave (repeat 10 noise-code) (repeat 0xF0) (repeat 255))]
648 (-> (second (music-base))
649 (set-memory-range 0xA900 (flatten noise-pattern))
650 (set-memory-range 0xC000 (music-kernel 0 0))
651 (PC! 0xC000)))
652 (repeat 20 [])))
654 (defn test-all-noises []
655 (dorun (map test-play-noise (range 0x100))))
657 (def C4 (partial note-codes 261.63))
658 (def D4 (partial note-codes 293.66))
659 (def E4 (partial note-codes 329.63))
660 (def F4 (partial note-codes 349.23))
661 (def G4 (partial note-codes 392))
662 (def A4 (partial note-codes 440))
663 (def B4 (partial note-codes 493.88))
664 (def C5 (partial note-codes 523.3))
666 (def scale
667 (flatten
668 [(C4 0xF 0x40)
669 (D4 0xF 0x40)
670 (E4 0xF 0x40)
671 (F4 0xF 0x40)
672 (G4 0xF 0x40)
673 (A4 0xF 0x40)
674 (B4 0xF 0x40)
675 (C5 0xF 0x40)]))
677 (defn play-music [music-bytes]
678 (let [program-target 0xC000
679 music-target 0xA000]
680 (-> (set-memory-range (second (music-base))
681 program-target (music-kernel))
682 (set-memory-range music-target music-bytes)
683 (PC! program-target))))
685 (defn run-program
686 ([program]
687 (let [target 0xC000]
688 (-> (set-memory-range (second (music-base))
689 target program)
690 (PC! target)))))
692 (defn test-timer []
693 (flatten
694 [0x3E
695 0x01
696 0xE0
697 0x06 ;; set TMA to 0
699 0x3E
700 (Integer/parseInt "00000100" 2)
701 0xE0
702 0x07 ;; set TAC to 16384 Hz and activate timer
704 (repeat
705 500
706 [0xF0
707 0x05])]))
709 (defn play-pony []
710 (println "playing" (.getName pony-csv))
711 (run-moves (play-midi pony-csv) (repeat 1800 [])))
713 (defn play-regret []
714 (println "playing" (.getName regret-csv))
715 (run-moves (play-midi regret-csv) (repeat 3380 [])))
717 (defn play-mother []
718 (println "playing" (.getName mother-csv))
719 (run-moves (play-midi mother-csv) (repeat 2200 [])))
721 (defn demo [] (play-mother) (play-regret) (play-pony))