Programmeren met Delphi  4  

Naar start 

 

De meeste eigen procedures en functies heb ik ondergebracht in een unit. Hierin ook de declaraties van de variabelen en record. Dit is bij nieuw te kiezen. Dus zonder form !!

unit damdeclar;

interface

type
    damdata=record
        naam : array [1..15] of string[25];
        uitslag: array [1..15,1..15,1..6] of integer;
    end;

{ de volgende types worden gebruikt om op typewerk te besparen en tbv de sorteerroutine om type aan te geven }

    nnm=array [1..15] of string[25];
    ggs=array [1..15] of string[2];
    ggm=array [1..15] of string[15];

var
    datafile :file of damdata;
    datarec :damdata;
    recteller :integer;
    namen :nnm;
    gespeeld :ggs;
    wit :ggs;
    zwart :ggs;
    gewonnen :ggs;
    remise :ggs;
    verloren :ggs;
    gemiddeld :ggm;
    punten :ggs;

procedure legen;
procedure wisalles;
procedure leesdata;
procedure schrijfdata;
procedure openbestand;
procedure sluitbestand;
function int_str(nummer:integer):string;
function int_str2(nummer:integer):string;
function int_str4(nummer:integer):string;
function str_int(naam:string):integer;
procedure berekenalles;
procedure sorteerspelers(var bb:ggm;var aa,cc,dd,ee,ff,gg,hh:ggs;var tt:nnm;j,n:integer);

implementation

{ deze sorteerroutine in recursief, dwz hij roept zichzelf weer aan. De snelheid van deze routine is echt SNEL }

procedure sorteerspelers;
var k,p:integer;
     h,w:string;
begin
    k:=j; p:=n; w:=bb[(k+n) div 2];
    repeat
        while bb[k]>w do k:=k+1;
        while w>bb[p] do p:=p-1;
        if k<=p then
        begin
            h:=bb[k]; bb[k]:=bb[p]; bb[p]:=h;
            h:=aa[k]; aa[k]:=aa[p]; aa[p]:=h;
            h:=cc[k]; cc[k]:=cc[p]; cc[p]:=h;
            h:=dd[k]; dd[k]:=dd[p]; dd[p]:=h;
            h:=ee[k]; ee[k]:=ee[p]; ee[p]:=h;
            h:=ff[k]; ff[k]:=ff[p]; ff[p]:=h;
            h:=gg[k]; gg[k]:=gg[p]; gg[p]:=h;
            h:=hh[k]; hh[k]:=hh[p]; hh[p]:=h;
            h:=tt[k]; tt[k]:=tt[p]; tt[p]:=h;
            k:=k+1; p:=p-1;
        end;
    until k>p;
    if j<p then sorteerspelers(bb,aa,cc,dd,ee,ff,gg,hh,tt,j,p);
    if k<n then sorteerspelers(bb,aa,cc,dd,ee,ff,gg,hh,tt,k,n);
end;

{ de gemiddeldes enz worden met deze procedure berekend }

procedure berekenalles;
var tel,tel1,tel2,res:integer;
aant,wt,zwrt,gw,rm,vrl,pt:integer;
gemid:integer;
begin
    with datarec do
    begin
        for tel:=1 to 15 do {elke speler}
        begin
            aant:=0; wt:=0; zwrt:=0; gw:=0; rm:=0; vrl:=0; pt:=0;
            for tel1:=1 to 15 do {elke tegenstander}
            begin
                if tel1<>tel then
                begin
                    for tel2:=1 to 3 do {elke partij met wit}
                    begin
                        res:=uitslag[tel,tel1,tel2];
                        case res of
                            0:begin
                                    aant:=aant+1; wt:=wt+1; vrl:=vrl+1;
                               end;
                            1:begin
                                    aant:=aant+1; wt:=wt+1; rm:=rm+1; pt:=pt+1;
                               end;
                            3:begin
                                    aant:=aant+1; wt:=wt+1; gw:=gw+1; pt:=pt+3;
                               end;
                        end;
                    end;
                    for tel2:=4 to 6 do {elke partij met zwart}
                    begin
                        res:=uitslag[tel,tel1,tel2];
                        case res of
                            0:begin
                                    aant:=aant+1; zwrt:=zwrt+1; vrl:=vrl+1;
                               end;
                            1:begin
                                    aant:=aant+1; zwrt:=zwrt+1; rm:=rm+1; pt:=pt+1;
                               end;
                            3:begin
                                    aant:=aant+1; zwrt:=zwrt+1; gw:=gw+1; pt:=pt+3;
                              end;
                        end;
                    end;
                end;
            end;
            if aant>0 then {alleen uitrekenen wanneer meer dan 0 gespeeld}
            begin
                gemid :=((pt*1000) div aant);
                namen[tel] :=naam[tel];
                gespeeld[tel] :=int_str2(aant);
                wit[tel] :=int_str2(wt);
                zwart[tel] :=int_str2(zwrt);
                gewonnen[tel] :=int_str2(gw);
                remise[tel] :=int_str2(rm);
                verloren[tel] :=int_str2(vrl);
                gemiddeld[tel]:=int_str4(gemid);
                punten[tel] :=int_str2(pt);
            end;
        end;
    end;
end;

{ het omzetten van een string naar een integer }

function str_int; {terugzetten naar integer}
var hulp,contro:integer;
begin
    str_int:=0;
    val(naam,hulp,contro);
    if contro=0 then str_int:=hulp;
end;

{ het omzetten van een integer naar een string (onbepaalde lengte) }

function int_str;
var hulp:string;
begin
    str(nummer,hulp);
    int_str:=hulp;
end;

{ het omzetten van een integer naar een string in een veld van 2 tekens breed }

function int_str2; {in veld van 2}
var hulp:string;
begin
    str(nummer:2,hulp);
    int_str2:=hulp;
end;

{ het omzetten van een integer naar een string in een veld van 4 tekens }

function int_str4; {in veld van 4}
var hulp:string;
begin
    str(nummer:4,hulp);
    int_str4:=hulp;
end;

{ een eigenlijk overbodige procedure, echter ten behoeve van de uniformiteit }

procedure sluitbestand;
begin
    close(datafile);
end;

{ het openen en controleren op de diskdata in damdata.dat. Is het bestand niet aanwezig, dan wordt deze aangemaakt }

procedure openbestand;
begin
    assign(datafile,'damdata.dat');
    {$I-} reset(datafile); {$I+} {controle of bestand bestaat}
    if ioresult <> 0 then {als bestand niet bestaat maak bestand}
    begin
        legen;
        rewrite(datafile);
        write(datafile,datarec);
        closefile(datafile);
        reset(datafile);
    end;
end;

{ Het bestand wordt overschreven bij het schrijven Er wordt ook maar 1 record gebruikt }

procedure schrijfdata;
begin
    rewrite(datafile);
    write(datafile,datarec);
end;

{ in het eerste record staan de gegevens }

procedure leesdata;
begin
    reset(datafile);
    read(datafile,datarec);
end;

{ alle gegevens worden gewist en naar de disk geschreven. Niet de namen deze blijven onveranderd }

procedure wisalles;
var tel,tel1,tel2:integer;
begin
    with datarec do
    begin
        for tel:=1 to 15 do {alle spelers}
        begin
            for tel2:=1 to 15 do {tegen alle spelers}
            begin
                for tel1:=1 to 6 do {alle partijen}
                begin
                    uitslag[tel,tel2,tel1]:=9; {9=niet gespeeld}
                end;
            end;
        end;
        schrijfdata;
    end;
end;


{ alle gegevens worden gewist en naar de disk geschreven. Ook de namen  }

procedure legen;
var tel,tel1,tel2:integer;
begin
    with datarec do
    begin
        for tel:=1 to 15 do {alle spelers}
        begin
            naam[tel]:=''; 
            for tel2:=1 to 15 do {tegen alle spelers}
            begin
                for tel1:=1 to 6 do {alle partijen}
                begin
                    uitslag[tel,tel2,tel1]:=9; {9 = niet gespeeld}
                end;
            end;
        end;
        schrijfdata;
    end;
end;

end.