open Unix;;
open Random;;

(***************************
  Interval functions
****************************)

let min (a:int) (b:int) = if (a < b) then a else b;;

(* *)

let max (a:int) (b:int) = - (min (-a) (-b));;

(* *)

let intersectIntervals (ainf, asup) (binf, bsup) = 
  (max ainf binf, min asup bsup);;

(***************************
  Absolute pitch functions
****************************)

let absolutePitchOfNote (note, octava) = 
  note + 7*octava;;

(* *)

let noteOfAbsolutePitch pitch = 
(pitch mod 7, pitch/7);;

(* *)

let rangeOfInterval note interval = 
  let pitch = absolutePitchOfNote note in
  (pitch - interval + 1, pitch + interval - 1);;

(* *)

let candidatesPitches range interval note = 
  intersectIntervals range (rangeOfInterval note interval);;

(* *)

let selectPitch (inf, sup) = 
  let size = sup - inf + 1 in
  let pitchFromZero = Random.int size in
  inf + pitchFromZero;;

(* *)

let selectNote (inf, sup) = 
  noteOfAbsolutePitch (selectPitch (inf, sup));;

(***************************
  Octavas functions
****************************)

let referenceOctava = 2;;

(* *)

let strOfUnkeyedOctava referenceOctava octava = 
  let rec strOfOctavaAux n = if (n = 0) then " "
  else (
    if (n > 0) then 
      "'" ^ (strOfOctavaAux (n - 1))
    else
      "," ^ (strOfOctavaAux (n + 1))
   ) in
  strOfOctavaAux (octava - referenceOctava);;

(* *)

let strOfOctava octava = 
  strOfUnkeyedOctava referenceOctava octava;;

(***************************
  Note functions
****************************)

let initRandNote range = 
  selectNote range;;

(* *)

let nextNote range interval note = 
  selectNote (candidatesPitches range interval note);;

(* *)

let makeNoteList range interval n = 
  let nextNoteAux = nextNote range interval in
  let rec makeNoteListAux note = function 
    | 0 -> [] 
    | nbNotes -> (note)
	::(makeNoteListAux (nextNoteAux note) (nbNotes - 1)) in
  makeNoteListAux (initRandNote range) n;;

(* *)

let strOfNote (note, octava) = (match note with
  | 0 -> "c"
  | 1 -> "d"
  | 2 -> "e"
  | 3 -> "f"
  | 4 -> "g"
  | 5 -> "a"
  | 6 -> "b"
  | _ -> "err")
  ^ (strOfOctava octava);;

(* *)

let noteOfStr  = function
  | "c" -> 0
  | "d" -> 1
  | "e" -> 2
  | "f" -> 3
  | "g" -> 4
  | "a" -> 5
  | "b" -> 6
  | _ -> -1;;

(* *)

let octavedNoteOfStr str = 
  (noteOfStr (String.sub str 0 1), 
   int_of_string (String.sub str 1 1));;
  
(* *)

let rec strOfNoteList = function
    [] -> ""
  | h::t -> strOfNote h ^ " " ^ (strOfNoteList t);;

(***************************
  Clef functions
****************************)

let rec listSize = function 
  | [] -> 0
  | h::t -> 1 + listSize t;;

(* *)

let rec removeKey key = function
  | [] -> []
  | (k, r)::t when key = k -> removeKey key t
  | h::t -> h::(removeKey key t);;
   
(* *)
	   
let selectKey keys = 
  let nbKeys = listSize keys in
  let rec selectKeyAux = 
    (function 
      | h::[] -> h
      | h::t -> if (Random.int nbKeys = 0) then 
	  h 
      else 
	  (selectKeyAux t)) in
  selectKeyAux keys;;

(* *)

let keyChange formerKey keys = 
  selectKey (removeKey formerKey keys);;
  
(* *)

let strOfKey key = "\n\\clef " ^ (match key with
  | 1 -> "treble"
  | 2 -> "alto"
  | 3 -> "tenor"
  | 4 -> "bass"
  | 5 -> "soprano"
  | 6 -> "mezzosoprano"
  | 7 -> "varbaritone"
  | _ -> "err") ^ " ";;

(***************************
  Exercise functions
****************************)

let selectNbNotes maxNbNotes n = 
  min (Random.int (maxNbNotes + 1) + 1) n;;

(* *)

let makeExercise interval maxNbNotes keys n = 
  let (firstKey, firstRange) = selectKey keys in
  if (listSize keys = 1) then    
    [(firstKey, makeNoteList firstRange interval n)]
  else
    (
     let rec makeExerciseAux previousKey = 
       (function 
	 | 0 -> []
	 | n -> let (key, range) = keyChange previousKey keys in 
	   let nbNotes = selectNbNotes maxNbNotes n in 
	   (key, makeNoteList range interval nbNotes)
	   ::(makeExerciseAux key (n - nbNotes))
       ) in 
     makeExerciseAux firstKey n
    );;

(* *)

let strOfExercise l = 
  let rec strOfExerciseAux = (function
  | [] -> ""
  | (key, notes)::t -> 
      strOfKey key ^ strOfNoteList notes ^ (strOfExerciseAux t)) in
  "\\version \"2.12.1\"\n{" ^ (strOfExerciseAux l) ^ "\n}\n";;

(***************************
  parser
****************************)

(* *)

let isAnOption str = 
  "--" = String.sub str 0 2;;

(* *)

let getOptionIndex optionName = 
  let rec findOptionName i = 
    if (i = Array.length Sys.argv) then
      -1
    else
      (if ("--" ^ optionName = Sys.argv.(i)) then
	i
      else
	findOptionName (i + 1)
      ) in
  findOptionName 1;;

(* *)

let getOptionIndexes optionName = 
  let rec findOptionNames i = 
    if (i = Array.length Sys.argv) then
      []
    else
      ((if ("--" ^ optionName = Sys.argv.(i)) then
	i::(findOptionNames (i + 1))
      else
	(findOptionNames (i + 1)))
      ) in
  findOptionNames 1;;
	
(* *)

let getOptionValue optionName = 
  let optionNameIndex = getOptionIndex optionName in
  if (optionNameIndex <> -1) then
    Sys.argv.(optionNameIndex + 1)
  else
    "";;
	
(* *)

let getOptionValues optionName = 
  let optionNameIndexes = getOptionIndexes optionName in
  let rec getOptionValuesAux beginingIndex = 
    (
     let rec getOptionValuesAuxAux index = 
       (
	if (index = Array.length Sys.argv or isAnOption Sys.argv.(index)) then
	 []
       else
	 Sys.argv.(index)::(getOptionValuesAuxAux (index + 1))
       ) in
     getOptionValuesAuxAux beginingIndex
    ) in
  List.map getOptionValuesAux (List.map (function f -> f + 1) optionNameIndexes);;

(* *)

let ioKeyOfStr = function
  | "g2" -> 1
  | "c3" -> 2
  | "c4" -> 3
  | "f4" -> 4
  | "c1" -> 5
  | "c2" -> 6
  | "f3" -> 7
  | _ -> -1;;

(* *)

let ioStrOfKey = function
  | 1 -> "g2"
  | 2 -> "c3"
  | 3 -> "c4"
  | 4 -> "f4"
  | 5 -> "c1"
  | 6 -> "c2"
  | 7 -> "f3"
  | _ -> "err";;

(* *)

let defaultRange = function
  | 1 -> ((noteOfStr "f", 2), (noteOfStr "g", 5))
  | 2 -> ((noteOfStr "c", 2), (noteOfStr "c", 4))
  | 3 -> ((noteOfStr "c", 2), (noteOfStr "c", 4))
  | 4 -> ((noteOfStr "c", 1), (noteOfStr "g", 3))
  | 5 -> ((noteOfStr "c", 2), (noteOfStr "c", 4))
  | 6 -> ((noteOfStr "c", 2), (noteOfStr "c", 4))
  | 7 -> ((noteOfStr "c", 1), (noteOfStr "g", 3));;

(* *)

let getKeysAndRanges l = 
  let rec getKeyAndRange = 
    (function
      | strkey::lower::upper::_ -> 
	  (ioKeyOfStr strkey, (octavedNoteOfStr lower, octavedNoteOfStr upper)) 
      | strkey::_ -> let key  = ioKeyOfStr strkey in 
	(key, defaultRange key)
    ) in
  List.map getKeyAndRange l;; 
  
(***************************
  input-output
****************************)

let getNbNotes = 
  int_of_string (
  let str = getOptionValue "nb" in
  (
   if (str = "") then
     (print_string "# number of notes : " ; read_line ())
   else
     str
  ));;

(* *)

let getInterval = 
  int_of_string (
  let str = getOptionValue "i" in
  (
   if (str = "") then
     (print_string "# greater interval (1 for unisson, 2 for second...) : ";
      read_line ())
   else
     str
  ));;
  
(* *)

let getNbSameKey= 
  int_of_string (
  let str = getOptionValue "max" in
  (
   if (str = "") then
     (print_string "# maximum notes written with the same key : ";
      read_line ())
   else
     str
  ));;

(* *)

let ioStrOfKeyWithSelection (index, b) = 
  (ioStrOfKey index) ^ (if b then " (enabled)" else " (disabled)");;

(* *)

let ioStrOfKeys l = 
  let rec ioStrOfKeysAux k = 
    (function 
      | [] -> ""
      | h::t -> (string_of_int k) ^ " - " ^ (ioStrOfKeyWithSelection h) 
	  ^ "\n" ^ (ioStrOfKeysAux (k + 1) t)
    ) in 
  ioStrOfKeysAux 1 l;;

(* *)

let ioInitKey = [(1, false) ; (4, false) ; (7, false) ; 
		 (3, false) ; (2, false) ; (6, false) ; (5, false)];;

(* *)

let rec switchKey position = function 
  | [] -> []
  | (h, b)::t when position = 1 -> (h, not b)::t
  | h::t -> h::(switchKey (position - 1) t);;

(* *)

let ioSelectKeys =
  let optionValues = getOptionValues "key" in
  if (optionValues = []) then
      (
       print_string "# here is he list of the available keys :\n";
       let rec selectKeysAux l = 
	 (
	  print_string (ioStrOfKeys l);
	  print_string ("# type the index of a key to enable (or disable) it "
			^ "(0 when it's done) : ");
	  let selectionStr = read_line () in
	  let selection = int_of_string selectionStr in
	  if (selection >= 1 && selection <= 7) then
	    selectKeysAux (switchKey selection l)
	  else
	    l
	 ) in
       let rec returnKeysWithRange = 
	 (function 
	   | [] -> []
	   | (k, true)::t -> (k, defaultRange k)::(returnKeysWithRange t)
	   | _::t -> (returnKeysWithRange t)
	 ) in
       (returnKeysWithRange (selectKeysAux ioInitKey), false)
      )
  else
    (getKeysAndRanges optionValues, true);;

(* *)

let getRange k = 
  print_string "# range for the key ";
  print_string (ioStrOfKey k);
  print_string "\n# type the lowest note's name (c, d, e, f, g, a or b) : ";
  let infNameStr = read_line () in
  let infName = noteOfStr infNameStr in
  print_string ("\n# type the lowest note's octava "
		^ "(middle c is c3, type a positive value or zero) : ");
  let infOctavaStr = read_line () in
  let infOctava = int_of_string infOctavaStr in
  print_string "\n# type the highest note's name (c, d, e, f, g, a or b) : ";
  let supNameStr = read_line () in
  let supName = noteOfStr supNameStr in
  print_string ("\n# type the highest note's octava "
		^ "(middle c is c3, type a positive value or zero) : ");
  let supOctavaStr = read_line () in
  let supOctava = int_of_string supOctavaStr in
  ((infName, infOctava), (supName, supOctava));;
  
(* *)

let ioStrOfNote (note, octava) = (match note with
  | 0 -> "c"
  | 1 -> "d"
  | 2 -> "e"
  | 3 -> "f"
  | 4 -> "g"
  | 5 -> "a"
  | 6 -> "b"
  | _ -> "err")
  ^ (string_of_int octava);;

(* *)

let strOfRange (inf, sup) = 
  "from " ^ (ioStrOfNote inf) ^ " to " ^ (ioStrOfNote sup);;

(* *)

let ioStrOfKeyWithRange (index, r) = 
  (ioStrOfKey index) ^ " " ^ (strOfRange r);;

(* *)

let ioStrOfKeysWithRange l = 
  let rec ioStrOfKeysAux k = 
    (function 
      | [] -> ""
      | h::t -> (string_of_int k) ^ " - " ^ (ioStrOfKeyWithRange h) 
	  ^ "\n" ^ (ioStrOfKeysAux (k + 1) t)
    ) in 
  ioStrOfKeysAux 1 l;;

(* *)

let rec absolutePitchesOfNotes = function
  | [] -> []
  | (k, (inf, sup))::t -> 
      (k, (absolutePitchOfNote inf, absolutePitchOfNote sup))
      ::(absolutePitchesOfNotes t);;

(* *)

let editRanges l =
  print_string "# here is he list of the selected keys :\n";
  let rec editRangeAux position = 
    (function 
      | [] -> []
      | (k, r)::t when position = 1 -> (k, getRange k)::t
      | h::t -> h::(editRangeAux (position - 1) t)
    ) in
  let rec selectRanges l = 
    (
     print_string (ioStrOfKeysWithRange l);
     print_string ("# type the index of a key to edit its range "
		   ^ "(0 when it's done) : ");
     let selectionStr = read_line () in
     let selection = int_of_string selectionStr in
     if (selection >= 1 && selection <= 7) then
       selectRanges (editRangeAux selection l)
     else
       l
    ) in
  absolutePitchesOfNotes (selectRanges l);;

(* *)

let writeExercise e fStr =
  let fic = open_out fStr in
  output_string fic (strOfExercise e);
  let _ = close_out fic in ();;

(* *)

let rec writeExerciseIfAsked e = 
  let outputFile = getOptionValue "o" in
  let (fName, writeAsked) = 
    (
     if (outputFile = "") then
      (
       print_string "1 - print source\n2 - write in a file\n# type your answer : ";
       let str = read_line() in
       let answer = int_of_string str in
       match answer with
       | 1 -> ("", false)
       | 2 -> 
	   print_string ("# type the name of the file without the extension " 
			 ^ "(e.g. \"exercise\" if you want an \"exercise.pdf\" file), "
			 ^ "type nothing for \"output.pdf\") : "); 
	   (read_line(), true)
      )
    else      
      (
       if (outputFile = "stdout") then 
	 ("", false)
       else
	 (outputFile, true)
      )
    )  in
  if (writeAsked) then
    (
     let fName = (
       if (fName = "") then
	 "output.ly"
       else
	 fName ^ ".ly") in
     writeExercise e fName;
     let _ = Unix.system ("lilypond " ^ fName) in ();
    )
  else
    (print_string ("%%% begin lilypond source code %%%\n" ^ (strOfExercise e) ^ "\n%%% end lilypond source code %%%"));;

(***************************
  Main !
****************************)

let main = 
  let nbNotes = getNbNotes in
  let interval = getInterval in
  let nbSameKey = getNbSameKey in  
  let (keys, initializated) = ioSelectKeys in
  let keysWithRanges = 
    (if (initializated) then
      absolutePitchesOfNotes keys
	else
      editRanges keys
    ) in
  let exo = makeExercise interval nbSameKey keysWithRanges nbNotes in
  writeExerciseIfAsked exo;;