(* TODO: ESC *)
{$r-,s-,d+,l+,y+,i-,g+,a+}
uses
  crt, xkey;

type
  float = double;

  SoundType = record
    dist  : Integer;
    pitch : Integer;
    freq  : float;
  end;


const
  DIFF_FACTOR : float =   5.0; (* maximum factor difference    *)
  MAX_FACTOR  : float = 100.0; (* maximum frequency difference *)
  S_MODE      : Boolean = False;

  {NOTES_STR = 'c5 d5 e5 f5 g5 a5';}
  NOTES_STR : string = 'f#4 g4 a4 h4 c5 d5 e5 f#5 g5 a5 h5 c6 d6 e6';
  MAX_NOTES = 32;

  NOTE_C = 0;
  NOTE_D = 2;
  NOTE_E = 4;
  NOTE_F = 5;
  NOTE_G = 7;
  NOTE_A = 9;
  NOTE_H = 11;

  OCTAVE   = 12;
  NOTE_A4  = NOTE_A + OCTAVE*4;
  FREQ_A4  = 440;

  TIA_FREQ : Word = 31440; (* NTSC = 31440, PAL = 31200 *)
  NUM_DIST = 4;
  DIST_DIV : array[0..NUM_DIST-1] of Integer = (2,6,31,93);
  DIST_NUM : array[0..NUM_DIST-1] of Integer = (4,12,6,14);

  g_fBase  : float   = FREQ_A4;
  baseNote : Integer = NOTE_A4;

type
  SoundArrType = array[0..MAX_NOTES-1] of SoundType;

var
  g_fOrgBase : float;
  g_nNotes  : Integer;
  g_fFactor : float;
  g_fLow, g_fHigh : float;
  Notes  : array[0..MAX_NOTES-1] of Integer;


function Power(x, y : REAL) : REAL;
(* calculates x^y *)
begin
  if x=0 then Power := 0
  else begin
    x:=Abs(x);
    x:=Ln(x) * y;
    if x < -80 then Power := 0
               else Power := Exp(x);
  end;
end; (* Power *)


function minFloat(f1, f2 : float):double;
begin
  if f1 < f2 then
    minFloat:=f1
  else
    minFloat:=f2;
end; (* minFloat *)


function note2Str(note:Integer):string;
const
  strNotes : array[0..OCTAVE-1]of string =
    ('c', 'c#', 'd', 'd#', 'e', 'f', 'f#', 'g', 'g#', 'a', 'a#', 'h');
begin
  note2Str:=Copy(strNotes[note mod octave]+Chr(note div OCTAVE+48)+' ', 1, 3);
end; (* note2Str *)


function toFreq(note:Integer):float;
begin
  toFreq:=g_fBase * Power(g_fFactor, (note-baseNote));
end; (* toFreq *)


function toCent(opt, tia : float):float;
begin
  toCent:=Ln(tia/opt) / Ln(g_fFactor)*100;
end; (* toCent *)


function addCent(value, cent : float):float;
begin
  addCent:=value * Exp(cent/100*Ln(g_fFactor));
end; (* addCent *)


function prevFreq(freq:float{; var sound:SoundType}):float;
var
  d, p : Integer;
  fBest, fNew : float;
begin
  fBest:=0;

  for d:=0 TO NUM_DIST-1 do begin
    for p:=0 to 31 do begin
      fNew:=TIA_FREQ/DIST_DIV[d]/(p+1);
      if fNew >= freq then continue;
      if fNew > fBest then begin
        {sound.dist :=d;
        sound.pitch:=p;}
        fBest      :=fNew;
      end;
    end;
  end;

  {sound.freq:=fBest;}
  prevFreq  :=fBest;
end; (* prevFreq *)


function nextFreq(freq:float{; var sound:SoundType}):float;
var
  d, p : Integer;
  fBest, fNew : float;
begin
  fBest:=1e8;

  for d:=0 TO NUM_DIST-1 do begin
    for p:=0 to 31 do begin
      fNew:=TIA_FREQ/DIST_DIV[d]/(p+1);
      if fNew <= freq then continue;
      if fNew < fBest then begin
        {sound.dist :=d;
        sound.pitch:=p;}
        fBest      :=fNew;
      end;
    end;
  end;

  {sound.freq:=fBest;}
  nextFreq  :=fBest;
end; (* nextFreq *)


procedure findBestSound(fSearch : float; var best:SoundType);
var
  d, p        : Integer;
  fBest, fNew : float;
begin
  fBest:=1e10;

  for d:=0 TO NUM_DIST-1 do begin
    for p:=0 to 31 do begin
      fNew:=TIA_FREQ/DIST_DIV[d]/(p+1);
      if Abs(fSearch-fNew) < Abs(fSearch-fBest) then begin
        best.dist :=d;
        best.pitch:=p;
        fBest     :=fNew;
      end;
      if fNew < fSearch then Break;
    end;
  end;

  best.freq:=fBest;
end; (* findBestSound *)


function check(draw : WordBool; var sounds : SoundArrType) : float;
var
  i, j, dNote : Integer;
  fNew, fBase, cent : float;
  sx, sx2, sa, err : float;

  function calcError:float;
  (* calculates the frequency difference between all notes,
     the difference is weighted by the note difference *)
  var
    i, j, dNote : Integer;
    sx2, {sx, sa, fDiv,} fDivSum : float;
    cent : float;
  begin
    sx2:=0; {sx:=0;  fDivSum:=0;}

    for i:=1 to g_nNotes-1 do begin
      for j:=0 to i-1 do begin
        dNote:=Notes[i]-Notes[j];
        cent:=Ln(sounds[i].freq/sounds[j].freq) / Ln(Power(g_fFactor, dNote))*100-100;
        {fDiv:=Power(dNote, 0.0);
        fDivSum:=fDivSum +1/fDiv;
        sx :=sx  + cent / fDiv;
        sx2:=sx2 + Power(cent, 2) / fDiv;}
        sx2:=sx2 + Power(cent, 2);
      end;
    end;
    {calcError:=Power(sx2 / fDivSum, 0.5);}
    fDivSum:=g_nNotes * (g_nNotes-1)/2;
    calcError:=Power(sx2 / fDivSum, 0.5);

    {sa:=Power((sx2-(sx/fDivSum)*sx)/(fDivSum-1), 0.5);
    calcError:=sa;}
    {cnt:=g_nNotes * (g_nNotes-1)/2;}
    {calcError:=Power(sx2/fDivSum, 0.5);}
  end; (* calcError *)

begin (* check *)
  if draw then begin
    GotoXY(1,WhereY);
    WriteLn('Max. Frequency Difference: +/- ', MAX_FACTOR:0:1, '%');
    WriteLn('Max. Distance Factor     : +/- ', DIFF_FACTOR:0:1, '%');
    Write  ('Super Mode               : ');
    if S_MODE then
      WriteLn('enabled')
    else
      WriteLn('disabled');
    Write  ('Video mode               : ');
    if TIA_FREQ=31200 then
      WriteLn('PAL')
    else
      WriteLn('NTSC');
    WriteLn;
    WriteLn('Original Base-Frequency  : ', g_fOrgBase:7:2, ' Hz');
  end;
  (* calculate frequencies based on 1st note: *)
  (*for i:=0 to g_nNotes-1 do begin
    dNote:=Notes[i]-baseNote;
    findBestSound(g_fBase * Power(g_fFactor, dNote), sounds[i]);
  end;*)

  (* calculate new base frequency: *)
  (*sx:=0;
  for i:=0 to g_nNotes-1 do begin
    dNote:=Notes[i]-baseNote;
    fNew :=sounds[i].freq * Power(g_fFactor, -dNote);
    {WriteLn(i:2, dNote:3, fNew:8:1);}
    sx :=sx + fNew;
  end;
  fBase:=sx/g_nNotes;*)
  fBase:=g_fBase;

  (* iterate calculation: *)
  for j:=0 to 1 do begin
    if (j = 1) and draw then begin
      WriteLn('New Base-Frequency       : ', fBase:7:2, ' Hz', ' (', Ln(fBase/g_fOrgBase)/Ln(2)*100:0:1, '%)');
      WriteLn('Distance Factor          : ', g_fFactor:6:4, '(':6, ((g_fFactor-1)/(Power(2, 1/OCTAVE)-1)-1)*100:0:1, '%)');
      WriteLn;
      WriteLn(' #  Note  Opt.    TIA     Cent  Dist Pitch');
    end;
    sx:=0; sx2:=0;
    for i:=0 to g_nNotes-1 do begin
      dNote:=Notes[i]-baseNote;
      fNew:=fBase * Power(g_fFactor, dNote);

      cent:=toCent(fNew, sounds[i].freq);

      if (j = 1) and draw then begin
        Write  (i:2, note2Str(Notes[i]):5);
        WriteLn(fNew:8:1, sounds[i].freq:8:1, cent:7:1,'%', DIST_NUM[sounds[i].dist]:5, sounds[i].pitch:3);
      end;
      sx :=sx + cent;
      sx2:=sx2+ Power(cent, 2{1.414});
    end;

    {if (j = 1) and draw then begin
      Write  ('Exý/n: ', sx2/g_nNotes:0:2, '   Ex/n: ', sx:0:2);
      (* Standardabweichung: *)
      sa:=Power((sx2-(sx/g_nNotes)*sx)/(g_nNotes-1), 0.5);
      WriteLn('   dX: ', sa:5:3);
    end;}
    {WaitKey;}
    {if (j = 0) and Draw then
      WriteLn('old base-frequency:', fBase:8:2);}
    fBase:=addCent(fBase, sx/g_nNotes);
  end;
  {WaitKey;}
  sx2:=Power(sx2/(g_nNotes-1), 0.5); (* = Standardabweichung *) (* if sx = 0 then sa == sx2 *)
  sx:=calcError;

  err:=(sx*3 + sx2*0) / 3;
  if (draw) then
    WriteLn('Error: ', err:0:2);

  check:=err;
end; (* check *)


function combineNotes(var bestSounds : SoundArrType):double;
const
  progress : string = '|/-\';
var
  sounds   : SoundArrType;
  bestDiff : float;
  diff     : float;
  c,cc     : Integer;
  dNote    : Integer;

  procedure recCombine(i : Integer);
  var
    fSearch : float;
  begin
    if i = g_nNotes then begin
      diff:=check(False, sounds);
      if diff < bestDiff then begin
        bestDiff  :=diff;
        bestSounds:=sounds;
      end;
      if S_MODE then begin
        if cc = 0 then begin
          GotoXY(WhereX-1, WhereY);
          Write(progress[1 + c AND 3]);
          Inc(c);
          cc:=100;
        end;
        Dec(cc);
      end;
    end else begin
      dNote  :=Notes[i]-baseNote;
      fSearch:=g_fBase * Power(g_fFactor, dNote);

      findBestSound(fSearch, sounds[i]);
      if S_MODE then begin
        if i = 0 then begin
          recCombine(i+1);
          Exit;
        end;
        if sounds[i].freq <> sounds[i-1].freq then
          recCombine(i+1);

        if fSearch > sounds[i].freq then
          sounds[i].freq:=nextFreq(fSearch)
        else
          sounds[i].freq:=prevFreq(fSearch);
        if sounds[i].freq <> sounds[i-1].freq then
          recCombine(i+1);
      end else
        recCombine(i+1);
    end;
  end; (* recCombine *)

begin (* combineNotes *)
  bestDiff:=1E20;
  c:=0; cc:=0;
  recCombine(0);

  if S_MODE then begin
    GotoXY(WhereX-1, WhereY);
    Write('.|');
  end else
    Write('.');

  combineNotes:=bestDiff;
end; (* combineNotes *)


function iterateFrequencies(var bestSounds : SoundArrType) : float;
var
  fSave, fBest, bestDiff, diff : float;
  sounds : SoundArrType;
begin
  fBest:=g_fBase;
  bestDiff:=combineNotes(bestSounds);

  fSave:=g_fBase;
  while true do begin
    g_fBase:=nextFreq(g_fBase);
    if g_fBase > g_fHigh then break;

    diff:=combineNotes(sounds);
    if diff < bestDiff then begin
      bestDiff:=diff;
      fBest   :=g_fBase;
      bestSounds:=sounds;
    end;
  end;

  g_fBase:=fSave;
  while true do begin
    g_fBase:=prevFreq(g_fBase);
    if g_fBase < g_fLow then break;

    diff:=combineNotes(sounds);
    if diff < bestDiff then begin
      bestDiff:=diff;
      fBest   :=g_fBase;
      bestSounds:=sounds;
    end;
  end;
  WriteLn;

  g_fBase:=fBest;
  iterateFrequencies:=bestDiff;
end; (* iterateFrequencies *)


function iterateFactors(var bestSounds : SoundArrType):float;
var
  sounds                 : SoundArrType;
  i                      : Integer;
  bestFactor, saveFactor : float;
  bestDiff, diff         : float;
begin
  saveFactor:=g_fFactor;
  bestDiff:=1E20;

  for i:=0 to Round(DIFF_FACTOR*2) do begin
    g_fFactor:=1+(saveFactor-1)*(1+i/200);
    Write(g_fFactor:0:4, '':2);
    diff:=iterateFrequencies(sounds);
    if bestDiff > diff then begin
      bestFactor:=g_fFactor;
      bestDiff  :=diff;
      bestSounds:=sounds;
    end;
  end;
  {WriteLn;}

  for i:=-1 downto -Round(DIFF_FACTOR*2) do begin
    g_fFactor:=1+(saveFactor-1)*(1+i/200);
    Write(g_fFactor:0:4, '':2);
    diff:=iterateFrequencies(sounds);
    if bestDiff > diff then begin
      bestFactor:=g_fFactor;
      bestDiff  :=diff;
      bestSounds:=sounds;
    end;
  end;
  WriteLn;

  g_fFactor:=bestFactor;
  iterateFactors:=bestDiff;
end; (* iterateFactors *)


{procedure showSounds;
var
  freq : float;
  sound : SoundType;
begin
  freq:=0;
  repeat
    freq:=nextFreq(freq,sound);
    WriteLn(freq:7:1,DIST_NUM[sound.dist]:4,sound.pitch:3);
    WaitKey;
  until freq = TIA_FREQ/2;
end; (* showSounds *)}


procedure ConvertNotes(const strNotes : string);
var
  i, j, note : Integer;
begin
  i:=1; j:=0;
  while i < Length(strNotes) do begin
    if j = MAX_NOTES then begin
      WriteLn('Error: To many notes!');
      Halt(1);
    end;

    case UpCase(strNotes[i]) of
      'C': note := NOTE_C;
      'D': note := NOTE_D;
      'E': note := NOTE_E;
      'F': note := NOTE_F;
      'G': note := NOTE_G;
      'A': note := NOTE_A;
      'H': note := NOTE_H;
      else begin
        WriteLn('Error: Illegal note!');
        Halt(1);
      end;
    end;
    Inc(i);

    if '#' = strNotes[i] then begin
      Inc(note);
      Inc(i);
    end;

    if (strNotes[i] >= '0') and (strNotes[i] <= '9') then begin
      Inc(note, (Ord(strNotes[i])-Ord('0'))*OCTAVE);
      Inc(i);
    end else begin
      WriteLn('Error: Illegal octave!');
      Halt(1);
    end;

    Notes[j]:=note;
    Inc(j);

    while ' ' = strNotes[i] do Inc(i);
  end;
  g_nNotes:=j;
end; (* ConvertNotes *)


procedure ReadParams;
var
  i,error  : Integer;
  strParam : string;

begin
  WriteLn;
  WriteLn('Tune2600  Version 0.5 - Copyright (c) 2001  Thomas Jentzsch');

  for i:=1 to ParamCount do begin
    strParam:=ParamStr(i);
    case strParam[1] of
      '-','/' : begin
        case UpCase(strParam[2]) of
          'N' : begin
            NOTES_STR:=Copy(strParam,3,255);
            continue;
          end;
          'F' : begin
            Val(Copy(strParam,3,255),MAX_FACTOR,Error);
            MAX_FACTOR:=Abs(MAX_FACTOR);
            continue;
          end;
          'D' : begin
            Val(Copy(strParam,3,255),DIFF_FACTOR,Error);
            DIFF_FACTOR:=Abs(DIFF_FACTOR);
            continue;
          end;
          'S' : begin
            S_MODE:=True;
            continue;
          end;
          'P' : begin
            TIA_FREQ:=31200;
            continue;
          end;
        end; (* case *)
      end
    end; (* case *)

    WriteLn('Syntax: Tune2600 [/nNotes] [/fPercent] [/dPercent] [/c] [/p]');
    WriteLn('  /nNotes     list of ordered notes (i.E. c4d#4a4)');
    WriteLn('  /fPercent   maximum frequency difference (default: 100 = 1 octave)');
    WriteLn('  /dPercent   distance change between two notes (defautl: 5)');
    WriteLn('  /s          super mode, gives optimal results (SLOW!)');
    WriteLn('  /p          PAL mode (default: NTSC)');
    WriteLn;
    Halt(1);
  end;
  ConvertNotes(NOTES_STR);
end; (* ReadParams *)


var
  sound      : SoundType;
  bestSounds : SoundArrType;
  diff       : float;
begin
  (* calculate the frequency factor between two notes: *)
  g_fFactor:=Power(2, 1/OCTAVE);

  ReadParams;

  g_fOrgBase:=toFreq(Notes[0]);
  g_fLow :=toFreq(Notes[0]) / Power(g_fFactor, OCTAVE*MAX_FACTOR/100);
  g_fHigh:=toFreq(Notes[0]) * Power(g_fFactor, OCTAVE*MAX_FACTOR/100);

  findBestSound(toFreq(Notes[0]),sound);
  BaseNote:=Notes[0];
  g_fBase:=sound.freq;
  iterateFactors(bestSounds);

  check(True, bestSounds);
  WaitKey;
end.