unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Graphics, Forms, StdCtrls, Classes,
  Controls, Spin, ExtCtrls, Dialogs, ExtDlgs, MPlayer;

type
  TForm1 = class(TForm)
    plaat: TImage;
    SpinEdit1: TSpinEdit;
    SpinEdit2: TSpinEdit;
    Berichten: TLabel;
    SpinEdit3: TSpinEdit;
    OpenPictureDialog1: TOpenPictureDialog;
    Button1: TButton;
    Label6: TLabel;
    Bestandsnaam: TLabel;
    Button2: TButton;
    SpinEdit4: TSpinEdit;
    Label5: TLabel;
    Label7: TLabel;
    Label8: TLabel;
    Label9: TLabel;
    MediaPlayer1: TMediaPlayer;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

type
  TCoord = record
    x,y : LongInt;
  end;
  punt = record
    x,y : double;
  end;

const
{ Real disk size in mm: }
  diameter : double = 114;
  tanden : double = 3;
  geladen : boolean = false;
  nieuw : boolean = true;
var
  naam, muziek : string;
  centrum : punt;
  straal, schaal, terug : double;
  aantal, teller : integer;
  verzamel : array[0..500] of TCoord;
  links,rechts,boven,onder : TCoord;
{ Coordinates of holes in disk: }
  xx,yy : array[1..500] of double;
  tijd : array[1..500] of word;
  kount,waar, hoog : array[1..500] of byte;
  HulpScherm : TBitmap;

procedure Scherm(bericht : string);
{ Feedback messages on screen }
begin
  Form1.Berichten.Caption := bericht;
  Form1.Berichten.Update;
  Application.ProcessMessages;
end;

procedure Schijf(bericht : string);
{ Debugging and Logging }
const
  eerst : boolean = true;
var
  bug : text;
begin
  Assign(bug, 'musicbox.log');
  if eerst then Rewrite(bug);
  eerst := false;
  Append(bug);
  Writeln(bug, bericht);
  Closefile(bug);
end;

function binnen(w , p,q,r : punt) : boolean;
{        ======
  Inner domain of triangle
  ------------------------ }
var
  x1,y1,x2,y2, xp,yp, d,h,k,L, b : double;
begin
  x1 := q.x-p.x ; y1 := q.y-p.y ;
  x2 := r.x-p.x ; y2 := r.y-p.y ;
  xp := w.x-p.x ; yp := w.y-p.y ;

  d := (x1*y2 - y1*x2);
  h := (xp*y2 - yp*x2)/d;
  k := (x1*yp - y1*xp)/d;
  b := 1 ;
  L := 1-h-k;
  if h < b then b := h;
  if k < b then b := k;
  if L < b then b := L;
  binnen := (b >= 0);
end;

procedure Zoekcentrum;
{         ===========
   Find centre and size
   -------------------- }
var
  x,y, xb,yb,xe,ye, mx,my : integer;
  Flag : boolean;
  drempel : integer;
  grijs : longint;

procedure LaatZien;
{ Visualization }
begin
{ Midpoint = Red }
  HulpScherm.Canvas.pen.color := $0000FF;
  HulpScherm.Canvas.brush.color := $0000FF;
  mx := Trunc(centrum.x) ; my := Trunc(centrum.y);
  HulpScherm.Canvas.Ellipse(mx-2,my-2,mx+2,my+2);
{ Sizing = Green }
  HulpScherm.Canvas.pen.color := $00FF00;
  HulpScherm.Canvas.brush.color := $00FF00;
  HulpScherm.Canvas.Ellipse(boven.x-4,boven.y-4,
                            boven.x+4,boven.y+4);
  HulpScherm.Canvas.Ellipse(onder.x-4,onder.y-4,
                            onder.x+4,onder.y+4);
  HulpScherm.Canvas.Ellipse(links.x-4,links.y-4,
                            links.x+4,links.y+4);
  HulpScherm.Canvas.Ellipse(rechts.x-4,rechts.y-4,
                            rechts.x+4,rechts.y+4);
  Form1.plaat.Picture.Graphic := HulpScherm;
  Form1.Update;
end;

begin
  Scherm('Find Midpoint + Diameter');
  boven.y := 0 ; links.x := 0 ;
  boven.x := 0 ; links.y := 0 ;
  onder.x := 0 ; rechts.y := 0 ;
  rechts.x := 0 ; onder.y := 0 ;
  xb := 2 ; xe := HulpScherm.width-3 ;
  yb := 2 ; ye := HulpScherm.height-3 ;
  drempel := Form1.SpinEdit1.Value;
  grijs := $10101 * drempel;

  Flag := False;
  for y := yb to ye do
  begin
    for x := xb to xe do
    begin
      if HulpScherm.Canvas.Pixels[x,y] <= grijs then
      begin
        boven.y := y;
        boven.x := x;
        flag := True;
      end;
      if Flag then Break;
    end;
    if Flag then Break;
  end;

  Flag := False;
  for y := ye downto yb do
  begin
    for x := xe downto xb do
    begin
      if HulpScherm.Canvas.Pixels[x,y] <= grijs then
      begin
        onder.y := y;
        onder.x := x;
        flag := True;
      end;
      if Flag then Break;
    end;
    if Flag then Break;
  end;

  Flag := False;
  for x := xb to xe do
  begin
    for y := yb to ye do
    begin
      if HulpScherm.Canvas.Pixels[x,y] <= grijs then
      begin
        links.x := x;
        links.y := y;
        flag := True;
      end;
      if Flag then Break;
    end;
    if Flag then Break;
  end;

  Flag := False;
  for x := xe downto xb do
  begin
    for y := ye downto yb do
    begin
      if HulpScherm.Canvas.Pixels[x,y] <= grijs then
      begin
        rechts.x := x;
        rechts.y := y;
        flag := True;
      end;
      if Flag then Break;
    end;
    if Flag then Break;
  end;

{ Radius, scaling and centre: }
  straal := 0.5*sqrt((rechts.x-links.x)*(onder.y-boven.y));
  schaal := 0.5*diameter / straal;
  terug := 1/schaal;
  straal := straal * (1 - tanden/(0.5*diameter));
  centrum.x := (rechts.x + links.x)/2;
  centrum.y := (onder.y + boven.y)/2;
  LaatZien;
end;

function Floodfill(x,y : integer) : boolean;
{        =========
  Linear FloodFill
  ---------------- }
const
  gaatje : double = 10;
var
  buf : array[0..500] of TCoord;
  bufbegin,bufeind : integer;
  drempel, mini,maxi : integer;
  b : TCoord;
  vol : boolean;
  plaats, gat : double;
begin
{ User Input: }
  drempel := Form1.SpinEdit1.Value;
  mini := Form1.SpinEdit2.Value;
  maxi := Form1.SpinEdit3.Value;

  vol := True;
  teller := 0;
  bufbegin := 0;
  bufeind := 0;
  buf[0].x := x;
  buf[0].y := y;
  gat := gaatje*terug;
  while bufeind >= bufbegin do
  begin
    if bufeind > 996 then bufeind := 0;
    if bufbegin > 996 then bufbegin := 0;
    b := buf[bufbegin];
  { For all points inside the disk: }
    plaats := sqrt(sqr(b.x - centrum.x)+sqr(b.y - centrum.y));
    with HulpScherm.Canvas do
    if (plaats < straal) and (plaats > gat) then
    if Pixels[b.x,b.y] and $0000FF > drempel then
    begin
      Pixels[b.x,b.y] := $00FF00;
      teller := teller + 1;
      if teller > 500 then
      begin
        Schijf('ERROR: too many pixels in disk hole');
        teller := teller - 1;
      end;
      verzamel[teller] := b;

      if Pixels[b.x+1,b.y] and $0000FF > drempel then
      begin
        bufeind := bufeind + 1;
        buf[bufeind].x := b.x+1;
        buf[bufeind].y := b.y;
      end;

      if Pixels[b.x-1,b.y] and $0000FF > drempel then
      begin
        bufeind := bufeind + 1;
        buf[bufeind].x := b.x-1;
        buf[bufeind].y := b.y;
      end;

      if Pixels[b.x,b.y+1] and $0000FF > drempel then
      begin
        bufeind := bufeind + 1;
        buf[bufeind].x := b.x;
        buf[bufeind].y := b.y+1;
      end;

      if Pixels[b.x,b.y-1] and $0000FF > drempel then
      begin
        bufeind := bufeind + 1;
        buf[bufeind].x := b.x;
        buf[bufeind].y := b.y-1;
      end;
    end;
    bufbegin := bufbegin + 1;
  end;
{ Discard impossible domains: }
  if teller > maxi then
    vol := False;
  if teller < mini then
    vol := False;

  Floodfill := vol;
end;

procedure Berekening;
{         ==========
  Some Calculations
  ----------------- }
var
  midden, hoofd, resultaat : punt;
  sigma_xx,sigma_yy,sigma_xy,
  wortel,waarde,lengte,det,extra : double;
  i, mx,my : integer;
begin
{ Mean / Center of gravity: }
  midden.x := 0;
  midden.y := 0;
  for i := 1 to teller do
  begin
    midden.x := midden.x + verzamel[i].x;
    midden.y := midden.y + verzamel[i].y;
  end;
  midden.x := midden.x/teller;
  midden.y := midden.y/teller;
{ Correllations / Moments of inertia: }
  sigma_xx := 0;
  sigma_yy := 0;
  sigma_xy := 0;
  for i := 1 to teller do
  begin
    sigma_xx := sigma_xx + verzamel[i].x*verzamel[i].x;
    sigma_yy := sigma_yy + verzamel[i].y*verzamel[i].y;
    sigma_xy := sigma_xy + verzamel[i].x*verzamel[i].y;
  end;
  sigma_xx := (sigma_xx - teller*midden.x*midden.x)/(teller-1);
  sigma_yy := (sigma_yy - teller*midden.y*midden.y)/(teller-1);
  sigma_xy := (sigma_xy - teller*midden.x*midden.y)/(teller-1);
{ Biggest eigenvalue: }
  wortel := sqrt(sqr(sigma_xx - sigma_yy) + 4*sqr(sigma_xy));
  waarde := 0.5*(sigma_xx + sigma_yy + wortel);
{ The other eigenvalue analogously = - wortel .
  Accompanying eigenvector must be non-zero: }
  if sigma_yy < sigma_xx then
  begin
    hoofd.x := sigma_yy - waarde;
    hoofd.y := - sigma_xy;
  end;
  if sigma_xx < sigma_yy then
  begin
    hoofd.x := - sigma_xy;
    hoofd.y := sigma_xx - waarde;
  end;
  lengte := sqrt(sqr(hoofd.x) + sqr(hoofd.y));
  hoofd.x := hoofd.x/lengte;
  hoofd.y := hoofd.y/lengte;
{ Theoretical spread of interval [-a,+a] = sqrt((a^2)/3)
  giving a Default value of 3 for the length of a hole }
  extra := Form1.SpinEdit4.Value;
  waarde := sqrt(extra*waarde);
  hoofd.x := waarde*hoofd.x;
  hoofd.y := waarde*hoofd.y;
{ Toggles are in counterclockwise direction }
  det := (midden.x-centrum.x)*hoofd.y
       - (midden.y-centrum.y)*hoofd.x ;
  if det < 0 then
  begin
    resultaat.x := midden.x + hoofd.x;
    resultaat.y := midden.y + hoofd.y;
  end;
  if det > 0 then
  begin
    resultaat.x := midden.x - hoofd.x;
    resultaat.y := midden.y - hoofd.y;
  end;
{ Toggle found: }
  aantal := aantal + 1;
  if aantal > 500 then
  begin
    Schijf('ERROR: too many notes');
    aantal := aantal - 1;
  end;
  Scherm('# Music Notes = '+IntToStr(aantal));
{ Real world coordinate system right oriented: }
  xx[aantal] := + schaal*(resultaat.x - centrum.x);
  yy[aantal] := - schaal*(resultaat.y - centrum.y);
  HulpScherm.Canvas.pen.color := $FF0000;
  HulpScherm.Canvas.brush.color := $FF0000;
  mx := Trunc(resultaat.x) ; my := Trunc(resultaat.y);
  Hulpscherm.Canvas.Ellipse(mx-2,my-2,mx+2,my+2);
end;

procedure Zoekpunten;
{         ==========
  Find music information
  ---------------------- }
var
  x,y : integer;
  y1,y2 : integer;
  rechthoek : TRect;
  abscis, kwadraat, wortel : double;
  drempel : integer;
begin
  drempel := Form1.SpinEdit1.Value;
  if not nieuw then
    Form1.plaat.Picture.LoadFromFile(naam);
  HulpScherm := TBitmap.Create;
  HulpScherm.Height := Form1.Plaat.Picture.Height;
  HulpScherm.Width := Form1.Plaat.Picture.Width;
  rechthoek := Rect(0,0,HulpScherm.Width-1,
                        HulpScherm.Height-1);
  HulpScherm.Canvas.CopyRect(rechthoek,
          Form1.plaat.Canvas,rechthoek);
{ Zwart_Wit;  }
  Zoekcentrum;

{ Find music information: }
  aantal := 0;
  for x := links.x to rechts.x do
  begin
    abscis := (x - centrum.x)*(x - centrum.x);
    kwadraat := 0.25*(rechts.x - links.x)*(onder.y - boven.y);
    wortel := sqrt(abs(kwadraat - abscis));
    y1 := Round(centrum.y - wortel);
    y2 := Round(centrum.y + wortel);
    for y := y1 to y2 do
      if HulpScherm.Canvas.Pixels[x,y] and $0000FF > drempel then
        if Floodfill(x,y) = True then Berekening;
  end;
  Form1.plaat.Picture.Graphic := HulpScherm;
  Form1.Update;
  HulpScherm.Free;
end;

{ ******************************************************* }

function hoek(x,y : double) : double;
{        ====
  Computation of angle (normed)
  ----------------------------- }
var
  f : double;
begin
  f := 0;
  if (x >= 0) and (y <= +x) and (y >= -x) then f := ArcTan(y/x);
  if (x <= 0) and (y <= -x) and (y >= +x) then f := Pi + ArcTan(y/x);
  if (y >= 0) and (x <= +y) and (x >= -y) then f := Pi/2 - ArcTan(x/y);
  if (y <= 0) and (x <= -y) and (x >= +y) then f := Pi + Pi/2 - ArcTan(x/y);
  if f < 0 then f := f + 2*Pi;
  hoek := f/(2*Pi);
end;

procedure TelSort;
{         =======
  Sorting by counting.
  Algorithm C on page 76 of "The Art of Computer Programming"
  volume 3 / "Sorting and Searching" by Donald E. Knuth
}
var
  i,j,k,L : byte;
begin
  for k := 1 to aantal do
    kount[k] := 0;
  for k := 0 to (aantal-2) do
  begin
    i := aantal - k;
    for L := 1 to (i-1) do
    begin
      j := i - L;
      if tijd[i] < tijd[j] then
         kount[j] := kount[j] + 1
      else
         kount[i] := kount[i] + 1;
    end;
  end;
end;

function StartHoek : double;
{        =========
  Find beginning of song
  ---------------------- }
const
{ Void area estimate: }
  deel : integer = 24;
var
  stuk, effe : double;
  a,b,c, w : punt;
  leeg : boolean;
  mx,my, t,k : integer;
begin
  effe := 0;
  stuk := 2*Pi/deel;
  for t := 1 to deel do
  begin
    a.x := 0 ; a.y := 0 ;
    b.x := 0.5*diameter * cos(stuk*(t-1));
    b.y := 0.5*diameter * sin(stuk*(t-1));
    c.x := 0.5*diameter * cos(stuk*t);
    c.y := 0.5*diameter * sin(stuk*t);
    leeg := True;
    for k := 1 to aantal do
    begin
      w.x := xx[k] ; w.y := yy[k] ;
      if not binnen(w, a,b,c) then Continue;
      leeg := False ; Break;
    end;
    if leeg then
    begin
      Form1.plaat.Canvas.Pen.Color := $00FFFF;
      mx := Trunc(centrum.x) ; my := Trunc(centrum.y);
      Form1.plaat.Canvas.MoveTo(mx,my);
      mx := Round(centrum.x + terug*0.5*(b.x+c.x));
      my := Round(centrum.y - terug*0.5*(b.y+c.y));
      Form1.plaat.Canvas.LineTo(mx,my);
      Form1.Update;
      effe := Hoek(0.5*(b.x+c.x),0.5*(b.y+c.y));
      Break;
    end;
  end;
  StartHoek := effe;
end;

procedure MusicBox;
{         ========
  Mathematical Model of the Music Box
  ----------------------------------- }
const
{ Tuning of the MusicBox's voices: }
  Toon : array[0..29] of byte =
  ( 52,59, { C4 } 64,66,68,71,71,
           { C5 } 73,75,76,78,81,83,
           { C6 } 85,87,88,88,90,90,92,92,93,93,94,95,95,
           { C7 } 97,97,99,100);
var
  k, pin : integer ;
  r,psie,del : double;
  start, helling, glijd : double;
  gs,gc , xg,yg : double;
  aan : array[0..29] of boolean;
{ Inverse of Toon: }
  noot : array[52..100] of byte;
{ MidiFile: }
  midi : array[1..2500] of byte;
  W : integer;

function ByteCount(del : integer) : byte;
var
  d : integer;
  b : byte;
begin
  d := del;
  b := 1;
  while d >= 128 do
  begin
    d := (d shr 7);
    b := b + 1;
  end;
  ByteCount := b;
end;

procedure Put_Delta_Time(del : integer);
var
  d : integer;
  tel, k : byte;
begin
  d := del;
  tel := ByteCount(d);
  W := W + integer(tel);
  midi[W] := byte(d and $007F);
  if tel=1 then Exit;
  for k := 1 to tel-1 do
  begin
    d := d shr 7;
    midi[W-k] := byte(d and $007F) or $80;
  end;
end;

procedure Doe_Kop;
const
  kop : array[1..42] of byte =
  { FileHeader                              0        1       96 }
  ( $4D,$54,$68,$64, $00,$00,$00,$06, $00,$00, $00,$01, $00,$60,
  { TrackHeader      4 bytes = size     0  Meta $51(Tempo) 600000 }
    $4D,$54,$72,$6B, $00,$00,$03,$18, $00, $FF, $51,       $03,$09,$27,$C0,
  { 20   Program ch$0 $0A(Music Box) ; 20   Control ch$0 $07(Volume) 100 }
   $14,  $C0,         $0A,            $14,  $B0,         $07,       $64,
  { 20   Control ch$0 $0A(Stereo) 64 ; 20 ; Control ch$0 $0B(Expression) 127 }
   $14,               $0A,       $40, $14,               $0B,           $7F );
var
  k : integer;
begin
  for k := 1 to 42 do
    midi[k] := kop[k];
  W := 42;
end;

procedure Doe_Staart;
const
  staart : array[1..7] of byte =
{ Control $0 $7B(All Notes Off) $0 }
( $B0,       $7B,               $0,
{  20   Meta $2F(TrkEnd) }
  $14 , $FF, $2F, $00 );
var
  k : integer;
begin
  Put_Delta_Time(120);
  for k := 1 to 7 do
    midi[W + k] := staart[k];
  W := W + 7;
end;

procedure Maak_Track_Af;
const
  hier : integer = 22;
var
  nr : integer;
  k : integer;
begin
  nr := W - hier;
  for k := 0 to 3 do
  begin
    midi[hier - k] := byte(nr and $00FF);
    nr := nr shr 8;
  end;
end;

procedure Midi_UitVoer;
var
  eruit : file;
begin
{ Midi File: }
  muziek := copy(naam,1,length(naam)-3)+'mid';
  AssignFile(eruit,muziek);
  Rewrite(eruit,1);
  BlockWrite(eruit, midi, W);
  Close(eruit);
end;

begin
{ Transform all points
  according to beginning: }
  psie := StartHoek;
  gc := cos(2*Pi*psie);
  gs := sin(2*Pi*psie);
  for k := 1 to aantal do
  begin
    xg := + xx[k]*gc + yy[k]*gs;
    yg := - xx[k]*gs + yy[k]*gc;
    xx[k] := xg ; yy[k] := yg ;
  end;

  for k := 1 to aantal do
  begin
  { Convert to polar coordinates: }
    r := sqrt(xx[k]*xx[k] + yy[k]*yy[k]);
  { Song recorded counterclockwise on Scan: }
    psie := hoek(xx[k],yy[k]);
  { Correct angles for radial dependance: }
    del := 0.4;
    tijd[k] := Round(3600*(psie + del/r));
  { Pitch of tones: }
    pin := Round(30*(r-14.5)/41);
    if (pin < 0) or (pin > 29) then
      Schijf('No tone corresponding with pin '
        +IntToStr(k)+' : '+IntToStr(pin))
    else
      hoog[k] := Toon[pin];
  end;

  TelSort; {: sort by increasing time }

  for k := 1 to aantal do
    waar[kount[k]+1] := k;

{ Initialize music: }
  for k := 0 to 29 do
  begin
    aan[k] := false;
    noot[Toon[k]] := k;
  end;

{ Header: }
  Doe_Kop;

  Put_Delta_Time(tijd[waar[1]]);
  start := 75 ; helling := 1 ; k := 1 ;
  glijd := start + helling*(hoog[waar[k]] - Toon[0]);
  midi[W + 1] := $90;
  midi[W + 2] := byte(hoog[waar[k]]);
  midi[W + 3] := byte(Round(glijd));
  W := W + 3;
  aan[noot[hoog[waar[k]]]] := true;

{ Midi Music: }
  for k := 2 to aantal do
  begin
    Put_Delta_Time(tijd[waar[k]]-tijd[waar[k-1]]);
  { Because high tones sound louder than low tones: }
    glijd := start + helling*(hoog[waar[k]] - Toon[0]);
    if aan[noot[hoog[waar[k]]]] then
    begin
      midi[W + 1] := byte(hoog[waar[k]]);
      midi[W + 2] := 0; { Note Off }
      midi[W + 3] := 0; { Delta Time }
      W := W + 3;
    end;
    midi[W + 1] := byte(hoog[waar[k]]);
    midi[W + 2] := byte(Round(glijd));
    W := W + 2;
    aan[noot[hoog[waar[k]]]] := true;
  end;

{ Ending: }
  Doe_Staart;
  Maak_Track_Af;
  Midi_UitVoer;
  with Form1.MediaPlayer1 do
  begin
    FileName := muziek;
    Open;
    EnabledButtons := [btPlay,btPause,btStop,btNext,btPrev];
    Play;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  i : integer;
begin
  geladen := false;
  if Form1.OpenPictureDialog1.Execute then
  begin
    naam := Form1.OpenPictureDialog1.FileName;
    for i := length(naam) downto 1 do
      if naam[i] = '\' then
      begin
        Form1.Bestandsnaam.Caption := copy(naam,i+1,length(naam)-i);
        Break;
      end;
  end;
  if Length(naam) < 5 then Exit;
  Form1.plaat.Picture.LoadFromFile(naam);
  Scherm('Messages');
  geladen := true;
  nieuw := true;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  if not geladen then Exit;
  Cursor := crHourGlass;
  Zoekpunten;
  if aantal = 0 then Exit;
  Form1.MediaPlayer1.Close;
  MusicBox;
  Scherm('MidiFile Ready !!');
  nieuw := false;
  Cursor := crDefault;
end;

end.