(ns com.aurellem.run.music

   (:use (com.aurellem.gb saves gb-driver util constants

                          items vbm characters money

                          rlm-assembly))

   (:use (com.aurellem.run util title save-corruption

                           bootstrap-0 bootstrap-1))

   (:require clojure.string)

   (:import [com.aurellem.gb.gb_driver SaveState])

   (:import java.io.File))

 

 (def pony

   (File. user-home "/proj/vba-clojure/music/pony-title.mid"))

 

 (def pony-csv 

   (File. user-home "proj/vba-clojure/music/pony-title.csv"))

   

 (def sync-test

   (File. user-home "proj/vba-clojure/music/sync-test.mid"))

 

 (def drum-test

   (File. user-home "proj/vba-clojure/music/drum-test.mid"))

 

 (def regret

   (File. user-home "proj/vba-clojure/music/ship-of-regret-and-sleep.mid"))

 

 (def regret-csv

   (File. user-home "proj/vba-clojure/music/ship-of-regret-and-sleep.csv"))

 

 (def mother

   (File. user-home "proj/vba-clojure/music/mother.mid"))

 

 (def mother-csv

   (File. user-home "proj/vba-clojure/music/mother.csv"))

 

 

 (defn raw-midi-text [#^File midi-file]

   (let [extention (apply str (take-last 3 (.getCanonicalPath

                                            midi-file)))]

     (cond (= "mid" extention)

           (:out 

            (clojure.java.shell/sh

             "midicsv"

             (.getCanonicalPath midi-file)

             "-"))

           (= "csv" extention)

              (slurp midi-file))))

 

 (def command-line #"^(\d+), (\d+), ([^,]+)(.*)$")

 

 (defmulti parse-command :command)

 

 (defn discard-args [command] (dissoc command :args))

 

 (defmethod parse-command :Start_track

   [command] (discard-args command))

 

 (defmethod parse-command :End_track

   [command] (discard-args command))

 

 (defmethod parse-command :default

   [command] command)

 

 (defn parse-number-list

   [number-list-str]

   (map #(Integer/parseInt %)

        (clojure.string/split number-list-str #", ")))

 

 (defmethod parse-command :Tempo

   [command]

   (update-in command [:args] #(Integer/parseInt %)))

 

 (defn parse-midi-note-list

   [midi-note-list-str]

   (let [[channel note velocity]

         (parse-number-list midi-note-list-str)]

     {:channel channel :note note :velocity velocity}))

 

 (defmethod parse-command :Note_on_c

   [command]

   (update-in command [:args] parse-midi-note-list))

 

 (defmethod parse-command :Note_off_c

   [command]

   (update-in command [:args] parse-midi-note-list))

 

 (defmethod parse-command :Header

   [command]

   (let [args (:args command)

         [format num-tracks division] (parse-number-list args)]

     (assoc command :args

            {:format format

             :num-tracks num-tracks

             :division division})))

         

 (defmethod parse-command :Program_c

   [command]

   (let [args (:args command)

         [channel program-num] (parse-number-list args)]

     (assoc command :args

            {:channel channel

             :program-num program-num})))

 

 (defn parse-midi [#^File midi-file]

   (map

    (comp parse-command

          (fn [line]

            (let [[[_ channel time command args]]

                  (re-seq command-line line)]

              {:channel (Integer/parseInt channel)

               :time (Integer/parseInt time)

               :command (keyword command)

               :args (apply str (drop 2 args))})))

    (drop-last

     (clojure.string/split-lines

      (raw-midi-text midi-file)))))

   

 (def music-base new-kernel)

 

 (defn store [n address]

   (flatten

    [0xF5

     0xE5

     

     0x3E

     n

     

     0x21

     (reverse (disect-bytes-2 address))

 

     0x77

     

     0xE1

     0xF1]))

 

 (defn infinite-loop []

   [0x18 0xFE])

 

 (def divider-register 0xFF04)

 

 (defrecord Bit-Note [frequency volume duration duty])

 

 (defn clear-music-registers []

   (flatten

    [(store (Integer/parseInt "00000000" 2) 0xFF10) ;; sweep

     (store (Integer/parseInt "00000000" 2) 0xFF11) ;; pattern duty

     (store (Integer/parseInt "00000000" 2) 0xFF12) ;; volume

     (store (Integer/parseInt "00000000" 2) 0xFF13) ;; frequency-low

     (store (Integer/parseInt "00000000" 2) 0xFF14) ;; frequency-high

 

     (store (Integer/parseInt "00000000" 2) 0xFF16) ;; pattern duty 000000

     (store (Integer/parseInt "00000000" 2) 0xFF17) ;; volume 0000

     (store (Integer/parseInt "00000000" 2) 0xFF18) ;; frequency-low

     (store (Integer/parseInt "00000000" 2) 0xFF19) ;; 00000 frequency-high

 

     (store (Integer/parseInt "00000000" 2) 0xFF1A)

     (store (Integer/parseInt "00000000" 2) 0xFF1B)

     (store (Integer/parseInt "00000000" 2) 0xFF1C)

     (store (Integer/parseInt "00000000" 2) 0xFF1D)

     (store (Integer/parseInt "00000000" 2) 0xFF1E)

 

     (store (Integer/parseInt "00000000" 2) 0xFF20) ;; length

     (store (Integer/parseInt "00000000" 2) 0xFF21) ;; volume

     (store (Integer/parseInt "00000000" 2) 0xFF22) ;; noise-frequency

     (store (Integer/parseInt "00000000" 2) 0xFF23) ;; control

     ]))

 

 

 ;; mini-midi syntax

 

 ;; codes

 ;; note-code == 0x00

 ;; change-duty-code = 0x01

 ;; silence-code = 0x02

 

 ;; silence format

 ;;  2 bytes

 ;;  [silence-code (0x02)]

 ;;  [duration-8-bits]

 

 ;; note data format

 ;;  4 bytes

 ;;  [note-code (0x00)]

 ;;  [volume-4-bits 0 frequency-high-3-bits]

 ;;  [frequengy-low-8-bits]

 ;;  [duration-8-bits]

 

 ;; change-duty-format

 ;;  2 bytes

 ;;  [change-duty-code (0x01)]

 ;;  [new-duty]

 

 (def note-code 0x00)

 (def change-duty-code 0x01)

 (def silence-code 0x02)

 

 (defn do-message

   "Read the message which starts at the current value of HL and do

    what it says. Duration is left in A, and HL is advanced

    appropraitely."

   ([] (do-message 0x16 1))

   ([sound-base-address wave-duty]

      (assert (<= 0 wave-duty 3))

      (let [switch

            [0x2A ;; load message code into A, increment HL

             

             ;; switch on message

             0xFE

             note-code

             

             0x20

             :note-length]

 

            play-note

            [0x3E ;; set wave-duty

             (bit-shift-left wave-duty 6)

             0xE0

             sound-base-address

             0x2A   ;; load volume/frequency-high info

             0xF5   ;; push A

             0xE6

             (Integer/parseInt "11110000" 2) ;; volume mask

             0xE0

             (inc sound-base-address) ;;0x17   ;; set volume

             0xF1   ;; pop A

             0xE6

             (Integer/parseInt "00000111" 2) ;; frequency-high mask

             0xE0   

             (+ 3 sound-base-address) ;;0x19   ;; set frequency-high

             

             0x2A   ;; load frequency low-bits

             0xE0

             (+ 2 sound-base-address) ;;0x18   ;; set frequency-low-bits

             0x2A]]   ;; load duration

        (replace

         {:note-length (count play-note)}

         (concat switch play-note)))))

 

 (defn play-noise

   "read [noise-code, volume,  duration] and play the noise. Duration is left in

    A, and HL is advanced appropraitely."

   ([]

      [0x2A  ;; load noise-code into A

       0xE0

       0x22  ;; write noise-code

 

       0x2A  ;; load volume

       0xE0

       0x21  ;; write volume

       

       0x2A] ;; load duration into A

      ))

 

 

 ;; (defn play-note

 ;;   "Play the note referenced by HL in the appropiate channel.

 ;;    Leaves desired-duration in A."

 

 ;;   [0x2A   ;; load volume/frequency-high info

 ;;    0xF5   ;; push A

 ;;    0xE6

 ;;    (Integer/parseInt "11110000" 2) ;; volume mask

 ;;    0xE0

 ;;    0x17   ;; set volume

 ;;    0xF1   ;; pop A

 ;;    0xE6

 ;;    (Integer/parseInt "00000111" 2) ;; frequency-high mask

 ;;    0xE0   

 ;;    0x19   ;; set frequency-high

    

 ;;    0x2A   ;; load frequency low-bits

 ;;    0xE0

 ;;    0x18   ;; set frequency-low-bits

 

 ;;    0x2A   ;; load duration

 ;;    ]) 

 

 (defn music-step [sound-base-address wave-duty noise?]

   ;; C == current-ticks

   ;; A == desired-ticks

   

   (flatten

    [;; restore variables from stack

     0xE1 ;; pop HL

     0xC1 ;; pop CB

     0xF1 ;; pop AF

 

 

     0xF5 ;; push A

     0xF0

     0x05 ;; load current ticks from 0xF005

     0xB8 ;; 

     0x30 ;; increment C only if last result caused carry

     0x01

     0x0C

 

     0x47 ;; update sub-ticks (A->B)

 

     0xF1 ;; pop AF, now A contains desired-ticks

 

     0xB9 ;; compare with current ticks

 

     ;; if desired-ticks = current ticks

     ;;   go to next note ; set current set ticks to 0.

 

     (if noise?

       [0x20

        (+ 2 (count (play-noise)))

        (play-noise)]

     

       [0x20

        (+ (count (do-message 0 0)) 2)

        (do-message sound-base-address wave-duty)])

     

     0x0E

     0x00 ;; 0->C (current-ticks)

 

     ;; save variables to stack

     0xF5 ;; push AF

     0xC5 ;; push CB

     0xE5 ;; push HL

     

 

     ]))

     

 (def music-1 0x11)

 (def music-2 0x16)

 

 (defn music-kernel [wave-duty-1 wave-duty-2]

   (flatten

    [;; global initilization section

     (clear-music-registers)

     

     0x3E

     0x01

     0xE0

     0x06 ;; set TMA to 0

     

     0x3E

     (Integer/parseInt "00000110" 2)

     0xE0

     0x07 ;; set TAC to 65536 Hz and activate timer

 

     ;; initialize frame 1 

     0x21

     0x00

     0xA0 ;; set HL to 0xA000 == music-start 1

     0x0E

     0x00 ;; 0->C

     0x06

     0x00 ;; 0->B

 

     0xAF ;; 0->A

 

     0xF5 ;; push AF

     0xC5 ;; push CB

     0xE5 ;; push HL

 

     ;; initialize frame 2

     0x21

     0x00

     0xB0 ;; set HL to 0xB000 == music-start 2

 

     0xF5 ;; push AF

     0xC5 ;; push CB

     0xE5 ;; push HL

 

 

     ;; initialize frame 3 (noise)

     0x21

     0x00

     0xA9 ;; 0xA9OO -> HL

 

     0xF5 ;; push AF

     0xC5 ;; push CB

     0xE5 ;; push HL

 

     ;; main music loop

 

     0xE8 ;; SP + 12; activate frame 1

     12

     (music-step music-1 wave-duty-1 false)

     

     0xE8 ;; SP - 6; activate frame 2

     (->signed-8-bit -6)

     (music-step music-2 wave-duty-2 false)

 

     0xE8 ;; SP - 6;  activate frame 3

     (->signed-8-bit -6)

     (music-step nil nil true)

 

     0x18

     (->signed-8-bit (+

                      ;; two music-steps

                      (- (* 2 (count (music-step 0 0 false))))

                      ;; one noise

                      (- (count (music-step nil nil true)))

                      -2 ;; this jump instruction

                      -2 ;; activate frame 1

                      -2 ;; activate frame 2

                      -2 ;; activate frame 3

                      ))]))

 

 (defn frequency-code->frequency

   [code]

   (assert (<= 0 code 2047))

   (/ 131072 (- 2048 code)))

 

 (defn clamp [x low high]

   (cond  (> x high) high

          (< x low)  low

          true x))

 

 (defn frequency->frequency-code

   [frequency]

   (clamp

    (Math/round

     (float

      (/ (- (* 2048 frequency) 131072) frequency)))

    0x00 2048))

     

 (defn note-codes [frequency volume duration]

   (assert (<= 0 volume 0xF))

   (if (<= duration 0xFF)

     (let [frequency-code

           (frequency->frequency-code frequency)

           volume&high-frequency

           (+ (bit-shift-left volume 4)

              (bit-shift-right frequency-code 8))

           low-frequency

           (bit-and 0xFF frequency-code)]

       [note-code

        volume&high-frequency

        low-frequency

        duration])

     (vec

      (flatten 

       [(note-codes frequency volume 0xFF)

        (note-codes frequency volume (- duration 0xFF))]))))

   

 

 (defn midi-code->frequency

   [midi-code]

   (* 8.1757989156

      (Math/pow 2 (* (float (/ 12)) midi-code))))

 

 ;; division == clock-pulses / quarter-note

 ;; tempo    == microseconds / quarter-note

 

 ;; have: clock-pulses

 ;; want: seconds

 

 

 (defn silent-note [length]

   {:frequency 1

    :duration length

    :volume 0})

 

 (defn commands

   "return all events where #(= (:command %) command)"

   [command s]

   (filter #(= command (:command %)) s))

 

 (defn track-info [#^File midi-file]

   (let [events (parse-midi midi-file)

         track-titles (commands :Title_t events)

         track-info

         (map #(read-string (read-string (:args %))) track-titles)

         track-map

         (zipmap track-info track-titles)]

     track-map))

 

 (defn target-tracks

   "return the track-numbers in the form [voice-0 voice-1 noise]"

   [#^File midi-file]

   (let [track-data (track-info midi-file)

         track-order

         (zipmap (map :out (keys track-data))

                 (vals track-data))

         channel-nums (map (comp :channel track-order) (range 3))]

     channel-nums))

 

 (defn midi-track->abstract-mini-midi

   [#^File midi-file track-num]

     (let [midi-events (parse-midi midi-file)

 

         note-on-events  (commands :Note_on_c  midi-events)

         note-off-events (commands :Note_off_c midi-events)

 

         select-channel

         (fn [n s]

           (sort-by :time (filter #(= n (:channel %)) s)))

 

         channel-on (select-channel track-num note-on-events)

         

         channel-off (select-channel track-num note-off-events)

         

         

         tempo (:args (first (commands :Tempo midi-events)))

         division

         (:division (:args (first (commands :Header midi-events))))

 

         notes

         (map

          (fn [note-on note-off]

            {:frequency (midi-code->frequency (:note (:args note-on)))

             :midi-code (:note (:args note-on))

             :duration

             (/ (* (/ tempo division)

                   (- (:time note-off) (:time note-on)))

                1e6) ;; convert clock-pulses into seconds

             :volume (int (/ (:velocity (:args note-on)) 10))

             :time-stamp (/ (* (/ tempo division)

                               (:time note-on)) 1e6)})

          channel-on channel-off)

 

         silences

         (map (fn [note-1 note-2]

                (let [note-1-space (- (:time-stamp note-2)

                                      (:time-stamp note-1))

                      note-1-length (:duration note-1)]

                  (silent-note (- note-1-space note-1-length))))

              ;; to handle silence at the beginning.

              (concat [(assoc (silent-note 0)

                         :time-stamp 0)] notes)

              notes)

         

         notes-with-silence

         (concat

          (filter (comp not zero? :duration)

                  (interleave silences notes))

          [(silent-note 3)])]

     notes-with-silence))

       

 (defn midi-track->mini-midi-voice [#^File midi-file track-num]

   (let [abstract-mini-midi

         (midi-track->abstract-mini-midi midi-file track-num)]

      (map

       (fn [note-event]

         (note-codes (:frequency note-event)

                     (:volume note-event)

                     (int (* (:duration note-event) 0x100))))

       abstract-mini-midi)))

 

 (def midi-code->gb-noise-code

   {nil 0xFF

    35 90

    38 20

    39 0

    })

 

 (defn noise-codes [code volume duration]

   (assert (<= 0 volume 0xF))

   (if (<= duration 0xFF)

     [(midi-code->gb-noise-code code code)

      (bit-shift-left volume 4)

      duration]

     (vec

      (flatten 

       [(noise-codes code volume 0xFF)

        (noise-codes code volume (- duration 0xFF))]))))

 

 (defn midi-track->mini-midi-noise [#^File midi-file track-num]

   (let [abstract-mini-midi

         (midi-track->abstract-mini-midi midi-file track-num)]

     (map

      (fn [noise-event]

        (noise-codes (:midi-code noise-event)

                     (:volume noise-event)

                     (int (* (:duration noise-event) 0x100))))

      abstract-mini-midi)))

 

 

 (defn midi->mini-midi [#^File midi-file]

   (let [targets (target-tracks midi-file)

         duty-info (keys (track-info midi-file))]

     

     {:voice-1 (midi-track->mini-midi-voice midi-file (nth targets 0))

      :voice-2 (midi-track->mini-midi-voice midi-file (nth targets 1))

      :noise   (midi-track->mini-midi-noise midi-file (nth targets 2))

      :duty    (zipmap (map :out duty-info)

                       (map #(get % :duty 0) duty-info))}))

 

 (defn midi-bytes [^File midi-file]

   (let [voice-1-target 0xA000

         voice-2-target 0xB000

         noise-target   0xA900

         program-target 0xC000

         mini-midi (midi->mini-midi midi-file)

         long-silence (flatten (note-codes 20 0 5000))

         long-noise-silence 

         (interleave (range 100) (repeat 0x00) (repeat 255))

         voice-1 (flatten (:voice-1 mini-midi))

         wave-duty-1 ((:duty mini-midi) 0 0)

 

         voice-2 (flatten (:voice-2 mini-midi))

         wave-duty-2 ((:duty mini-midi) 1 0)

 

         noise (flatten (:noise mini-midi))

         kernel (music-kernel wave-duty-1 wave-duty-2)]

     

     {:voice-1 {:address voice-1-target

                :data  (concat voice-1 long-silence)}

      :voice-2 {:address voice-2-target

                :data (concat voice-2 long-silence)}

      :noise   {:address noise-target

                :data (concat noise long-noise-silence)}

      :kernel  {:address program-target

                :data (music-kernel wave-duty-1 wave-duty-2)}}))

 

 (defn play-midi [^File midi-file]

   (let [bytes (midi-bytes midi-file)]

     (-> (second (music-base))

         (set-memory-range

          (:address (:voice-1 bytes)) (:data (:voice-1 bytes)))

         (set-memory-range

          (:address (:voice-2 bytes)) (:data (:voice-2 bytes)))

         (set-memory-range

          (:address (:noise   bytes)) (:data (:noise   bytes)))

         (set-memory-range

          (:address (:kernel  bytes)) (:data (:kernel bytes)))

         (PC! (:address (:kernel bytes))))))

 

 (defn test-noise []

   (let [noise-pattern

         (concat (interleave (range 0x100) (repeat 0xF0) (repeat 255))

                 (interleave (range 10) (repeat 0x00) (repeat 255)))]

                 

     (-> (second (music-base))

         (set-memory-range 0xA900 (flatten noise-pattern))

         (set-memory-range 0xC000 (music-kernel 0 0))

         (PC! 0xC000))))

 

 (defn test-play-noise [noise-code]

   (Thread/sleep 300)

   (println "playing noise:" noise-code)

   (run-moves

    (let [noise-pattern

          (interleave (repeat 10 noise-code) (repeat 0xF0) (repeat 255))]

      (-> (second (music-base))

          (set-memory-range 0xA900 (flatten noise-pattern))

          (set-memory-range 0xC000 (music-kernel 0 0))

          (PC! 0xC000)))

    (repeat 20 [])))

 

 (defn test-all-noises []

   (dorun (map test-play-noise (range 0x100))))

 

 (def C4 (partial note-codes 261.63))

 (def D4 (partial note-codes 293.66))

 (def E4 (partial note-codes 329.63))

 (def F4 (partial note-codes 349.23))

 (def G4 (partial note-codes 392))

 (def A4 (partial note-codes 440))

 (def B4 (partial note-codes 493.88))

 (def C5 (partial note-codes 523.3))

 

 (def scale

   (flatten

    [(C4 0xF 0x40)

     (D4 0xF 0x40)

     (E4 0xF 0x40)

     (F4 0xF 0x40)

     (G4 0xF 0x40)

     (A4 0xF 0x40)

     (B4 0xF 0x40)

     (C5 0xF 0x40)]))

                  

 (defn play-music [music-bytes]

   (let [program-target 0xC000

         music-target 0xA000]

     (-> (set-memory-range (second (music-base))

                           program-target (music-kernel))

         (set-memory-range music-target music-bytes)

         (PC! program-target))))

 

 (defn run-program

   ([program]

      (let [target 0xC000]

        (-> (set-memory-range (second (music-base))

                              target program)

            (PC! target)))))

 

 (defn test-timer []

   (flatten

    [0x3E

     0x01

     0xE0

     0x06 ;; set TMA to 0

     

     0x3E

     (Integer/parseInt "00000100" 2)

     0xE0

     0x07 ;; set TAC to 16384 Hz and activate timer

     

     (repeat

      500

      [0xF0

       0x05])]))

 

 (defn play-pony []

   (println "playing" (.getName pony-csv))

   (run-moves (play-midi pony-csv) (repeat 1800 [])))

 

 (defn play-regret []

   (println "playing" (.getName regret-csv))

   (run-moves (play-midi regret-csv) (repeat 3380 [])))

 

 (defn play-mother []

   (println "playing" (.getName mother-csv))

   (run-moves (play-midi mother-csv) (repeat 2200 [])))

 

 (defn demo [] (play-mother) (play-regret) (play-pony))