honeylisp/game/boop.fnl

(local {: vm} (require :game.defs))

(local speaker :0xc030)
(vm:def :blipmem ; count p --
  [:block
    [:lda [vm.ST1 :x]]
    [:tay]
  :sample
    [:lda speaker]
    [:lda [vm.TOP :x]]
    [:inc vm.TOP :x]
    [:bne :wait]
    [:inc vm.TOPH :x]
  :wait
    [:clc] [:adc 1]
    [:bne :wait]
    [:dey]
    [:bne :sample]]
    (vm:drop) (vm:drop))

(vm:def :bliptone ; duration-f1 f2 --
  [:block
    [:lda vm.ST1H :x]
    [:sta vm.W]
  :top
    [:lda speaker]
    [:ldy vm.ST1 :x]
  :wave1 [:dey] [:bne :wave1]
    [:lda speaker]
    [:lda vm.TOPH :x]
    [:ldy vm.TOP :x] [:iny]
  :wave2 [:dey] [:bne :wave2]
    [:ldy 0xff]
    [:sec] [:sbc 1] [:bcs :wave2]
    [:dec vm.W]
    [:bne :top]
  (vm:drop) (vm:drop)])

; 0x39a "samples" = 440hz
(local notes {})
(each [i note (ipairs [:a :a# :b :c :c# :d :d# :e :f :f# :g :g#])]
  (tset notes note (- i 1)))
(fn wavelength [note]
  (-> 0x39a
    (/ (math.pow 1.05946 (. notes note)))
    (math.floor)))
(fn octave [wvl oct]
  (-> wvl
    (/ (math.pow 2 (- oct 3)))
    (math.floor)))
(fn parse-note [n]
  (values (n:sub 1 -2) (tonumber (n:sub -1))))
(fn note-wavelength [n]
  (local (note oct) (parse-note n))
  (-> (wavelength note)
    (octave oct)))
(fn note [n ?duration ?timbre]
  (local timbre (or ?timbre 0x20))
  (local duration (or ?duration 0x10))
  (local wvl (note-wavelength n))
  [:vm (bit.bor (bit.lshift duration 8) timbre) (- wvl timbre) :bliptone])
(fn notes [ns ?duration ?timbre]
  (local result [:block])
  (each [_ n (ipairs ns)]
    (table.insert result (note n ?duration ?timbre)))
  result)

(vm:word :snd-explode 0x40 :lit :randombytes :blipmem)
(vm:word :snd-dooropen (notes [:c1 :e1] 8))
(vm:word :snd-doorclose (notes [:e1 :c1] 8))
(vm:word :snd-term-jingle (notes [:e3 :f3 :g3] 0x20))
(vm:word :snd-termon :snd-term-jingle (note :c4 0x20))
(vm:word :snd-termoff :snd-term-jingle (note :c3 0x20))

{: note : notes}