Mercurial > vba-clojure

annotate clojure/com/aurellem/run/music.clj @ 428:476f7da175a4

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