simple synth

open Containers;

external pow : float => float => float = "Math.pow" [@@bs.val];
external requestAnimationFrame : (unit => unit) => unit = "window.requestAnimationFrame" [@@bs.val];

module rec AudioContext:  {
  type destination;
  type t = Js.t {
    .
    destination : destination,
    sampleRate : float,
    createBufferSource [@bs.meth] : unit => AudioBufferSource.t,
    createBuffer [@bs.meth] : int => int => float => AudioBuffer.t,
    currentTime : float
  };

  external make : unit => t = "window.AudioContext" [@@bs.new];
} = AudioContext
and AudioBuffer: {
  type t = Js.t {
    .
    copyToChannel [@bs.meth]: Js_typed_array.Float32Array.t => int => int => unit
  };
} = AudioBuffer
and AudioBufferSource: {
  type t;

  external connect : t => AudioContext.destination => unit = "connect" [@@bs.send];
  external setBuffer : t => AudioBuffer.t => unit = "buffer" [@@bs.set];
  external start : t => float => unit = "start" [@@bs.send];
  external stop : t => float => unit = "stop" [@@bs.send];
} = AudioBufferSource;

module Synth = {
  type octave = float;
  type duration = float;
  type pitch = C | Cs | D | Ds | E | F | Fs | G | Gs | A | As | B;
  type note = Note pitch octave duration | Rest duration;
  type noteArray = Js_typed_array.Float32Array.t;

  module Notes = Map.Make({ type t = pitch; let compare = compare; });

  let notes = Notes.fromList [
    (C, 16.35),
    (Cs, 17.32),
    (D, 18.35),
    (Ds, 19.45),
    (E, 20.60),
    (F, 21.83),
    (Fs, 23.12),
    (G, 24.50),
    (Gs, 25.96),
    (A, 27.50),
    (As, 29.14),
    (B, 30.87),
  ];

  let makeNote : AudioContext.t => note => AudioBuffer.t  = fun ctx note => {
    switch note {
    | Note pitch octave duration => {
      let length = truncate @@ duration *. ctx##sampleRate;
      let c = ctx##createBuffer 2 (length) ctx##sampleRate;
      let freq = (pow 2.0 octave) *. Notes.find pitch notes;
      let noteDivisor = (ctx##sampleRate /. freq);
      let b = Array.make length 1.0
        |> Array.mapi (fun i _ => Js_math.sin (3.1415 *. 2.0 *. (float i) /. noteDivisor))
        |> Js_typed_array.Float32Array.make;

      c##copyToChannel b 0 0;
      c##copyToChannel b 1 0;
      c;
    }
    | Rest duration => {
      let length = truncate @@ duration *. ctx##sampleRate;
      let c = ctx##createBuffer 2 (length) ctx##sampleRate;
      let b = Array.make length 0.0
        |> Js_typed_array.Float32Array.make;
      c##copyToChannel b 0 0;
      c##copyToChannel b 1 0;
      c;
    }
    }
  };

  let stop = fun source time => {
    AudioBufferSource.stop source time;
  };

  let play : AudioContext.t => AudioBuffer.t => float => AudioBufferSource.t = fun audioCtx c time => {
    let source = audioCtx##createBufferSource ();

    AudioBufferSource.setBuffer source c;
    AudioBufferSource.connect source audioCtx##destination;
    AudioBufferSource.start source time;
    source;
  };
};

let audioCtx = AudioContext.make ();
let start = audioCtx##currentTime +. 0.05;
let spn = 60.0 /. 80.0;

let rec schedule (currentEnd, playing) (duration, source) list => {
  let currentTime = audioCtx##currentTime -. start;

  if (currentEnd < currentTime +. 0.25) {
    Synth.stop playing (currentEnd);
    let nowPlaying = Synth.play audioCtx source currentEnd;

    if (List.length list > 0) {
      let [(n1, n2), ...rest] = list;
      requestAnimationFrame (fun _ => schedule (spn *. duration +. currentTime, nowPlaying) (n1, n2) rest);
    } else {
      Synth.stop nowPlaying (currentEnd +. duration *. spn);
    };
  } else {
    requestAnimationFrame (fun _ => schedule (currentEnd, playing) (duration, source) list);
  };
};

let main song => {
  switch song {
  | [] => ()
  | [(d, s)] => {
    let x = Synth.play audioCtx s start;
  }
  | [(d, s), (d', s'), ...rest] => {
    let x = Synth.play audioCtx s start;
    schedule (start +. d *. spn, x) (d', s') rest;
  }
  };
};

let f = fun x => {
  switch x {
  | Synth.Note n o d => (d, Synth.makeNote audioCtx (Note n o d))
  | Synth.Rest d => (d, Synth.makeNote audioCtx (Rest d))
  };
};

main @@ List.map f [
  Synth.Note E 4.0 1.0,
  Synth.Note E 4.0 1.0,
  Synth.Note F 4.0 1.0,
  Synth.Note G 4.0 1.0,
  Synth.Note G 4.0 1.0,
  Synth.Note F 4.0 1.0,
  Synth.Note E 4.0 1.0,
  Synth.Note D 4.0 1.0,
  Synth.Note C 4.0 1.0,
  Synth.Note C 4.0 1.0,
  Synth.Note D 4.0 1.0,
  Synth.Note E 4.0 1.0,
  Synth.Note E 4.0 1.75,
  Synth.Note D 4.0 0.25,
  Synth.Note D 4.0 1.0,
];