{ Отзывы присылайте на склад нитроманита nitromanit@mail.ru 
}

{$G+}
Unit convert;

interface

function ConvResult:word;
function ConvResMsg(a:word):string;
procedure loadpage(fname:string;var paletbuf,buf);
procedure savepage(fname:string;var paletbuf,buf);
procedure saveblk(fname:string;var paletbuf,buf);
procedure loadblk(fname:string;var paletbuf,buf);
procedure loadbmp(fname:string;var paletbuf,buf);
procedure savebmp(fname:string;var paletbuf,buf);

implementation

type Tbuf=record
          wighthX,wighthY:word;
          image:array [0..64160] of byte;
          end;
     Lbuf=record
          wighthX,wighthY:word;
          image:array [0..1700] of byte;
          end;
     palette=record
             red,green,blue:byte;
             end;
     paletbufp=array [0..255] of palette;
     THeader=record
             id:word;
             fsize,ver,image,misc,wighth,height:longint;
             num,bits:word;
             comp,isize,xres,yres,psize,res:longint;
             end; {54 bytes}

var f:file;
    a,d,cres:word;
    header:THeader;

function ConvResult:word;
begin
ConvResult:=cres;
cres:=0;
end;

function ConvResMsg(a:word):string;
var s:string;
begin
  case a of
    0:s:='Ok';
    2:s:='File not found';
    3:s:='Path not found';
    4:s:='Files open too much';
    5:s:='Access denied';
   12:s:='Incorrect access code to file';
   50:s:='Need .vga file';
   51:s:='Need .blk file';
   52:s:='Need .bmp file';
   53:s:='Need .bmp file with 8 bits per color';
   54:s:='Need .bmp file with compression=0';
  else s:='Error';
  end;
ConvResMsg:=s;
end;

procedure loadpage(fname:string;var paletbuf,buf);
var ibuf:tbuf absolute buf;
begin
     assign(f,Fname);{$i-}
     reset(f,1);     {$i+}
     cres:=ioresult;
     if cres<>0 then exit;
     if (pos('.vga',fname)=0) and (pos('.VGA',fname)=0) then begin cres:=50;exit;end;
     blockread(f,paletbuf,sizeof(paletbufp),d);
     blockread(f,ibuf.image,64000,d);
     close(f);
     ibuf.wighthX:=320;
     ibuf.wighthY:=200;
end;

procedure savepage(fname:string;var paletbuf,buf);
var ibuf:tbuf absolute buf;
begin
     assign(f,Fname);{$i-}
     rewrite(f,1);   {$i+}
     cres:=ioresult;
     if cres<>0 then exit;
     blockwrite(f,paletbuf,sizeof(paletbufp),d);
     blockwrite(f,ibuf.image,64000,d);
     close(f);
end;

procedure saveblk(fname:string;var paletbuf,buf);
var ibuf:tbuf absolute buf;
begin
     assign(f,Fname);{$i-}
     rewrite(f,1);   {$i+}
     cres:=ioresult;
     if cres<>0 then exit;
     blockwrite(f,paletbuf,sizeof(paletbufp),d);
     a:=4+word((ibuf.wighthX)*(ibuf.wighthY));
     blockwrite(f,ibuf,a,d);
     close(f);
end;

procedure loadblk(fname:string;var paletbuf,buf);
var ibuf:tbuf absolute buf;
begin
     assign(f,Fname);{$i-}
     reset(f,1);     {$i+}
     cres:=ioresult;
     if cres<>0 then exit;
     if (pos('.blk',fname)=0) and (pos('.BLK',fname)=0)  then begin cres:=51;exit;end;
     blockread(f,paletbuf,sizeof(paletbufp),d);
     a:=filesize(f)-768;
     blockread(f,ibuf.wighthX,a,d);
     close(f);
end;

procedure loadbmp(fname:string;var paletbuf,buf);
type Tbmppalet=record
              blue,green,red,brightness:byte;
              end;
     bmppaletbufp=array [0..255] of Tbmppalet;

var a,b,d,k,i,x,y:word;
    bmppaletbuf:bmppaletbufp;
    l:longint;
    put_ky,total_y:real;
    ibuf:tbuf absolute buf;
    jbuf:lbuf; {jbuf - helpbuf может иметь размер <=2000 байт}
    palbuf:paletbufp absolute paletbuf;

    procedure prepare1(k:word;var buf);assembler;
                           asm
                           push es
                           push ds
                           push cx
                           les di,buf
                           add di,4
                           mov cx,k
                           add di,cx
                           dec di
                           lds si,buf
                           add si,4
                           shr cx,1
                       @d1:mov al,es:[di]
                           mov ah,al
                           mov al,ds:[si]
                           mov es:[di],al
                           mov al,ah
                           mov ds:[si],al
                           dec di
                           inc si
                           loop @d1
                           pop cx
                           pop ds
                           pop es
                           end;

    procedure prepare2(x,y:word;var buf);assembler;
                           asm
                           push es
                           push ds
                           push ax
                           push bx
                           push cx
                           push dx
                           mov cx,y
                           mov ax,x
                           shr ax,1
                           mov dx,ax {dx=x/2}
                           mov ax,x
                           mov bx,ax {bx=x}
                           dec ax    {ax=x-1}
                           les di,buf
                           add di,4
                           lds si,buf
                           add si,4
                           add si,ax {x-1}
                       @d2:push cx
                           mov cx,dx {cx=dx=x/2}
                       @d3:mov al,es:[di]
                           mov ah,al
                           mov al,ds:[si]
                           mov es:[di],al
                           mov al,ah
                           mov ds:[si],al
                           inc di
                           dec si
                           loop @d3
                           add di,dx {di=di+dx=di+x/2}
                           add si,bx {si=si+bx+dx=si+x+x/2}
                           add si,dx
                           pop cx
                           loop @d2
                           pop dx
                           pop cx
                           pop bx
                           pop ax
                           pop ds
                           pop es
                           end;

    procedure res(x,yline:word;var buf,hbuf);assembler;
    asm
           push bx
           push dx
           push si
           push cx
           push di
           push es
           push ds
           les di,buf
           add di,4
           mov ax,yline {номер создаваемой строки}
           mov bx,320 {новый размер в bx}
           mul bx
           add di,ax
           mov ax,X {старый размер в ax}
           shl ax,6
           xor dx,dx
           div bx
           mov dx,ax {dx=put_kx}
           lds si,hbuf
           add si,4
    @rline:mov cx,320
           mov bx,0 {bx это total_x}
           xor ax,ax
   @rline1:push si
           add si,ax
           movsb
           pop si
           mov ax,bx
           add ax,dx
           mov bx,ax
           shr ax,6
           loop @rline1
           pop ds
           pop es
           pop di
           pop cx
           pop si
           pop dx
           pop bx
    end;

begin
     assign(f,Fname);{$i-}
     reset(f,1);     {$i+}
     cres:=ioresult;
     if cres<>0 then exit;
     if (pos('.bmp',fname)=0) and (pos('.BMP',fname)=0) then begin cres:=52;exit;end;
     blockread(f,header,sizeof(THeader));
     blockread(f,bmppaletbuf,sizeof(bmppaletbufp),d);
     if header.bits<>8 then begin close(f);cres:=53;exit;end;
     if header.comp<>0 then begin close(f);cres:=54;exit;end;
     seek(f,header.image);
     l:=header.isize;
     if l>64000 then begin
                         x:=header.wighth;
                         put_ky:=header.height/200;
                         y:=0;total_y:=0;
                         repeat
                         seek(f,header.image+(x*trunc(total_y)));
                         blockread(f,jbuf.image,x,d);
                             res(x,y,buf,jbuf);
                             inc(y);
                             total_y:=total_y+put_ky;
                         until y=200;
                         ibuf.wighthX:=320;
                         ibuf.wighthY:=y;
                         k:=320*y;
                         prepare1(k,buf);
                         prepare2(320,200,buf);
                         end
                    else begin
                         k:=word(l);
                         blockread(f,ibuf.image,k,d);
                         ibuf.wighthX:=header.wighth;
                         ibuf.wighthY:=header.height;
                         prepare1(k,buf);
                         prepare2(header.wighth,header.height,buf);
                         end;
     close(f);
     for i:=0 to 255 do begin
                        palbuf[i].red:=byte(trunc(bmppaletbuf[i].red/4));
                        palbuf[i].green:=byte(trunc(bmppaletbuf[i].green/4));
                        palbuf[i].blue:=byte(trunc(bmppaletbuf[i].blue/4));
                        end;
end;

procedure savebmp(fname:string;var paletbuf,buf);

type Tbmppalet=record
              blue,green,red,brightness:byte;
              end;
     bmppaletbufp=array [0..255] of Tbmppalet;

var a,b,d,k,i,x,y,v:word; {v-popravka na nechetnoe znachenie wighthX}
    bmppaletbuf:bmppaletbufp;
    ibuf:tbuf absolute buf;
    palbuf:paletbufp absolute paletbuf;

begin
     assign(f,Fname);{$i-}
     rewrite(f,1);   {$i+}
     cres:=ioresult;
     if cres<>0 then exit;
     for i:=0 to 255 do begin
         bmppaletbuf[i].red:=byte(trunc(palbuf[i].red*4));
         bmppaletbuf[i].green:=byte(trunc(palbuf[i].green*4));
         bmppaletbuf[i].blue:=byte(trunc(palbuf[i].blue*4));
         bmppaletbuf[i].brightness:=0;
     end;
     header.id:=$4d42;
     header.ver:=0;
     header.image:=1078;
     header.misc:=40;
     header.wighth:=ibuf.wighthX;
     header.height:=ibuf.wighthY;
     x:=header.wighth;
     y:=header.height;
     header.num:=1;
     header.bits:=8;
     header.comp:=0;
     header.isize:=longint(trunc(ibuf.wighthX*ibuf.wighthY));
     header.fsize:=header.isize+header.image;
     header.xres:=0;
     header.yres:=0;
     header.psize:=0;
     header.res:=0;
     k:=word(header.isize);
     if odd(x) then v:=2 else v:=0;
                           asm
                           push es
                           push ds
                           push cx
                           les di,buf
                           add di,4
                           mov cx,k
                           add di,cx
                           dec di
                           lds si,buf
                           add si,4
                           shr cx,1
                       @d1:mov al,es:[di]
                           mov ah,al
                           mov al,ds:[si]
                           mov es:[di],al
                           mov al,ah
                           mov ds:[si],al
                           dec di
                           inc si
                           loop @d1
                           pop cx
                           pop ds
                           pop es
                           push es
                           push ds
                           push ax
                           push bx
                           push cx
                           push dx
                           les di,buf
                           add di,4
                           mov ax,x
                           shr ax,1
                           mov bx,ax
                           mov dx,x
                           add dx,bx
                           add bx,v
                           mov cx,y
                           lds si,buf
                           add si,4
                           add si,x
                           dec si
                       @d2:push cx
                           mov cx,bx
                       @d3:mov al,es:[di]
                           mov ah,al
                           mov al,ds:[si]
                           mov es:[di],al
                           mov al,ah
                           mov ds:[si],al
                           inc di
                           dec si
                           loop @d3
                           add di,bx
                           add si,dx
                           pop cx
                           loop @d2
                           pop dx
                           pop cx
                           pop bx
                           pop ax
                           pop ds
                           pop es
                           end;
     blockwrite(f,header,sizeof(THeader));
     blockwrite(f,bmppaletbuf,sizeof(bmppaletbufp),d);
     blockwrite(f,ibuf.image,header.isize,d);
     close(f);
end;
begin
cres:=0;
end.