Mercurial > vba-clojure

annotate clojure/com/aurellem/run/music.clj @ 426:c03f28aa98d9

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