Mercurial > vba-clojure

annotate clojure/com/aurellem/run/music.clj @ 454:bf87b87a4ad7

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
exporting to midi file.
author Robert McIntyre <rlm@mit.edu>
date Thu, 03 May 2012 07:25:06 -0500
parents 067ea3f0d951
children 1c10fa8366a7
rev   line source
rlm@417 1 (ns com.aurellem.run.music
rlm@417 2 (:use (com.aurellem.gb saves gb-driver util constants
rlm@417 3 items vbm characters money
rlm@417 4 rlm-assembly))
rlm@417 5 (:use (com.aurellem.run util title save-corruption
rlm@417 6 bootstrap-0 bootstrap-1))
rlm@426 7 (:require clojure.string)
rlm@426 8 (:import [com.aurellem.gb.gb_driver SaveState])
rlm@426 9 (:import java.io.File))
rlm@417 10
rlm@427 11 (def third-kind
rlm@427 12 (File. "/home/r/proj/midi/third-kind.mid"))
rlm@417 13
rlm@454 14 (def pony "/home/r/proj/vba-clojure/music/pony-title.mid")
rlm@454 15
rlm@427 16 (defn raw-midi-text [#^File midi-file]
rlm@427 17 (:out
rlm@427 18 (clojure.java.shell/sh
rlm@427 19 "midicsv"
rlm@427 20 (.getCanonicalPath midi-file)
rlm@427 21 "-")))
rlm@427 22
rlm@427 23 (def command-line #"^(\d+), (\d+), ([^,]+)(.*)$")
rlm@427 24
rlm@427 25 (defmulti parse-command :command)
rlm@427 26
rlm@427 27 (defn discard-args [command] (dissoc command :args))
rlm@427 28
rlm@427 29 (defmethod parse-command :Start_track
rlm@427 30 [command] (discard-args command))
rlm@427 31
rlm@427 32 (defmethod parse-command :End_track
rlm@427 33 [command] (discard-args command))
rlm@427 34
rlm@427 35 (defmethod parse-command :default
rlm@427 36 [command] command)
rlm@427 37
rlm@427 38 (defn parse-number-list
rlm@427 39 [number-list-str]
rlm@427 40 (map #(Integer/parseInt %)
rlm@427 41 (clojure.string/split number-list-str #", ")))
rlm@427 42
rlm@427 43 (defmethod parse-command :Tempo
rlm@427 44 [command]
rlm@427 45 (update-in command [:args] #(Integer/parseInt %)))
rlm@427 46
rlm@427 47 (defn parse-midi-note-list
rlm@427 48 [midi-note-list-str]
rlm@427 49 (let [[channel note velocity]
rlm@427 50 (parse-number-list midi-note-list-str)]
rlm@427 51 {:channel channel :note note :velocity velocity}))
rlm@427 52
rlm@427 53 (defmethod parse-command :Note_on_c
rlm@427 54 [command]
rlm@427 55 (update-in command [:args] parse-midi-note-list))
rlm@427 56
rlm@427 57 (defmethod parse-command :Note_off_c
rlm@427 58 [command]
rlm@427 59 (update-in command [:args] parse-midi-note-list))
rlm@427 60
rlm@427 61 (defmethod parse-command :Header
rlm@427 62 [command]
rlm@427 63 (let [args (:args command)
rlm@427 64 [format num-tracks division] (parse-number-list args)]
rlm@427 65 (assoc command :args
rlm@427 66 {:format format
rlm@427 67 :num-tracks num-tracks
rlm@427 68 :division division})))
rlm@427 69
rlm@427 70 (defmethod parse-command :Program_c
rlm@427 71 [command]
rlm@427 72 (let [args (:args command)
rlm@427 73 [channel program-num] (parse-number-list args)]
rlm@427 74 (assoc command :args
rlm@427 75 {:channel channel
rlm@427 76 :program-num program-num})))
rlm@427 77
rlm@427 78 (defn parse-midi [#^File midi-file]
rlm@427 79 (map
rlm@427 80 (comp parse-command
rlm@427 81 (fn [line]
rlm@427 82 (let [[[_ channel time command args]]
rlm@427 83 (re-seq command-line line)]
rlm@427 84 {:channel (Integer/parseInt channel)
rlm@427 85 :time (Integer/parseInt time)
rlm@427 86 :command (keyword command)
rlm@427 87 :args (apply str (drop 2 args))})))
rlm@427 88 (drop-last
rlm@427 89 (clojure.string/split-lines
rlm@427 90 (raw-midi-text midi-file)))))
rlm@427 91
rlm@417 92 (def music-base new-kernel)
rlm@417 93
rlm@417 94 (defn store [n address]
rlm@417 95 (flatten
rlm@417 96 [0xF5
rlm@417 97 0xE5
rlm@417 98
rlm@417 99 0x3E
rlm@417 100 n
rlm@417 101
rlm@417 102 0x21
rlm@417 103 (reverse (disect-bytes-2 address))
rlm@417 104
rlm@417 105 0x77
rlm@417 106
rlm@417 107 0xE1
rlm@417 108 0xF1]))
rlm@417 109
rlm@417 110 (defn infinite-loop []
rlm@417 111 [0x18 0xFE])
rlm@417 112
rlm@417 113 (def divider-register 0xFF04)
rlm@417 114
rlm@417 115 (defrecord Bit-Note [frequency volume duration duty])
rlm@417 116
rlm@417 117 (defn clear-music-registers []
rlm@417 118 (flatten
rlm@433 119 [(store (Integer/parseInt "00000000" 2) 0xFF10) ;; sweep
rlm@433 120 (store (Integer/parseInt "00000000" 2) 0xFF11) ;; pattern duty
rlm@433 121 (store (Integer/parseInt "00000000" 2) 0xFF12) ;; volume
rlm@433 122 (store (Integer/parseInt "00000000" 2) 0xFF13) ;; frequency-low
rlm@433 123 (store (Integer/parseInt "00000000" 2) 0xFF14) ;; frequency-high
rlm@417 124
rlm@417 125 (store (Integer/parseInt "00000000" 2) 0xFF16) ;; pattern duty 000000
rlm@417 126 (store (Integer/parseInt "00000000" 2) 0xFF17) ;; volume 0000
rlm@417 127 (store (Integer/parseInt "00000000" 2) 0xFF18) ;; frequency-low
rlm@417 128 (store (Integer/parseInt "00000000" 2) 0xFF19) ;; 00000 frequency-high
rlm@417 129
rlm@417 130 (store (Integer/parseInt "00000000" 2) 0xFF1A)
rlm@417 131 (store (Integer/parseInt "00000000" 2) 0xFF1B)
rlm@417 132 (store (Integer/parseInt "00000000" 2) 0xFF1C)
rlm@417 133 (store (Integer/parseInt "00000000" 2) 0xFF1D)
rlm@417 134 (store (Integer/parseInt "00000000" 2) 0xFF1E)
rlm@417 135
rlm@433 136 (store (Integer/parseInt "00000000" 2) 0xFF20) ;; length
rlm@433 137 (store (Integer/parseInt "00000000" 2) 0xFF21) ;; volume
rlm@433 138 (store (Integer/parseInt "00000000" 2) 0xFF22) ;; noise-frequency
rlm@433 139 (store (Integer/parseInt "00000000" 2) 0xFF23) ;; control
rlm@433 140 ]))
rlm@417 141
rlm@424 142
rlm@424 143 ;; mini-midi syntax
rlm@424 144
rlm@424 145 ;; codes
rlm@424 146 ;; note-code == 0x00
rlm@424 147 ;; change-duty-code = 0x01
rlm@424 148 ;; silence-code = 0x02
rlm@424 149
rlm@424 150 ;; silence format
rlm@424 151 ;; 2 bytes
rlm@424 152 ;; [silence-code (0x02)]
rlm@424 153 ;; [duration-8-bits]
rlm@424 154
rlm@424 155 ;; note data format
rlm@424 156 ;; 4 bytes
rlm@424 157 ;; [note-code (0x00)]
rlm@424 158 ;; [volume-4-bits 0 frequency-high-3-bits]
rlm@424 159 ;; [frequengy-low-8-bits]
rlm@424 160 ;; [duration-8-bits]
rlm@424 161
rlm@424 162 ;; change-duty-format
rlm@424 163 ;; 2 bytes
rlm@424 164 ;; [change-duty-code (0x01)]
rlm@424 165 ;; [new-duty]
rlm@424 166
rlm@425 167 (def note-code 0x00)
rlm@425 168 (def change-duty-code 0x01)
rlm@425 169 (def silence-code 0x02)
rlm@425 170
rlm@424 171 (defn do-message
rlm@424 172 "Read the message which starts at the current value of HL and do
rlm@424 173 what it says. Duration is left in A, and HL is advanced
rlm@424 174 appropraitely."
rlm@433 175 ([] (do-message 0x16))
rlm@433 176 ([sound-base-address]
rlm@433 177 (let [switch
rlm@433 178 [0x2A ;; load message code into A, increment HL
rlm@433 179
rlm@433 180 ;; switch on message
rlm@433 181 0xFE
rlm@433 182 note-code
rlm@433 183
rlm@433 184 0x20
rlm@433 185 :note-length]
rlm@424 186
rlm@433 187 play-note
rlm@433 188 [0x2A ;; load volume/frequency-high info
rlm@433 189 0xF5 ;; push A
rlm@433 190 0xE6
rlm@433 191 (Integer/parseInt "11110000" 2) ;; volume mask
rlm@433 192 0xE0
rlm@433 193 (inc sound-base-address) ;;0x17 ;; set volume
rlm@433 194 0xF1 ;; pop A
rlm@433 195 0xE6
rlm@433 196 (Integer/parseInt "00000111" 2) ;; frequency-high mask
rlm@433 197 0xE0
rlm@433 198 (+ 3 sound-base-address) ;;0x19 ;; set frequency-high
rlm@433 199
rlm@433 200 0x2A ;; load frequency low-bits
rlm@433 201 0xE0
rlm@433 202 (+ 2 sound-base-address) ;;0x18 ;; set frequency-low-bits
rlm@433 203 0x2A]] ;; load duration
rlm@433 204 (replace
rlm@433 205 {:note-length (count play-note)}
rlm@433 206 (concat switch play-note)))))
rlm@424 207
rlm@433 208 ;; (defn play-note
rlm@433 209 ;; "Play the note referenced by HL in the appropiate channel.
rlm@433 210 ;; Leaves desired-duration in A."
rlm@433 211
rlm@433 212 ;; [0x2A ;; load volume/frequency-high info
rlm@433 213 ;; 0xF5 ;; push A
rlm@433 214 ;; 0xE6
rlm@433 215 ;; (Integer/parseInt "11110000" 2) ;; volume mask
rlm@433 216 ;; 0xE0
rlm@433 217 ;; 0x17 ;; set volume
rlm@433 218 ;; 0xF1 ;; pop A
rlm@433 219 ;; 0xE6
rlm@433 220 ;; (Integer/parseInt "00000111" 2) ;; frequency-high mask
rlm@433 221 ;; 0xE0
rlm@433 222 ;; 0x19 ;; set frequency-high
rlm@417 223
rlm@433 224 ;; 0x2A ;; load frequency low-bits
rlm@433 225 ;; 0xE0
rlm@433 226 ;; 0x18 ;; set frequency-low-bits
rlm@417 227
rlm@433 228 ;; 0x2A ;; load duration
rlm@433 229 ;; ])
rlm@417 230
rlm@434 231 (defn music-step [sound-base-address]
rlm@432 232 ;; C == current-ticks
rlm@432 233 ;; A == desired-ticks
rlm@435 234
rlm@435 235 (flatten
rlm@435 236 [;; restore variables from stack
rlm@435 237 0xE1 ;; pop HL
rlm@435 238 0xC1 ;; pop CB
rlm@435 239 0xF1 ;; pop AF
rlm@432 240
rlm@435 241
rlm@435 242 0xF5 ;; push A
rlm@417 243 0xF0
rlm@432 244 0x05 ;; load current ticks from 0xF005
rlm@431 245 0xB8 ;;
rlm@417 246 0x30 ;; increment C only if last result caused carry
rlm@417 247 0x01
rlm@418 248 0x0C
rlm@417 249
rlm@417 250 0x47 ;; update sub-ticks (A->B)
rlm@417 251
rlm@417 252 0xF1 ;; pop AF, now A contains desired-ticks
rlm@417 253
rlm@417 254 0xB9 ;; compare with current ticks
rlm@417 255
rlm@417 256 ;; if desired-ticks = current ticks
rlm@417 257 ;; go to next note ; set current set ticks to 0.
rlm@417 258
rlm@417 259 0x20
rlm@434 260 (+ (count (do-message 0)) 2)
rlm@417 261
rlm@434 262 (do-message sound-base-address)
rlm@417 263
rlm@417 264 0x0E
rlm@435 265 0x00 ;; 0->C (current-ticks)
rlm@417 266
rlm@435 267 ;; save variables to stack
rlm@435 268 0xF5 ;; push AF
rlm@435 269 0xC5 ;; push CB
rlm@435 270 0xE5 ;; push HL
rlm@435 271
rlm@435 272
rlm@435 273 ]))
rlm@435 274
rlm@435 275 (def music-1 0x11)
rlm@434 276 (def music-2 0x16)
rlm@434 277
rlm@417 278 (defn music-kernel []
rlm@417 279 (flatten
rlm@432 280 [;; global initilization section
rlm@432 281 (clear-music-registers)
rlm@432 282
rlm@417 283 0x3E
rlm@418 284 0x01
rlm@417 285 0xE0
rlm@417 286 0x06 ;; set TMA to 0
rlm@417 287
rlm@417 288 0x3E
rlm@423 289 (Integer/parseInt "00000110" 2)
rlm@417 290 0xE0
rlm@423 291 0x07 ;; set TAC to 65536 Hz and activate timer
rlm@417 292
rlm@435 293 ;; initialize frame 1
rlm@432 294 0x21
rlm@432 295 0x00
rlm@437 296 0xA0 ;; set HL to 0xA000 == music-start 1
rlm@432 297 0x0E
rlm@432 298 0x00 ;; 0->C
rlm@432 299 0x06
rlm@432 300 0x00 ;; 0->B
rlm@435 301
rlm@433 302 0xAF ;; 0->A
rlm@432 303
rlm@435 304 0xF5 ;; push AF
rlm@435 305 0xC5 ;; push CB
rlm@435 306 0xE5 ;; push HL
rlm@432 307
rlm@435 308 ;; initialize frame 2
rlm@436 309 0x21
rlm@436 310 0x00
rlm@437 311 0xB0 ;; set HL to 0xB000 == music-start 2
rlm@436 312
rlm@436 313 0xF5 ;; push AF
rlm@436 314 0xC5 ;; push CB
rlm@436 315 0xE5 ;; push HL
rlm@436 316
rlm@436 317
rlm@437 318 ;; main music loop
rlm@437 319
rlm@437 320 0xE8 ;; SP + 6; activate frame 1
rlm@437 321 6
rlm@437 322 (music-step music-1)
rlm@437 323 ;;(repeat (count (music-step music-1)) 0x00)
rlm@435 324
rlm@437 325 0xE8 ;; SP - 6; activate frame 2
rlm@437 326 (->signed-8-bit -6)
rlm@437 327 ;;(repeat (count (music-step music-2)) 0x00)
rlm@437 328 (music-step music-2)
rlm@433 329
rlm@424 330
rlm@417 331 0x18
rlm@437 332 (->signed-8-bit (+
rlm@437 333 ;; two music-steps
rlm@437 334 (- (* 2 (count (music-step 0))))
rlm@437 335 -2 ;; this jump instruction
rlm@437 336 -2 ;; activate frame 1
rlm@437 337 -2 ;; activate frame 2
rlm@437 338 ))]))
rlm@417 339
rlm@424 340 (defn frequency-code->frequency
rlm@424 341 [code]
rlm@424 342 (assert (<= 0 code 2047))
rlm@424 343 (/ 131072 (- 2048 code)))
rlm@424 344
rlm@424 345 (defn clamp [x low high]
rlm@424 346 (cond (> x high) high
rlm@424 347 (< x low) low
rlm@424 348 true x))
rlm@424 349
rlm@424 350 (defn frequency->frequency-code
rlm@424 351 [frequency]
rlm@424 352 (clamp
rlm@424 353 (Math/round
rlm@424 354 (float
rlm@424 355 (/ (- (* 2048 frequency) 131072) frequency)))
rlm@424 356 0x00 2048))
rlm@424 357
rlm@424 358 (defn note-codes [frequency volume duration]
rlm@424 359 (assert (<= 0 volume 0xF))
rlm@430 360 (if (<= duration 0xFF)
rlm@430 361 (let [frequency-code
rlm@430 362 (frequency->frequency-code frequency)
rlm@430 363 volume&high-frequency
rlm@430 364 (+ (bit-shift-left volume 4)
rlm@430 365 (bit-shift-right frequency-code 8))
rlm@430 366 low-frequency
rlm@430 367 (bit-and 0xFF frequency-code)]
rlm@430 368 [note-code
rlm@430 369 volume&high-frequency
rlm@430 370 low-frequency
rlm@430 371 duration])
rlm@430 372 (vec
rlm@430 373 (flatten
rlm@430 374 [(note-codes frequency volume 0xFF)
rlm@430 375 (note-codes frequency volume (- duration 0xFF))]))))
rlm@430 376
rlm@424 377
rlm@427 378 (defn midi-code->frequency
rlm@427 379 [midi-code]
rlm@427 380 (* 8.1757989156
rlm@427 381 (Math/pow 2 (* (float (/ 12)) midi-code))))
rlm@427 382
rlm@427 383 ;; division == clock-pulses / quarter-note
rlm@427 384 ;; tempo == microseconds / quarter-note
rlm@427 385
rlm@427 386 ;; have: clock-pulses
rlm@427 387 ;; want: seconds
rlm@427 388
rlm@427 389
rlm@428 390 (defn silence [length]
rlm@428 391 {:frequency 1
rlm@428 392 :duration length
rlm@428 393 :volume 0})
rlm@427 394
rlm@438 395 (defn commands
rlm@438 396 "return all events where #(= (:command %) command)"
rlm@438 397 [command s]
rlm@438 398 (filter #(= command (:command %)) s))
rlm@438 399
rlm@438 400 (defn midi-track->mini-midi [#^File midi-file track-num]
rlm@427 401 (let [midi-events (parse-midi midi-file)
rlm@427 402
rlm@438 403 note-on-events (commands :Note_on_c midi-events)
rlm@438 404 note-off-events (commands :Note_off_c midi-events)
rlm@427 405
rlm@438 406 select-channel
rlm@438 407 (fn [n s]
rlm@438 408 (sort-by :time (filter #(= n (:channel (:args %))) s)))
rlm@438 409
rlm@438 410 channel-on (select-channel track-num note-on-events)
rlm@427 411
rlm@438 412 channel-off (select-channel track-num note-off-events)
rlm@427 413
rlm@438 414
rlm@438 415 tempo (:args (first (commands :Tempo midi-events)))
rlm@438 416 division
rlm@438 417 (:division (:args (first (commands :Header midi-events))))
rlm@428 418
rlm@428 419 notes
rlm@428 420 (map
rlm@428 421 (fn [note-on note-off]
rlm@428 422 {:frequency (midi-code->frequency (:note (:args note-on)))
rlm@428 423 :duration
rlm@428 424 (/ (* (/ tempo division)
rlm@428 425 (- (:time note-off) (:time note-on)))
rlm@428 426 1e6) ;; convert clock-pulses into seconds
rlm@428 427 :volume (int (/ (:velocity (:args note-on)) 10))
rlm@428 428 :time-stamp (/ (* (/ tempo division)
rlm@428 429 (:time note-on)) 1e6)})
rlm@438 430 channel-on channel-off)
rlm@428 431
rlm@428 432 silences
rlm@428 433 (map (fn [note-1 note-2]
rlm@428 434 (let [note-1-space (- (:time-stamp note-2)
rlm@428 435 (:time-stamp note-1))
rlm@428 436 note-1-length (:duration note-1)]
rlm@428 437 (silence (- note-1-space note-1-length))))
rlm@428 438 ;; to handle silence at the beginning.
rlm@428 439 (concat [(assoc (silence 0)
rlm@428 440 :time-stamp 0)] notes)
rlm@428 441 notes)
rlm@428 442
rlm@428 443 notes-with-silence
rlm@438 444 (filter (comp not zero? :duration)
rlm@438 445 (interleave silences notes))]
rlm@427 446 (map
rlm@427 447 (fn [note-event]
rlm@427 448 (note-codes (:frequency note-event)
rlm@427 449 (:volume note-event)
rlm@427 450 (int (* (:duration note-event) 0x100))))
rlm@428 451 notes-with-silence)))
rlm@428 452
rlm@438 453 (defn midi->mini-midi [#^File midi-file]
rlm@438 454 {:track-1 (flatten (midi-track->mini-midi midi-file 1))
rlm@438 455 :track-2 (flatten (midi-track->mini-midi midi-file 2))})
rlm@438 456
rlm@438 457 (defn play-midi [#^File midi-file]
rlm@438 458 (let [track-1-target 0xA000
rlm@438 459 track-2-target 0xB000
rlm@438 460 program-target 0xC000
rlm@438 461 mini-midi (midi->mini-midi midi-file)
rlm@438 462 long-silence (flatten (note-codes 20 0 9001))]
rlm@438 463
rlm@438 464 (-> (second (music-base))
rlm@438 465 (set-memory-range track-1-target long-silence)
rlm@438 466 (set-memory-range track-2-target long-silence)
rlm@438 467 (set-memory-range track-1-target (:track-1 mini-midi))
rlm@438 468 (set-memory-range track-2-target (:track-2 mini-midi))
rlm@438 469 (set-memory-range program-target (music-kernel))
rlm@438 470 (PC! program-target))))
rlm@438 471
rlm@438 472
rlm@438 473
rlm@428 474
rlm@424 475 (def C4 (partial note-codes 261.63))
rlm@424 476 (def D4 (partial note-codes 293.66))
rlm@424 477 (def E4 (partial note-codes 329.63))
rlm@424 478 (def F4 (partial note-codes 349.23))
rlm@424 479 (def G4 (partial note-codes 392))
rlm@424 480 (def A4 (partial note-codes 440))
rlm@424 481 (def B4 (partial note-codes 493.88))
rlm@424 482 (def C5 (partial note-codes 523.3))
rlm@424 483
rlm@430 484 (def scale
rlm@430 485 (flatten
rlm@430 486 [(C4 0xF 0x40)
rlm@430 487 (D4 0xF 0x40)
rlm@430 488 (E4 0xF 0x40)
rlm@430 489 (F4 0xF 0x40)
rlm@430 490 (G4 0xF 0x40)
rlm@430 491 (A4 0xF 0x40)
rlm@430 492 (B4 0xF 0x40)
rlm@430 493 (C5 0xF 0x40)]))
rlm@424 494
rlm@418 495 (defn play-music [music-bytes]
rlm@417 496 (let [program-target 0xC000
rlm@437 497 music-target 0xA000]
rlm@417 498 (-> (set-memory-range (second (music-base))
rlm@417 499 program-target (music-kernel))
rlm@417 500 (set-memory-range music-target music-bytes)
rlm@417 501 (PC! program-target))))
rlm@417 502
rlm@417 503
rlm@438 504
rlm@437 505 ;; (defn test-note [music-bytes]
rlm@437 506 ;; (-> (set-memory-range (second (music-base))
rlm@437 507 ;; 0xC000 (concat (clear-music-registers)
rlm@437 508 ;; (play-note)
rlm@437 509 ;; (infinite-loop)))
rlm@437 510 ;; (set-memory-range 0xD000 music-bytes)
rlm@437 511 ;; (PC! 0xC000)
rlm@437 512 ;; (HL! 0xD000)
rlm@437 513 ;; ))
rlm@417 514
rlm@417 515
rlm@417 516 (defn run-program
rlm@418 517 ([program]
rlm@417 518 (let [target 0xC000]
rlm@417 519 (-> (set-memory-range (second (music-base))
rlm@417 520 target program)
rlm@417 521 (PC! target)))))
rlm@417 522
rlm@424 523 (defn test-timer []
rlm@424 524 (flatten
rlm@424 525 [0x3E
rlm@424 526 0x01
rlm@424 527 0xE0
rlm@424 528 0x06 ;; set TMA to 0
rlm@424 529
rlm@424 530 0x3E
rlm@424 531 (Integer/parseInt "00000100" 2)
rlm@424 532 0xE0
rlm@424 533 0x07 ;; set TAC to 16384 Hz and activate timer
rlm@424 534
rlm@424 535 (repeat
rlm@424 536 500
rlm@424 537 [0xF0
rlm@424 538 0x05])]))
rlm@426 539
rlm@426 540