Projects‎ > ‎

Finger Paint Pro



Finger Paint Pro was released as shareware for low level pixel editing of VGA images. I have an official copyright filled and granted for the program. It could load many different data types, edit palettes, copy and paste, and everything you could think of that an early Photoshop program might have. It was written in Pascal and Assembly. One major technology used was EMS and EMM memory.


procedure loadGIFfile(s: string; h: pCPR_HEADER; n: integer);
const
 wordmasktable: array[0..15] of word=
  ($0000,$0001,$0003,$0007,
   $000f,$001f,$003f,$007f,
   $00ff,$01ff,$03ff,$07ff,
   $0fff,$1fff,$3fff,$7fff);
 starttable: array[0..4] of word= (0,4,2,1,0);
 inctable: array[0..4] of word= (8,8,4,2,0);
type
 buffertype= array[0..4095] of integer;
 buffertype2= array[0..4095] of byte;
var
 hb1: GIF_HEADER1;
 hb2: GIF_HEADER2;
 f: file;
 err,num: word;

 size: byte;

 bits2,codesize,line,codesize2,nextcode,thiscode,oldtoken,currentcode,pass,
  oldcode,bitsleft,bt,p,q: word;
 interlace: boolean;
 u: integer;

 blocksize: byte;

 b: array[0..255] of byte;
 firstcodestack: ^buffertype2;
 lastcodestack: ^buffertype2;
 codestack: ^buffertype;

 procedure handleerror;
 begin
  h^.version:=CPR_ERROR;
  close(f);
  if firstcodestack<>nil then dispose(firstcodestack);
  if lastcodestack<>nil then dispose(lastcodestack);
  if codestack<>nil then dispose(codestack);
  firstcodestack:=nil;
  lastcodestack:=nil;
  codestack:=nil;
  j:=ioresult;
 end;

 procedure loadpalette(n: integer);
 begin
  num:=n*3;
  blockread(f,colors,num,err);
  if (ioresult<>0) or (num<>err) then
   begin
    handleerror;
    exit;
   end;
  for j:=1 to 768 do
   colors[0,j]:=colors[0,j] shr 2;
  set256colors(colors);
 end;

 function getheader1: boolean;
 begin
  getheader1:=false;
  num:=sizeof(GIF_HEADER1);
  blockread(f,hb1,num,err);
  with hb1 do
   begin
    if (ioresult<>0) or (num<>err) or (signature[0]<>'G') or (signature[1]<>'I')
     or (signature[2]<>'F') then exit;
    if (flag and 128)>0 then loadpalette(2 shl (flag and 7));
   end;
  interlace:=false;
  getheader1:=true;
 end;

 function getheader2: boolean;
 var
  sig: char;
  skip: byte;
 begin
  getheader2:=false;
  done:=false;
  repeat
   num:=1;
   blockread(f,sig,num,err);
   if (ioresult<>0) or (num<>err) then exit;
   if sig='!' then
    begin
     num:=1;
     blockread(f,skip,num,err);
     if (ioresult<>0) or (num<>err) then exit;
     seek(f,filepos(f)+skip);
     if (ioresult<>0) then exit;
    end
   else if sig<>',' then exit;
  until sig=',';
  num:=sizeof(GIF_HEADER2);
  blockread(f,hb2,num,err);
  if (hb2.flag and 128)>0 then loadpalette(2 shl (hb2.flag and 7));
  if hb2.w>MAXWIDTH then h^.width:=MAXWIDTH else h^.width:=hb2.w;
  if hb2.h>MAXHEIGHT then h^.height:=MAXHEIGHT else h^.height:=hb2.h;
  h^.version:=CPR_GIF;
  h^.flags:=1;
  if (hb2.flag and 64)>0 then interlace:=true;
  getheader2:=true;
 end;

 procedure getbuffer;
 begin
  blockread(f,blocksize,1,err);
  if ioresult<>0 then
   begin
    handleerror;
    exit;
   end;
  blockread(f,b,blocksize,err);
  if (ioresult<>0) or (blocksize<>err) then
   begin
    handleerror;
    exit;
   end;
  q:=blocksize;
  p:=0;
 end;

 procedure decode(bits: integer);
 label loop;
 begin
  fillchar(lastcodestack^,sizeof(buffertype2),0);
  bt:=0;
  line:=0;
  bitsleft:=8;
  bits2:=1 shl bits;
  nextcode:=bits2+2;
  codesize:=bits+1;
  codesize2:=1 shl codesize;
  oldtoken:=$FFFF;
  oldcode:=$FFFF;
  q:=0;
  p:=0;
  pass:=0;

 loop:
   if bitsleft=8 then
    begin
     inc(p);
     if p>=q then getbuffer;
     bitsleft:=0;
    end;
   thiscode:=b[p];
   currentcode:=codesize+bitsleft;
   if currentcode<=8 then
    begin
     b[p]:=b[p] shr codesize;
     bitsleft:=currentcode;
    end
   else
    begin
     inc(p);
     if p>=q then getbuffer;
     thiscode:=thiscode or (b[p] shl (8-bitsleft));
     if (currentcode<=16) then
      begin
       bitsleft:=currentcode-8;
       b[p]:=b[p] shr bitsleft;
      end
     else
      begin
       inc(p);
       if p>=q then getbuffer;
       thiscode:=thiscode or (b[p] shl (16-bitsleft));
       bitsleft:=currentcode-16;
       b[p]:=b[p] shr bitsleft;
      end;
    end;
   thiscode:=thiscode and wordmasktable[codesize];
   currentcode:=thiscode;
   if thiscode=bits2+1 then exit;
   if thiscode>nextcode then exit;
   if thiscode=bits2 then
    begin
     nextcode:=bits2+2;
     codesize:=bits+1;
     codesize2:=1 shl codesize;
     oldcode:=$FFFF;
     oldtoken:=$FFFF;
     goto loop;
    end;
   u:=0;
   if thiscode=nextcode then
    begin
     firstcodestack^[u]:=oldtoken;
     inc(u);
     thiscode:=oldcode;
     end;
   while thiscode>=bits2 do
    begin
     firstcodestack^[u]:=lastcodestack^[thiscode];
     inc(u);
     thiscode:=codestack^[thiscode];
    end;
   oldtoken:=thiscode;
   repeat
    if bt=hb2.w then
     begin
      dumpline(line);
      if interlace then
       begin
        inc(line,inctable[pass]);
        if line>=hb2.h then
         begin
          inc(pass);
          line:=starttable[pass];
         end;
       end
      else inc(line);
      bt:=0;
     end;
    dec(u);
    if u>=0 then thiscode:=firstcodestack^[u];
   until u<0;
   if (nextcode<4096) and (oldcode<>$FFFF) then
    begin
     codestack^[nextcode]:=oldcode;
     lastcodestack^[nextcode]:=oldtoken;
     inc(nextcode);
     if (nextcode>=codesize2) and (codesize<12) then
      begin
       inc(codesize);
       codesize2:=1 shl codesize;
      end;
    end;
   oldcode:=currentcode;
  goto loop;
 end;

begin
 new(firstcodestack);
 new(lastcodestack);
 new(codestack);
 assign(f,s);
 reset(f,1);
 if n>0 then seek(f,n);
 if ioresult<>0 then
  begin
   handleerror;
   exit;
  end;
 if not getheader1 then
  begin
   handleerror;
   exit;
  end;
 if not getheader2 then
  begin
   handleerror;
   exit;
  end;
 size:=0;
 blockread(f,size,1,err);
 decode(size);
 close(f);
 if firstcodestack<>nil then dispose(firstcodestack);
 if lastcodestack<>nil then dispose(lastcodestack);
 if codestack<>nil then dispose(codestack);
end;