{ procedure saveimg saved een vga scherm 640 x 480 pixels in 4 gedeelten

  1e gedeelte van   0..119   =  38406 bytes
  2e gedeelte van 120..239   =  76812 bytes
  3e gedeelte van 240..359   = 115218 bytes
  4e gedeelte van 360..479   = 153624 bytes

  een tekening van 640 x 480 pixels
  neemt dus 153624 bytes in beslag op de schijf
}

UNIT TPU3;

INTERFACE

procedure SAVEIMG(filenaam :string);
procedure LOADIMG(filenaam :string);
procedure RESET_PAL;
procedure HORLIJN(aantal,xpos,ypos,xlengte,afstand,kleur :integer);
procedure VERLIJN(aantal,xpos,ypos,ylengte,afstand,kleur :integer);
procedure NAAM(x,y,kleur :integer);
procedure VUL(x,y :integer;raster,kleur,randkleur :byte);
procedure RONDJES(aantal :byte;x,y,str,afstand :integer;kleur,vulkl :byte);
procedure KUBES(aantal :byte;x,y,xx,yy,afstand :integer;kleur,vulkl :byte);
procedure CLEAN(x,y,xx,yy :integer;kleur,pauze :byte);
procedure DUBBTEKST(x,y :integer;woord :string;kleurachter,
                    kleurvoor,afstand,groote :byte);
procedure VGARAAM(x1,y1,x2,y2 :integer;kaderkleur,vulkl,raster :byte);
procedure ORGEL(x,y :integer;aantal :byte);
procedure DAMBORD(x,y,groote :integer;kleur,kleur1,kleur2,bord :byte);
procedure KLOK(x,y :integer;kleurcijfers,achtergrondkleur :byte);
procedure DATEM(x,y :integer;kleur :byte;keuze :boolean);
procedure KNOPUIT(l,b,r,o :integer;tekst :string;kleur,kleurtekst :byte);
procedure KNOPAAN(l,b,r,o :integer;tekst :string;kleur,kleurtekst :byte);
procedure MAAKVGARAAM(l,b,r,o :integer;kleur,kleurrand :byte;tekst :string);
procedure SLUITVGARAAM(l,b :integer);


IMPLEMENTATION

uses dos,crt,graph;

var
  z,x,y,p,kleur,pp  :integer;
  hor,ver           :real;
  x1,y1             :array[1..200] of integer;
  st,st1,st2,st3    :string;
  icon,vak          :pointer;
  s1,s2             :word;
  s3                :longint;
  f                 :file;

procedure knopuit(l,b,r,o :integer;tekst :string;kleur,kleurtekst :byte);

begin
  setcolor(kleur);
  for p :=b to o do line(l,p,r,p);
  setcolor(kleur+8);
  line(l+5,b+5,r-5,b+5);line(r-5,b+5,r-5,o-5);
  setcolor(0);line(l+5,b+5,l+5,o-5);line(l+5,o-5,r-5,o-5);
  hor :=((r-l)/2)+L-(length(tekst)*8)/2;ver :=((o-b)/2)+B-4;
  setcolor(kleurtekst);
  outtextxy(round(hor)+1,round(ver)+1,tekst);
end;

procedure knopaan(l,b,r,o :integer;tekst :string;kleur,kleurtekst :byte);

begin
  setcolor(kleur);
  for p :=b to o do line(l,p,r,p);
  setcolor(0);
  line(l+5,b+5,r-5,b+5);line(r-5,b+5,r-5,o-5);
  setcolor(kleur+8);line(l+5,b+5,l+5,o-5);line(l+5,o-5,r-5,o-5);
  hor :=((r-l)/2)+L-(length(tekst)*8)/2;ver :=((o-b)/2)+B-4;
  setcolor(kleurtekst);
  outtextxy(round(hor)+2,round(ver)+2,tekst);
end;

procedure maakvgaraam(l,b,r,o :integer;kleur,kleurrand :byte;tekst :string);

begin
  s2 :=imagesize(l,b,r,o);getmem(vak,s2);
  getimage(l,b,r,o,vak^);
  setcolor(kleur);for p :=b to o-10 do line(l,p,r-10,p);
  setcolor(kleurrand);
  rectangle(l,b,r-10,o-10);rectangle(l+1,b+1,r-11,o-11);
  for p :=b to b+15 do line(l,p,r-10,p);
  setcolor(0);for p :=o-9 to o do line(l+10,p,r,p);
  for p :=r-9 to r do line(p,b+10,p,o);
  hor :=(((r-10)-l)/2)+L-(length(tekst)*8)/2;
  setcolor(kleur);
  outtextxy(round(hor),b+4,tekst);
end;

procedure sluitvgaraam(l,b :integer);

begin
  putimage(l,b,vak^,0);
  freemem(vak,s2);
end;

procedure SAVEIMG(filenaam :string);

begin
  s3 :=0;x :=0;
  for p :=1 to 4 do begin
    s1 :=imagesize(0,x,639,x+119);
    getmem(icon,s1);
    assign(f,filenaam);
    {$I-} reset(f,1); {$I+}
    if ioresult <>0 then rewrite(f,1);
    seek(f,s3);
    getimage(0,x,639,x+119,icon^);
    blockwrite(f,icon^,s1);
    close(f);
    freemem(icon,s1);
    inc(s3,38406);
    inc(x,120);
  end;
end;

procedure LOADIMG(filenaam :string);

begin
  s3 :=0;x :=0;
  for p :=1 to 4 do begin
    assign(f,filenaam);
    {$I-} reset(f,1); {$I+}
    if ioresult <>0 then begin
      sound(500);delay(500);nosound;
      exit;
    end;
    seek(f,s3);
    s1 :=38406;
    getmem(icon,s1);
    blockread(f,icon^,s1);
    close(f);
    putimage(0,x,icon^,0);
    freemem(icon,s1);
    inc(s3,38406);
    inc(x,120);
  end;
end;

procedure RESET_PAL;

begin
  for p :=0 to 5 do setpalette(p,p);
  setpalette(6,20);
  setpalette(7,7);
  for p :=8 to 15 do setpalette(p,p+48);
end;

procedure horlijn(aantal,xpos,ypos,xlengte,afstand,kleur :integer);

begin
  setcolor(kleur);
  for p :=1 to aantal do begin
    line(xpos,ypos,xlengte,ypos);inc(ypos,afstand);
  end;
end;

procedure verlijn(aantal,xpos,ypos,ylengte,afstand,kleur :integer);

begin
  setcolor(kleur);
  for p :=1 to aantal do begin
    line(xpos,ypos,xpos,ylengte);inc(xpos,afstand);
  end;
end;

procedure naam(x,y,kleur :integer);

const
    nepnaam ='MOKD(1 JN9 IS)C9NA1 c';

    neppos :array[1..21] of byte =
            (9,2,8,5,14,18,4,1,11,19,13,6,3,16,7,20,12,10,21,17,15);
begin
  for p :=1 to 21 do begin
    setcolor(kleur);outtextxy(x +neppos[p]*9,y,copy(nepnaam,p,1));
  end;
end;

procedure vul(x,y :integer;raster,kleur,randkleur :byte);

const
  soort :array[1..17] of fillpatterntype =((0,$fb,$fb,$fb,0,$df,$df,$df),
        (0,$10,$28,$44,$28,$10,0,0),($cc,$33,$cc,$33,$cc,$33,$cc,$33),
        ($aa,$55,$aa,$55,$aa,$55,$aa,$55),($94,$84,$48,$30,0,$c1,$22,$14),
        ($cc,$cc,$cc,$cc,$cc,$cc,$cc,$cc),($01,$82,$44,$28,$10,$20,$40,$80),
        (0,$3c,$42,$42,$42,$42,$3c,0),(0,$7e,$7e,$7e,$7e,$7e,$7e,0),
        ($81,$42,$24,$18,$18,$24,$42,$81),(0,$ec,$2a,$2a,$2a,$aa,$ec,0),
        (0,$08,$18,$3f,$3f,$18,$08,0),(0,0,$7e,$42,$7e,$42,$7e,$42),
        ($80,$7f,$41,$41,$41,$41,$41,$7f),(0,$5d,$3e,$6b,$7f,$63,$36,$5d),
        (0,0,$04,$08,$90,$a0,$c0,$f0),($ff,$ff,$ff,$ff,$ff,$ff,$ff,$ff));

begin
  if (raster<1) or (raster>16) then raster :=17;
  setfillpattern(soort[raster],kleur);setfillstyle(12,kleur);
  floodfill(x,y,randkleur);setfillstyle(0,0);
end;

procedure rondjes(aantal :byte;x,y,str,afstand :integer;kleur,vulkl :byte);

begin
  for p :=1 to aantal do begin
    setcolor(kleur);circle(x,y,str);setfillstyle(1,vulkl);
    floodfill(x,y,kleur);inc(x,afstand);
  end;
end;

procedure kubes(aantal :byte;x,y,xx,yy,afstand :integer;kleur,vulkl :byte);

begin
  for p :=1 to aantal do begin
    setcolor(kleur);rectangle(x,y,xx,yy);
    setfillstyle(1,vulkl);floodfill(x+1,y+1,kleur);
    inc(x,afstand);inc(xx,afstand);
  end;
end;

procedure clean(x,y,xx,yy :integer;kleur,pauze :byte);

begin
  for p :=y to yy do begin
    setcolor(kleur);line(x,p,xx,p);delay(pauze);
  end;
end;

procedure dubbtekst(x,y :integer;woord :string;kleurachter,
                    kleurvoor,afstand,groote :byte);

begin
  settextstyle(0,0,groote);
  for p :=1 to length(woord) do begin
    st :=copy(woord,p,1);
    setcolor(kleurachter);outtextxy(x,y,st);
    setcolor(kleurvoor);outtextxy(x+1,y+1,st);inc(x,afstand);
  end;settextstyle(0,0,0);
end;

procedure vgaraam(x1,y1,x2,y2 :integer;kaderkleur,vulkl,raster :byte);

begin
  setviewport(x1,y1,x2,y2,clipoff);clearviewport;
  setviewport(0,0,639,479,clipoff);
  setcolor(kaderkleur);rectangle(x1,y1,x2,y2);rectangle(x1+5,y1+5,x2-5,y2-5);
  rectangle(x1+1,y1+1,x2-1,y2-1);
  vul(x1+6,y1+6,raster,vulkl,kaderkleur);
end;

procedure orgel(x,y :integer;aantal :byte);

const
  toets :array[1..5] of integer =(5,22,56,73,90);

begin
  for pp :=1 to aantal do begin
    for p :=1 to 8 do begin
      setcolor(15);for z :=y to y+60 do line(x,z,x+15,z);
      putpixel(x,y+60,0);putpixel(x+15,y+60,0);
      inc(x,17);
    end;
    dec(x,131);
    for p :=1 to 5 do begin
      setcolor(8);for z :=y to y+40 do line(x+toets[p],z,x+toets[p]+11,z);
      setcolor(0);rectangle(x+toets[p]+1,y,x+toets[p]+12,y+40);
      setcolor(7);
      for z :=y+37 to y+39 do line(x+toets[p]+2,z,x+toets[p]+11,z);
    end;inc(x,114);
  end;
end;

procedure dambord(x,y,groote :integer;kleur,kleur1,kleur2,bord :byte);

begin
  setviewport(x-5,y-5,x+((bord*groote)+5),y+((bord*groote)+5),clipoff);
  clearviewport;setviewport(0,0,639,479,clipoff);
  setcolor(kleur);z :=0;
  if bord<1 then bord :=1;
  rectangle(x-5,y-5,x+((bord*groote)+5),y+((bord*groote)+5));
  rectangle(x-4,y-4,x+((bord*groote)+4),y+((bord*groote)+4));
  for pp :=1 to bord do begin
    for p :=1 to bord do begin
      rectangle(x,y,x+groote,y+groote);inc(z);
      if odd(z) =true then begin              { kijkt of getal oneven is }
        setfillstyle(1,kleur1);floodfill(x+1,y+1,kleur);
      end
      else setfillstyle(1,kleur2);floodfill(x+1,y+1,kleur);
      inc(x,groote);
    end;
    if odd(bord) =false then inc(z);
    dec(x,bord*groote);inc(y,groote);
  end;
end;

procedure klok(x,y :integer;kleurcijfers,achtergrondkleur :byte);

var h,m,s,hund :word;

function leading(w :word) :string;

begin
  str(w:0,st);
  if length(st) =1 then st :='0' +st;
  leading :=st;
end;
begin
  gettime(h,m,s,hund);setcolor(achtergrondkleur);
  outtextxy(x,y,'лллллллл');      { crtl + alt +ascinummer }
  setcolor(kleurcijfers);
  outtextxy(x,y,leading(h)+':'+leading(m)+':'+leading(s));
end;

procedure datem(x,y :integer;kleur :byte;keuze :boolean);

var j,m,d,w :word;

const
  maand :array[1..12] of string =('JANUARI','FEBRUARI','MAART','APRIL',
         'MEI','JUNI','JULI','AUGUSTUS','SEPTEMBER','OKTOBER','NOVEMBER',
         'DECEMBER');
begin
  getdate(j,m,d,w);
  case w of
    0:st:='ZONDAG';
    1:st:='MAANDAG';
    2:st:='DINSDAG';
    3:st:='WOENSDAG';
    4:st:='DONDERDAG';
    5:st:='VRIJDAG';
    6:st:='ZATERDAG';
  end;
  str(d,st1);str(m,st2);str(j,st3);setcolor(kleur);
  if keuze =true then outtextxy(x,y,st+' '+st1+' '+maand[m]+' '+st3)
    else outtextxy(x,y,st1+'-'+st2+'-'+st3);
end;


begin
end.