program COMPRES;

{ Example : I use 20 windows-icons with a size of 766 bytes for my program }
{ and compress(link) these to one file ICON.LIB with a size of }
{ 20 x 766 = 15320 Bytes }
{ After this, you can delete these icons }
{ Now read with the procedure SHOW_ICONS these icons and display them on }
{ the vga screen) 640 x 480 x 16 }
{ Jos Dickmann (c) 1997 / maximal icons in this demo = 1000 }


uses graph,crt,dos;


var
  x,y,xx,yy,p,pp,q: integer;
  f,ff            : file;
  buf             : array[1..512] of byte;
  icon            : pointer;
  s1              : longint;
  NumR,NumW       : Word;
  grdriver,grmode : integer;
  files           : array[1..1000] of string[12];
  search          : searchrec;
  aantal          : integer;
  s               : string;
  r,rr,ch         : byte;

procedure del_file(filename :string);{**************************************}

begin
  assign(f,filename);
  {$I-} reset(f); {$I+}
  if ioresult =0 then begin
    close(f);
    erase(f);
  end;
end;

Function exist_file(FileName : string) : boolean;{**************************}

var
  sr : SearchRec;

begin
  FindFirst(FileName, AnyFile, sr);
  Exist_File := (DosError = 0);
end;

Function Search_For_Icons : integer;{***************************************}

begin
  for p :=1 to 1000 do files[p] :='';
  aantal :=1;
  findfirst('*.ico',0,search);
  files[aantal] :=search.name;
  while doserror =0 do begin
    files[aantal] :=search.name;
    findnext(search);
    inc(aantal);
  end;
  dec(aantal);
  Search_For_Icons :=aantal;
end;

procedure compress;{********************************************************}

begin
  if exist_file('icon.lib') = true
    then del_file('icon.lib');             { first delete exist file }
  aantal := Search_For_Icons;                     { search for icons }
  assign(f,'icon.lib');                      { open file for writing }
  for p :=1 to aantal do begin
    {$I-} reset(f,1); {$I+}
    if ioresult <>0 then rewrite(f,1);
    seek(f,filesize(f));
    assign(ff,files[p]);
    {$I-} reset(ff,1); {$I+}
    if (ioresult =0) and (filesize(ff) =766) then begin
      repeat
        BlockRead(ff,buf,SizeOf(buf),NumR);
        BlockWrite(f,buf,NumR,NumW);
      until (NumR = 0) or (NumW <> NumR);
    end;
    close(ff);
  end;
  close(f);
end;

Procedure show_icons;{******************************************************}

Begin
  s1 :=0;
  xx :=5;yy :=40;                    { start coordinate icons }
  Assign(f,'icon.lib');
  {$I-} Reset(f,1); {$I+}
  if ioresult =0 then begin
    aantal := round(filesize(f)/766);
    for pp :=1 to aantal do begin
      seek(f,s1);
      x :=xx;y :=yy;

      for p :=1 to 766 do begin
        blockread(f,ch,1);q :=ord(ch);
        if (p >126) and (p <639) then begin
          r :=q shr 4;rr :=q-r div 16;
          putpixel(x,y,r);putpixel(x+1,y,rr);
          inc(x,2);
          if x =xx+32 then begin
            x :=xx;dec(y);
          end;
        end;
      end;

      inc(s1,766);
      inc(xx,40);
      if xx >630 then begin
        xx :=5;inc(yy,40);
      end;
    end;
    close(f);
  end;
end;


begin
  clrscr;
  compress;
  textcolor(3);
  gotoxy(2,2);
  writeln('Compress ',aantal,' files(icons) to one file ICON.LIB');
  textcolor(7);
  gotoxy(2,4);writeln('Enter for show icons......');
  readln;

  grdriver := VGA;
  grmode   := VGAHI;                                      { 640 x 480 x 16 }
  initgraph(grdriver,grmode,'');

  { You can now (if you want) delete the 20 icon files }

  show_icons;          { load file ICON.LIB and display them on the screen }
  readln;
  closegraph;
  halt;
end.