(* -------------------------------------------------------------------------- *)
(* ----------------------- DEFINITIONS OF MUSIC SCORES ---------------------- *)
(* -------------------------------------------------------------------------- *)

type note = C | D | E | F | G | A | B
type pitch = { note : note; octave : int }
type duration = Full | Half | Quarter | Eighth | Sixteenth
type symbol = Note of duration * pitch | Rest of duration
type score = { symbols : symbol list;  tempo : int }

let o1_frequency t = match t with
  | C -> 32.70
  | D -> 36.71
  | E -> 41.20
  | F -> 43.65
  | G -> 49.
  | A -> 55.
  | B -> 61.74

let frequency p =
  let f0 = o1_frequency p.note in
  f0 *. (2. ** float p.octave)

let duration d t =
  let t = 60. /. (float_of_int t) in
  match d with
  | Sixteenth -> t /. 4.
  | Eighth    -> t /. 2.
  | Quarter   -> t +. 0.0001
  | Half      -> t *. 2.
  | Full      -> t *. 4.

let df_of_symbol s tp =
  match s with
  | Rest d -> (duration d tp, 0.)
  | Note (d, f) -> (duration d tp, frequency f)

(* -------------------------------------------------------------------------- *)
(* ------------------------------ PLAYING SOUNDS  --------------------------- *)
(* -------------------------------------------------------------------------- *)

let play_sound s tp =
  let (d, f) = df_of_symbol s tp in
  let pid = Unix.create_process
      "/usr/bin/play"
      [|"play"; "-r"; "44100"; "-n"; "synth"; string_of_float d; "sin"; string_of_float f |]
      Unix.stdin Unix.stdout Unix.stderr in
  let _ = Unix.waitpid [] pid in ()

let play_score sc =
  List.iter (fun s -> play_sound s sc.tempo) sc.symbols

(* let () = Printf.printf "%.2f\n" (o1_frequency G) *)
let _ = {note = A; octave = 3}
let r_4 = Rest Quarter
let r_8 = Rest Eighth
let r_16 = Rest Sixteenth
let g_4_8 = Note (Eighth, {note = G; octave = 4})
let sol_4_8 = g_4_8
let f_4_8 = Note (Eighth, {note = F; octave = 4})
let _fa_4_8 = f_4_8
let e_4_8 = Note (Eighth, {note = E; octave = 4})
let mi_4_8 = e_4_8
let d_4_8 = Note (Eighth, {note = D; octave = 4})
let re_4_8 = d_4_8
let c_4_8 = Note (Eighth, {note = C; octave = 4})
let do_4_8 = c_4_8
let a_4_8 = Note (Eighth, {note = A; octave = 4})
let la_4_8 = a_4_8
let b_4_8 = Note (Eighth, {note = B; octave = 4})
let si_4_8 = b_4_8

let l1 = [r_4; r_16; r_8]
let l2 = [f_4_8; e_4_8; d_4_8]
let l3 = List.init 7 (fun _i -> g_4_8)
let sc1 = r_4 :: l3 @ l2 @ l1

let _sc2 = sc1 @ [r_8; d_4_8] @ l3 @ [f_4_8; e_4_8; d_4_8]
           @ [r_8; c_4_8; d_4_8; d_4_8; ]

let sc3 = [ c_4_8; d_4_8; e_4_8; f_4_8; g_4_8; a_4_8; b_4_8 ]

let increase_pitch_octave p =
  { p with octave = p.octave + 1 }

let decrease_pitch_octave p =
  { p with octave = p.octave - 1 }

let change_octave (f: pitch -> pitch) (s: symbol) =
  match s with
  | Note (d, p) -> Note (d, f p)
  | Rest d -> Rest d

let increase_octave = change_octave increase_pitch_octave
let decrease_octave = change_octave decrease_pitch_octave

let increase_duration (s: symbol) =
  let increase (d: duration) =
    match d with
    | Full -> Full
    | Half -> Full
    | Quarter -> Half
    | Eighth -> Quarter
    | Sixteenth -> Eighth in
  match s with
  | Note (d, p) -> Note (increase d, p)
  | Rest d -> Rest d

let decrease_duration (s: symbol) =
  match s with
  | Note (_, p) -> Note (Sixteenth, p)
  | Rest d -> Rest d

let sc4 = List.rev (List.map increase_octave sc3)
let sc5 = List.rev (List.map decrease_octave sc3)

let () =
  play_score { symbols = sc3 @ r_4 :: sc4 @ r_4 :: sc5; tempo = 292 }

let _frere_jacques = [
  sol_4_8;
  la_4_8;
  si_4_8;
  sol_4_8;
  sol_4_8;
  la_4_8;
  si_4_8;
  sol_4_8;
  si_4_8;

  increase_octave do_4_8;
  increase_octave (increase_duration re_4_8);
  si_4_8;
  increase_octave do_4_8;
  increase_octave (increase_duration re_4_8);

  increase_octave (decrease_duration re_4_8);
  increase_octave (decrease_duration mi_4_8);
  increase_octave (decrease_duration re_4_8);
  increase_octave (decrease_duration do_4_8);
  si_4_8;
  sol_4_8;

  increase_octave (decrease_duration re_4_8);
  increase_octave (decrease_duration mi_4_8);
  increase_octave (decrease_duration re_4_8);
  increase_octave (decrease_duration do_4_8);
  si_4_8;
  sol_4_8;
  sol_4_8;
  re_4_8;
  increase_duration sol_4_8;

  sol_4_8;
  re_4_8;
  increase_duration (increase_duration sol_4_8);
]

type tokens = Tempo of int | Pitch of string * int * string

let score_of_file fname =
  let cin = open_in fname in
  let text = ref [] in
  let rec read_loop () =
    try
      let line = input_line cin in
      text := line :: !text;
      read_loop ()
    with End_of_file -> !text in
  let split_file = List.map (String.split_on_char ':') in
  let parse_line s = match s with
    | [tempo_or_pitch; info] ->
      begin match tempo_or_pitch with
        | "Tempo" -> Tempo (int_of_string (String.trim info))
        | pitch ->
          begin match String.split_on_char ' ' (String.trim info) with
            | [octave; duration] ->
              let octave = int_of_string octave in
              Pitch (pitch, octave, duration)
            | _ -> Format.eprintf "Anomaly: syntax error@."; exit 3
          end end
    | _ -> Format.eprintf "Anomaly: syntax error@."; exit 2 in
  let parse_file = List.map parse_line in
  let note_of_string = function
    | "Do" -> C
    | "Re" -> D
    | "Mi" -> E
    | "Fa" -> F
    | "Sol" -> G
    | "La" -> A
    | "Si" -> B
    | _ -> Format.eprintf "Anomaly: lexer error@."; exit 4 in
  let duration_of_string = function
    | "Six" -> Sixteenth
    | "Eighth" -> Eighth
    | "Quarter" -> Quarter
    | "Half" -> Half
    | "Full" -> Full
    | s -> Format.eprintf "Anomaly: lexer error \"%s\"@." s; exit 5 in
  let note_of_token = function
    | Tempo _ -> assert false
    | Pitch (s, octave, d) ->
      let p = { note = note_of_string s; octave } in
      let d = duration_of_string d in
      Note (d, p) in
  let score_of_tokens = function
    | [] -> Format.eprintf "Anomaly: ill-typed file@."; exit 6
    | Tempo tempo :: r -> { tempo; symbols = List.map note_of_token r }
    | _ -> Format.eprintf "Anomaly: ill-typed file@."; exit 7 in
  let file = List.rev (read_loop ()) in
  let file = split_file file in
  let file = parse_file file in
  score_of_tokens file

let () =
  play_score (score_of_file Sys.argv.(1))

This document was generated using caml2html