unit Unit1;
{
  PunchCard Reader
  ================
  This program has been designed and is CopyLefted by:

* Han de Bruijn; Systems for Research "A little bit of Physics would be  (===)
* and Education (DTO/SOO), Mekelweg 6  NO Idleness in Mathematics"(HdB) @-O^O-@
* 2628 CD Delft, The Netherlands  http://huizen.dto.tudelft.nl/deBruijn  #/_\#
* E-mail: Han.deBruijn@DTO.TUDelft.NL  Tel: +31 15 27 82751. Fax: 81722   ###

All I ask is to be credited when it is appropriate.
}
INTERFACE

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls, ExtDlgs, Algemeen, BMPunit, Menus, Ogenblik;

type
  TForm1 = class(TForm)
    OpenPictureDialog1: TOpenPictureDialog;
    Image1: TImage;
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    Open1: TMenuItem;
    Panel1: TPanel;
    Edit1: TEdit;
    Exit1: TMenuItem;
    Process1: TMenuItem;
    Select1: TMenuItem;
    procedure Starten(Sender: TObject);
    procedure Stoppen(Sender: TObject);
    procedure Open1Click(Sender: TObject);
    procedure Process1Click(Sender: TObject);
    procedure Select1Click(Sender: TObject);
    procedure Kiezen(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Exit1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

IMPLEMENTATION

{$R *.dfm}

var
  geklaard : boolean;
  naam : string;
  HulpScherm : TBitmap;
  model : Ponskaart;
  kaart,soort,volgorde : integers;
  onthouden : array of moment;
  negatief : integer;
  coordinaten : punten;
  kodering : array[0..62] of string;
  eenmalig : boolean;
  steun,rechts,omhoog : vektor;
  ondersteund : boolean;

procedure ClearDevice;
{
  Clear BitMap
}
var
  rechthoek : TRect;
begin
  HulpScherm.Width := Wijd;
  HulpScherm.Height := Hoog;
  rechthoek := Rect(0,0,Wijd,Hoog);
  with HulpScherm.Canvas do
  begin
    Brush.Color := clWhite;
    FillRect(rechthoek);
  end;
end;

function Verfje : TColor;
{
  Red, Green, Blue
}
const
  heden : integer = 0;
  basis : array[0..3] of TColor = 
  ($000000, $0000FF, $00FF00, $FF0000);
begin
  heden := (heden mod 3) + 1;
  Verfje := basis[heden];
end;

procedure AssenStelsel(m,v : vektor);
{
  Draw Midpoint and Axes
}
var
  xm,ym, dx,dy : integer;
begin
  xm := Round(m.x);
  ym := Round(m.y);
  dx := Round(50*v.x);
  dy := Round(50*v.y);
  with HulpScherm.Canvas do
  begin
    Ellipse(xm-3,ym-3,xm+3,ym+3);
    MoveTo(xm,ym);
    LineTo(xm+dx,ym+dy);
    MoveTo(xm,ym);
    LineTo(xm+dy,ym-dx);
  end;
end;

function Afwijkend(C : Contour; P : Ponskaart; blah : boolean) : boolean;
{ 
  Differences between Specimen and Model
}
var
  goed : boolean;

  function Bekeken(u,v,w : double) : boolean;
  var
    OK : boolean;
    vgl : string;
  begin
    OK := abs(u-v) < w;
    if OK then vgl := ' < ' else vgl := ' > ';
    if blah then Writeln('| ',u:15:5,' - ',v:15:5,' |',vgl,w:15:5);
    if blah then Readln;
    Bekeken := OK;
  end;

begin
  Afwijkend := true;

  if blah then Writeln('Specimen versus Model:');
  goed := Bekeken(C.vlak.Inhoud,P.vlak.Inhoud,P.deltaOpp);
  if not goed then Exit;
  goed := Bekeken(C.vlak.Spoor,P.vlak.Spoor,P.deltaSp);
  if not goed then Exit;
  goed := Bekeken(C.vlak.Determinant,P.vlak.Determinant,P.deltaDet);
  if not goed then Exit;

  Afwijkend := false;
end;

function Vergelijken(praktijk : Contour; theorie : Ponskaart;
                                         blah : boolean) : boolean;
{ Compare Contour with Model
}
var
  als : boolean;
  L : integer;
begin
  Vergelijken := false;
  L := Huidige;
  praktijk.Hoofdzaken;
  als := Afwijkend(praktijk,theorie,false);
  if als then KansloosMaken(L);
  if als then Exit;

  if blah then
  begin
    Writeln('Area, Trace and Determinant:');
    Writeln(praktijk.vlak.Inhoud:15:5,
            praktijk.vlak.Spoor:15:5,
            praktijk.vlak.Determinant:15:5,
            '   : specimen');
    Writeln(theorie.vlak.Inhoud:15:5,
            theorie.vlak.Spoor:15:5,
            theorie.vlak.Determinant:15:5,
            '   : model');
  end;
  Vergelijken := true;
end;

function Aankaarten : boolean;
{
  Process PunchCards
}
var
  n,m, k,L : integer;
  opp : double;
  inhoud : array of double;
  r : vektor;
  curve : Contour;
  gaten : Ponskaart;
  goed : boolean;
  fouteboel : boolean;
begin
  Aankaarten := false;

  curve := Contour.Create;
  SetLength(inhoud,Aantal+1);
  SetLength(soort,Aantal+1);
  SetLength(volgorde,Aantal+1);

{ Select and Sort on Area First }
  negatief := 0;
  for n := 1 to Aantal do
  begin
    curve.Definitie(Kromme(n));
    curve.Eenvoudig;
    opp := curve.vlak.Inhoud;
    if abs(opp) < 1 then 
    begin
      KansloosMaken(n);
      inhoud[n] := 0;
      Continue;
    end;
    inhoud[n] := - opp;
  { Cards have negative Area
    Holes have positive Area }
    if inhoud[n] < 0 then
      negatief := negatief + 1;
  end;
  if negatief = 0 then Exit;
  soort := TelSort(inhoud);
{
  for n := 1 to negatief do
  begin
    m := soort[n];
    Writeln(m:5,inhoud[m]);
  end;
}
{ Model of PunchCard as a Whole }
  model := Ponskaart.Create;
{ model.Resolutie := 1/0.254; }
  model.Resolutie := PerMM;
  model.Omtrek(model.Resolutie);
  model.Grootheden;

  fouteboel := true;
{ More Advanced Selection Procedure }
  SetLength(onthouden,negatief+1);
  for n := 1 to negatief do
  begin
    L := soort[n];
    curve.Definitie(Kromme(L));
    curve.Hoofdzaken;
    goed := Vergelijken(curve,model,true);
    if not goed then Continue;
    model.Georienteerd(curve,true);
  { Memorize & Compress valid Cards }
    onthouden[n] := curve.vlak;
    FanDataCompressie(L);
    fouteboel := false;
  end;
  if fouteboel then Writeln('fouteboel');
  if fouteboel then Exit;

{ Punched Holes in a Card }
  gaten := Ponskaart.Create;
{ gaten.Resolutie := 1/0.254; }
  gaten.Resolutie := PerMM;
  gaten.EenGat(0.5);
  gaten.Grootheden;

{ Selection Procedure for Holes }
  for n := negatief+1 to Aantal do
  begin
    L := soort[n];
    if isKansloos(L) then Continue;
    curve.Definitie(Kromme(L));
    curve.Hoofdzaken;
    Vergelijken(curve,gaten,false);
  end;

  TijdMeting('');
  SetLength(kaart,Aantal+1);
  for n := 1 to Aantal do
    kaart[n] := 0;

{ Attach Holes to PunchCards }
  for m := 1 to negatief do
  begin
    Application.ProcessMessages;
    L := soort[m];
    kaart[L] := L;
    if isKansloos(L) then Continue;
    curve.Definitie(Kromme(L));
    for n := negatief+1 to Aantal do
    begin
      k := soort[n];
      if isKansloos(k) then Continue;
      if kaart[k] > 0 then Continue;
      r := StartPunt(k);
      if curve.Binnen(r) then kaart[k] := L;
    end;
  end;
  TijdMeting('Punched inside / outside');
 
  for n := 1 to Aantal do
    inhoud[n] := kaart[n];
  volgorde := TelSort(inhoud);
  Aankaarten := true;
end;

procedure Nakaarten(naam : string);
{
  Just a Test
}
var
  ff : TextFile;
  k : integer;
begin
  AssignFile(ff,naam);
  Rewrite(ff);
  for k := 1 to Aantal do
    Writeln(ff,volgorde[k]:5,
               kaart[volgorde[k]]:5);
  CloseFile(ff);
end;

procedure Schetsen(krom : Jordan; Scherm : TBitmap; C : TColor);
{
  Do the Drawing
}
var
  k,L, x,y : integer;
begin
  L := Length(krom);
  x := Round(krom[L-1].x);
  y := Round(krom[L-1].y);
  Scherm.Canvas.Pen.Color := C;
  Scherm.Canvas.MoveTo(x,y);
  for k := 0 to L-1 do
  begin
    x := Round(krom[k].x);
    y := Round(krom[k].y);
    Scherm.Canvas.LineTo(x,y);
  end;
end;

procedure Zichtbaar;
{
  Show all Contours on screen
}
var
  k,L,v : integer;
  C : TColor;
  curve : Contour;
  q,r : vektor;
  rand,gaten : Jordan;
begin
  ClearDevice;
  L := volgorde[1];
  C := Verfje;
  r := model.vlak.Midden;
  q := model.vlak.Hoofdas;
  curve := Contour.Create;
  SetLength(rand,0);
  SetLength(gaten,0);

  for k := 1 to Aantal do
  begin
    v := L;
    L := volgorde[k];
    if isKansloos(L) then Continue;
  { Coloring belonging to PunchCard }
    if kaart[L] > kaart[v] then C := Verfje;
    Tekenen(HulpScherm,L,C);
    if kaart[L] <> L then Continue;
  { For PunchCards as a whole }
    curve.Definitie(Kromme(L));
    curve.Hoofdzaken;
    model.Georienteerd(curve,false);
  { Axes of Inertia }
  { AssenStelsel(curve.vlak.Midden,
                 curve.vlak.Hoofdas); }
  { Draw Model for Comparison }
    rand := model.AfbeeldenOp(curve);
    Schetsen(rand,HulpScherm,clBlack);
  end;
  Form1.Image1.Picture.Graphic := HulpScherm;
  Form1.Update;
end;

function Grijs(getal : double) : TColor;
{
  Translates Real into Grey values
}
var
  even,k : byte;
  effe : Tcolor;
begin
  if getal < 0 then getal := 0;
  if getal > 1 then getal := 1;
  effe := 0;
  for k := 1 to 3 do
  begin
    even := Round(255*(1-getal));
    effe := (effe shl 8) or even;
  end;
  Grijs := $00000000 or effe;
end;

function UitBestand : boolean;
{
  PunchCard Specifications
  ------------------------
  according to a TextFile
}
const
  IBM : string = 'ibmkaart.txt';
var
  ff : TextFile;
  regel,s : string;
  k,m : integer;
  eerst : boolean;
begin
  UitBestand := false;
  eerst := FileExists(IBM);
  if not eerst then
  begin
    Form1.Edit1.Font.Color := clRed;
    Form1.Edit1.text := 'TextFile  "' + IBM +
    '"  with punchcard specifications: missing';
    Exit;
  end;
  AssignFile(ff,IBM);
  Reset(ff);
  kodering[0] := '?';
  try
    for k := 1 to 11 do
      Readln(ff,regel);
    Readln(ff,regel);
    for k := 1 to 62 do
      kodering[k] := regel[k+4];
    Readln(ff,regel);
    for k := 1 to 12 do
    begin
      Readln(ff,regel);
      for m := 1 to 62 do
      begin
        s := kodering[m];
        kodering[m] := s + regel[m+4];
      end;
    end;
  except
    begin
      Form1.Edit1.Font.Color := clRed;
      Form1.Edit1.text := 'Errors in  "' + IBM +
      '"  with supposed punchcard specifications';
      Exit;
    end;
  end;
  CloseFile(ff);
{
  for m := 1 to 62 do
    Writeln(kodering[m]);
}
  UitBestand := true;
end;

procedure Begrijpen;
{
  Understanding PunchCard's Content
}
var
  vgl : array[1..80] of string;
  k,i,j,L : integer;
  s,leeg,vol : string;
  OK : boolean;
begin
  OK := UitBestand;
  if not OK then Exit;
  SetLength(leeg,12);
  for k := 1 to 12 do
     leeg[k] := ' ';
  for k := 1 to 80 do
    vgl[k] := leeg;

  L := Length(coordinaten);
  for k := 1 to L-1 do
  begin
    i := coordinaten[k].x;
    j := coordinaten[k].y;
    s := vgl[81-i];
    s[13-j] := 'O';
    vgl[81-i] := s;
  end;

  Writeln('Rendering of PunchCard (1-72):');
  vol := '';
  OK := true;
  for k := 1 to 72 do
    Write('-');
  Writeln;
  for i := 1 to 72 do
  begin
    j := 0;
    for k := 1 to 62 do
    begin
      s := Copy(kodering[k],2,13);
      if s <> vgl[i] then Continue;
      j := k; Break;
    end;
    s := kodering[j];
    vol := vol + Copy(s,1,1);
    if j = 0 then OK := false;
  end;
  Writeln(vol);
  for k := 1 to 72 do
    Write('-');
  Writeln;
  if not OK then Writeln('? = unknown');
  if OK then
    Form1.Edit1.Font.Color := clBlack
  else
    Form1.Edit1.Font.Color := clRed;
  Form1.Edit1.text := vol;
end;

procedure Visualisatie(BW : TColor);
{
  Visualization
}
var
  i,j : integer;
  r : vektor;
  xm,ym : integer;
begin
{ Visualization of Grid }
  for i := 0 to 80-1 do
  for j := 0 to 12-1 do
  begin
    r.x := steun.x + rechts.x*i + omhoog.x*j;
    xm := Round(r.x);
    r.y := steun.y + rechts.y*i + omhoog.y*j;
    ym := Round(r.y);
    Form1.Image1.Canvas.Pixels[xm,ym] := BW;
  end;
end;

procedure KaartLezen(deze : integer);
{
  Read PunchCard
}
const
  eps : double = 1.E-9;
var
  klein,curve : Contour;
  standaard,nogmaals : moment;
  k,tel,i,j : integer;
  iteratie,Lengte : integer;
  bewaard : momenten;
  G,V, waarde,maximum : double;
  A,p,q,r, mu : vektor;
  S : matrix; b : kolom;
  ruimte : VektorRuimte;
  verdeling : Schuine;
  sigma : tensor;
  gelukt : boolean;
  nauwkeurig : double;

  function overslaan(L : integer) : boolean;
  {
    Skipping
  }
  begin
    overslaan := true;
    if isKansloos(L) then Exit;
    if L = kaart[L] then Exit;
    if kaart[L] <> deze then Exit;
    overslaan := false;
  end;

  procedure Resultaat(extra : string);
  {
    Result of Iterative Solution
  }
  begin
    Writeln('Quality of Fit at ' + extra + ' = ',
            (100*G/Lengte):4:1,' %');
  end;

begin
  if ondersteund then
    Visualisatie(clWhite);

  tel := 0;
  for k := 1 to negatief do
  begin
    tel := k;
    if soort[k] = deze then Break;
  end;
{ Main Data of whole PunchCard }
  nogmaals := onthouden[tel];

  curve := Contour.Create;
  curve.Definitie(Kromme(deze));
  curve.Hoofdzaken;
  nauwkeurig := model.Georienteerd(curve,false);
  if nauwkeurig < 10 then { Educated Guess }
  begin
    Form1.Edit1.Font.Color := clRed;
    Form1.Edit1.text := 
    'This card should be scanned again: face up and backside down';
    Exit;
  end;
  Form1.Edit1.Font.Color := clBlack;
  Form1.Edit1.text := '';
  tel := 0;
  for k := 1 to Aantal do
    if not overslaan(k) then
      tel := tel + 1;
  SetLength(bewaard,tel+1);
  SetLength(coordinaten,tel+1);

{ Main Data of Punched Holes }
  tel := 0;
  klein := Contour.Create;
  for k := 1 to Aantal do
  begin
    if overslaan(k) then Continue;
    klein.Definitie(Kromme(k));
    klein.Hoofdzaken;
    tel := tel + 1;
    bewaard[tel] := klein.vlak;
  end;

  standaard := model.vlak;
{ Initial Guess of Holes Grid }
  model.StartWaarden(nogmaals,A,p,q);
  ruimte := VektorRuimte.Create;
  ruimte.Dimensie(6);
  Lengte := Length(bewaard);
  G := 0;
{ Educated Guess of Holes Grid }
  for iteratie := 0 to 99 do
  begin
    V := G;
    G := Vergelijkingen(bewaard,A,p,q, S,b);
    if iteratie = 0 then Resultaat('first');
    gelukt := ruimte.DirekteInverse(S);
    if not gelukt then Break;
    b := ruimte.Vermenigvuldig(S,b);
    A.x := b[1]; A.y := b[4];
    p.x := b[2]; p.y := b[5];
    q.x := b[3]; q.y := b[6];
    if abs (G-V) < eps then Break;
  end;
  if gelukt then
    Resultaat('last')
  else
    model.StartWaarden(nogmaals,A,p,q);
  steun := A;
  rechts := p;
  omhoog := q;
  ondersteund := true;
  Visualisatie(clBlack);

{ Extract indices belonging to Holes }
  verdeling := Schuine.Create;
  for k := 1 to tel do
  begin
    sigma := bewaard[k].Traagheid;
    mu := bewaard[k].Midden;
    verdeling.Definitie(sigma,mu);
    
    maximum := 0;
    for i := 0 to 80-1 do
    for j := 0 to 12-1 do
    begin
      r.x := A.x + p.x*i + q.x*j;
      r.y := A.y + p.y*i + q.y*j;
      waarde := verdeling.Gauss(r);
    { Proper indices where maximum }
      if waarde > maximum then
      begin
        maximum := waarde;
        coordinaten[k].x := i+1;
        coordinaten[k].y := j+1;
      end;
    end;
  end;
{ Understanding }
  Begrijpen;
end;

procedure TForm1.Starten(Sender: TObject);
{
  Initialize Form
}
const
  tien : string = '1234567890';
begin
  LogFile('Vertolkt.log');
  HulpScherm := TBitmap.Create;
  geklaard := false;
  eenmalig := true;
  ondersteund := false;
  Form1.Edit1.Font.Color := clBlue;
  Form1.Edit1.text := 'Content of IBM PunchCards';
  Form1.Process1.Enabled := false;
  Form1.Select1.Enabled := false;
end;

procedure TForm1.Stoppen(Sender: TObject);
{
  Close Form
}
begin
  BMPschoon;
  HulpScherm.free;
end;

procedure UitZetten;
begin
  Form1.File1.Enabled := false;
  Form1.Edit1.Enabled := false;
end;

procedure AanZetten;
begin
  Form1.File1.Enabled := true;
  Form1.Edit1.Enabled := true;
end;

procedure TForm1.Open1Click(Sender: TObject);
{
  Load BMP file
}
var
  OK : boolean;
begin
  UitZetten;
  ForceCurrentDirectory := true;
  if Form1.OpenPictureDialog1.Execute then
    naam := Form1.OpenPictureDialog1.FileName;
  if Length(naam) < 5 then
  begin
    AanZetten;
    Form1.Edit1.Font.Color := clRed;
    Form1.Edit1.text := naam + ' : Not a proper filename !!';
    Exit;
  end;
  OK := Inlezen(naam);
  if not OK then
  begin
    AanZetten;
    Form1.Edit1.Font.Color := clRed;
    Form1.Edit1.text := naam + ' : does Not exist !!';
    Exit;
  end;
  OK := LaatZien;
  if not OK then
  begin
    AanZetten;
    Form1.Edit1.Font.Color := clRed;
    Form1.Edit1.text := naam + ' : Not a proper B/W picture !!';
    Exit;
  end;
  Form1.Edit1.Font.Color := clBlack;
  Form1.Edit1.text := '';

  Form1.Image1.Width := Wijd;
  Form1.Image1.Height := Hoog;
  Form1.Image1.Picture.LoadFromFile(naam);

  geklaard := false;
  Form1.Process1.Enabled := true;
  Form1.Select1.Enabled := false;
  AanZetten;
end;

procedure TForm1.Process1Click(Sender: TObject);
{
  Process BMP Content
}
var
  OK : boolean;
begin
  UitZetten;
  Cursor := crHourGlass;
  BMProutines;
  OK := Aankaarten;
  Cursor := crDefault;
  if not OK then
  begin
    Form1.Edit1.Font.Color := clRed;
    Form1.Edit1.Text := 'Not (the backside of) any IBM punchcard';
    AanZetten;
    Exit;
  end;
  Form1.Edit1.Font.Color := clBlack;
  Form1.Edit1.text := '';
  Zichtbaar;
  Form1.Process1.Enabled := false;
  Form1.Select1.Enabled := true;
  ondersteund := false;
  AanZetten;
end;

procedure TForm1.Select1Click(Sender: TObject);
begin
  UitZetten;
  if eenmalig then
    Application.MessageBox('Select Card Image with Mouse','Select',MB_OK);
  eenmalig := false;
  geklaard := true;
  Form1.Image1.Cursor := crHandPoint;
  Form1.Edit1.Font.Color := clBlack;
  Form1.Edit1.text := '';
  AanZetten;
end;

procedure TForm1.Kiezen;
{
  Select PunchCard with Mouse
}
var
  binnen : boolean;
  uitverkoren : integer;
  k : integer;
  r : vektor;
  curve : Contour;
begin
  UitZetten;
  uitverkoren := 0;
  if not geklaard then 
  begin
    AanZetten;
    Exit;
  end;
  binnen := (X < Wijd) and (Y < Hoog);
  if not ((Button = mbLeft) and binnen) then
  begin
    AanZetten;
    Exit;
  end;
  r.x := X ; r.y := Y;
  curve := Contour.Create;
  for k := 1 to Aantal do
  begin
    if isKansloos(k) then Continue;
    if kaart[k] = k then
    begin
      curve.Definitie(Kromme(k));
      if curve.Binnen(r) then uitverkoren := k;
    end;
  end;
  if uitverkoren = 0 then
  begin
    Form1.Edit1.Font.Color := clRed;
    Form1.Edit1.text := 'Now click ON punchcard';
    AanZetten;
    Exit;
  end;
  KaartLezen(uitverkoren);
  Form1.Image1.Cursor := crDefault;
  geklaard := false;
  AanZetten;
end;

procedure TForm1.Exit1Click(Sender: TObject);
begin
  Form1.Close;
end;

END.