[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]

    {
    I am sending a unit which I have made that lets you get an image off the
    screen, put an image on the screen, save an image to disk, load it off
    the disk, and scale the object as well.  I would like to contribute this
    unit to swag.

    thanks

    }
    {Landon Rabern 1997
    {This unit has procedures for getting an image, putting an image, saving an
    image to disk, and scaling an image
    It works pretty well but it isn't optimised, so if you optimise it please
    send me a copy}
    unit picunit;

    interface

    uses crt;

    type
        Tpic=record
                   xs,ys:word;
        end;
        Upic=record
                   xs,ys:word;
                   data:pointer;
        end;

    procedure getpic(x1,y1,x2,y2:integer;var bitmap:Upic;where:word);
    procedure putpic(x,y:word;pic:Upic;where:word);
    procedure putcpic(x,y:word;pic:Upic;where:word);
    procedure savetopic(x1,y1,x2,y2:word;fn:string;where:word);
    procedure savepic(pic:Upic;fn:string);
    procedure loadpic(var pic:Upic;fn:string);
    procedure scalepic(ox,oy:word;pic:Upic;sc:real;where:word);
    procedure disposepic(var pic:Upic);

    implementation

    procedure getpic(x1,y1,x2,y2:integer;var bitmap:Upic;where:word);
    var
       i,line,off:word;
    begin
         line:=x1+y1*320;
         off:=0;
         bitmap.xs:=abs(x1-x2);
         bitmap.ys:=abs(y1-y2);
         getmem(bitmap.data,bitmap.xs*bitmap.ys);
         for i:=1 to bitmap.ys do begin
             move(mem[where:line],mem[seg(bitmap.data^):off],bitmap.xs);
             inc(line,320);
             inc(off,bitmap.xs);
         end;
    end;

    procedure putpic(x,y:word;pic:Upic;where:word);
    var
       i,off,line:word;

    begin
         line:=x+320*y;
         off:=0;
         for i:=1 to pic.ys do begin
             move(mem[seg(pic.data^):ofs(pic.data^)+off],mem[where:line],pic.xs);
             inc(line,320);
             inc(off,pic.xs);
         end;
    end;

    procedure putcpic(x,y:word;pic:Upic;where:word);
    var
       i,j,off,line:word;
       c:byte;
    begin
         line:=x+320*y;
         off:=0;
         for i:=1 to pic.ys do begin
             for j:=0 to pic.xs-1 do begin
                 c:=mem[seg(pic.data^):ofs(pic.data^)+off];
                 if c<>0 then
                    mem[where:line+j]:=c;
                 inc(off);
             end;
             inc(line,320);
         end;
    end;

    procedure savetopic(x1,y1,x2,y2:word;fn:string;where:word);
    var
       f:file of Tpic;
       f2:file;
       a:Upic;
       b:Tpic;
    begin
         getpic(x1,y1,x2,y2,a,where);
         b.xs:=a.xs;
         b.ys:=a.ys;
         assign(f,fn);
         assign(f2,fn);
         rewrite(f);
         write(f,b);
         close(f);
         reset(f2,1);
         seek(f2,4);
         blockwrite(f2,a.data^,a.xs*a.ys);
         close(f2);
         disposepic(a);
    end;

    procedure savepic(pic:Upic;fn:string);
    var
       f:file of Tpic;
       f2:file;
       b:Tpic;
    begin
         assign(f,fn);
         assign(f2,fn);
         b.xs:=pic.xs;
         b.ys:=pic.ys;
         rewrite(f);
         write(f,b);
         close(f);
         reset(f2,1);
         seek(f2,4);
         blockwrite(f2,pic.data^,pic.xs*pic.ys);
         close(f2);
    end;

    procedure loadpic(var pic:Upic;fn:string);
    var
       f:file of Tpic;
       f2:file;
       b:Tpic;
    begin
         assign(f,fn);
         assign(f2,fn);
         reset(f);
         read(f,b);
         close(f);
         pic.xs:=b.xs;
         pic.ys:=b.ys;
         getmem(pic.data,pic.xs*pic.ys);
         reset(f2,1);
         seek(f2,4);
         blockread(f2,pic.data^,pic.xs*pic.ys);
         close(f2);
    end;

    procedure scalepic(ox,oy:word;pic:Upic;sc:real;where:word);
    var
       x,y,wo,off:integer;
       yscalei,xscales,yscales,xscalei,sc2,sc3:real;
       data:byte;
    begin
         off:=ox+oy*320;
         wo:=0;
         data:=0;
         yscalei:=0;
         sc2:=sc*pic.xs;
         sc3:=sc*pic.ys;
         yscales:=pic.ys/sc3;
         xscales:=pic.xs/sc2;
         for y:=0 to trunc(sc3)-1 do begin
             xscalei:=0;
             for x:=0 to trunc(sc2)-1 do begin
                 data:=mem[seg(pic.data^):ofs(pic.data^)+wo+trunc(xscalei)];
                 if data<>0 then mem[where:off+x]:=data;
                 xscalei:=xscalei+xscales;
             end;
             yscalei:=yscalei+yscales;
             inc(off,320);
             wo:=pic.xs*trunc(yscalei);
         end;
    end;

    procedure disposepic(var pic:Upic);
    begin
         if pic.data=nil then exit
         else freemem(pic.data,pic.xs*pic.ys);
    end;

    end.

[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]