Displaying PCX, GIF and BMP.

Hi everybody,

Many people ask me some source for displaying BMP-, GIF- and PCX files.
I get a message almost every day. So it's beter for me (and you) to post
in on the newsgroup. Everybody can dload it now!

Please dont't email me for this anymore.

GreetZ, Nico.
-------------- BEGIN OF PASCAL SOURCE
-----------------------------------

unit XMisc2;

interface

Type
        TByteArray = array[0..0] of byte; {Array of bytes, useful for
typecasting}
        TIntArray  = array[0..0] of integer; {Array of integers, useful
for typecasting}
        TWordArray = array[0..0] of integer; {Array of words, useful for
typecasting}
        TCharArray = array[0..0] of char; {Array of chars, useful for
typecasting}

function  XIntToStr( n : integer; w : byte ) : string;
{ This function transforms the integer n into a string with with w}
function  XCompare( var a, b; l : word ) : boolean;
{ This function compares variables a and b for l bytes and, if equal
        it returns TRUE. It returns FALSE otherwise}
function  XExists( filename : string ) : boolean;
{ This functions returns TRUE if the file "filename" exists. It
        returns false otherwise}
procedure XStrUpCase( var s : string );
{ This procedure makes all the characters in a string uppercase}

implementation

function xinttostr( n : integer; w : byte ) : string;
var
        s : string;
begin
        str( n:w, s );
        xinttostr := s;
end;

function xcompare( var a, b; l : word ) : boolean; assembler;
asm
        cld
        push ds
        lds  si, a
        les  di, b
        mov  cx, l
        repe cmpsb
        or   cx, cx
        jz   @@Ok
        mov  ax, 0
        jmp  @@Done

@@Ok:
        mov  ax, 1

@@Done:
        pop  ds

end;

function xexists( filename : string ) : boolean;
var
        f : file;
        tmp : boolean;
begin
        {$I-}
        assign( f, filename );
        reset( f );
        {$I+}
        tmp := ioresult=0;
        if tmp then close(f);
        xexists := tmp;
end;

procedure xstrupcase( var s : string ); assembler;
asm
        les di, s
        mov cx, 0
        mov cl, es:[di]
        inc di
        or  cl, cl
        jz @@Done

@@ChangeChar:
        mov al, es:[di]
        cmp al, 'a'
        jl @@Next
        cmp al, 'z'
        jg @@Next
        sub al, 32
        mov es:[di], al
@@Next:
        inc di
        loop @@ChangeChar
@@Done:
end;

end.

------------------------------GIFVIEWER--------------------------------

unit XGif2;
{ ************************************************
  **    GIF Decoding and Encoding procedures    **
  **        for Borland/Turbo Pascal 7.0        **
  **                                            **
  **     Written by Tristan Tarrant, 1994       **
  **                                            **
  **        ( Supports GIF87a/GIF89a )          **
        ************************************************ }

interface

uses
        Dos,XMisc2;

const
        { Error constants used in GIF decoder }
        GoodRead      = 0; { No errors encountered during
encoding/decoding }
        BadFile       = 1; { Physical problem with the media}
        BadRead       = 2; { Could not read/interpret part of the file }
        UnexpectedEOF = 3; { File too short during decoding}
        BadCode       = 4; { Code encountered during decoding was not
expected}
        BadFirstCode  = 5; { The first code was invalid}
        NoFile        = 6; { Could not open the file for read/write}
        BadSymbolSize = 7; { Number of bits not supported}
        NoCode        = -1;

Type
        GifLineProcType = procedure( Var pixels; line, width : integer
);
        GifPixelProcType = function : integer;

Var
        { Pointers to custom procedures to deal with lines.
GifOutLineProc
                is called with three parameters : an untyped var,
containing
                the uncompressed data, and two integer values,
containing the
                line number and the width of the line.
                GifInPixelProc should instead return a pixels value, -1
if at the
                end of the data. }

        GifOutLineProc : GifLineProcType;
{ GifOutLineProc is called with an untyped variable containing a row's
        worth of pixels. The current line is given in line and the
number of
        pixels in a line is given in width}
        GifInPixelProc : GifPixelProcType;
{ GifInPixelProc should return a pixel value, -1 if at the end of the
data.
        Data should be returned width first (i.e. all pixels in row 0,
then all
        pixels in row 1, etc.}
        GifPalette : array[0..767] of byte;
{ GifPalette is an array which contains the palette of the last loaded
        GIF file}

function LoadGif( f : string ) : integer;
{ This function loads a GIF file f and returns an error code.
        It uses the #GIFLineProc# procedure to send the decoded picture
        to the application. The palette of the picture is stored in the
        global variable #GifPalette#}
function SaveGif( f : string; width, depth, bits : integer; var palette
) : integer;
{ This function saves a GIF file f with using screen size width*depth
        and with a color resolution of bits. For a 256 colour image bits
is 8.
        Palette contains the palette of the picture that is being saved.
        SaveGIF uses #GIFInPixelProc# to get the picture data from the
application.
        It returns an error code}
function GifError( ErrorCode : integer ) : string;
{ This function converts an error code returned by SaveGIF into a
string}

Implementation

type
        GifHeader =
                record
                        sig : array[1..6] of char;
                        screenwidth, screendepth : word;
                        flags, background, aspect : byte;
                end;

        ImageBlock =
                record
                        left, top, width, depth : word;
                        flags : byte;
                end;

        FileInfo =
                record
                        width, depth, bits,
                        flags, background : integer;
                        palette : array[1..768] of byte;
                end;

        ControlBlock =
                record
                        blocksize, flags : byte;
                        delay : word;
                        transparentcolour, terminator : byte;
                end;

        PlainText =
                record
                        blocksize : byte;
                        left, top, gridwidth, gridheight : word;
                        cellwidth, cellheight, forecolour, backcolour :
byte;
                end;

        Application =
                record
                        blocksize : byte;
                        applstring : array[1..8] of char;
                        authentication : array[1..3] of char;
                end;

const
        TableSize = 5003;
        { These values will be masked with the codes output from the
                decoder to remove spurious bits }
        CodeMask : array[1..13] of word =
                ( $0000,
                        $0001, $0003,
                        $0007, $000F,
                        $001F, $003F,
                        $007F, $00FF,
                        $01FF, $03FF,
                        $07FF, $0FFF );
        LargestCode = 4095;

function UnpackImage( var F : File; bits : integer; Var fi : FileInfo )
: integer;
var
        bits2, codesize, codesize2, nextcode, thiscode,
        oldtoken, currentcode, oldcode, bitsleft, blocksize,
        line, pass, byt, p, q, u : integer;
        b : array[0..255] of byte;
        linebuffer, firstcodestack, lastcodestack : ^TByteArray;
        codestack : ^TIntArray;
const
        wordmasktable : array[0..15] of word =
                ( $0000, $0001, $0003, $0007, $000F, $001F,
                        $003F, $007F, $00FF, $01FF, $03FF, $07FF,
                        $0FFF, $1FFF, $3FFF, $7FFF );
        inctable : array[0..4] of integer = ( 8, 8, 4, 2, 0 );
        starttable : array[0..4] of integer = ( 0, 4, 2, 1, 0 );
begin
        pass := 0;
        line := 0;
        byt := 0;
        p := 0;
        q := 0;
        blocksize := 0;
        fillchar( b, 256, 0 );
        bitsleft := 8;
        if ( bits < 2 ) or ( bits > 8 ) then
        begin
                UnpackImage := BadSymbolSize;
                exit;
        end;
        bits2 := 1 shl bits;
        nextcode := bits2 + 2;
        codesize := bits + 1;
        codesize2 := 1 shl codesize;
        oldcode := NoCode;
        oldtoken := NoCode;
        getmem( firstcodestack, 4096 );
        getmem( lastcodestack, 4096 );
        getmem( codestack, 8192 );
        getmem( linebuffer, fi.width );
        while true do
        begin
                if bitsleft = 8 then
                begin
                        inc(p);
                        if p>=q then
                        begin
                                blocksize := 0;
                                blockread( F, blocksize, 1);
                                if blocksize>0 then
                                begin
                                        p:=0;
                                        blockread( F, b, blocksize, q );
                                        if q<>blocksize then
                                        begin
                                                freemem( firstcodestack,
4096 );
                                                freemem( lastcodestack,
4096 );
                                                freemem( codestack, 8192
);
                                                freemem( linebuffer,
fi.width );
                                                UnpackImage :=
UnexpectedEOF;
                                                exit;
                                        end;
                                end else
                                begin
                                        freemem( firstcodestack, 4096 );
                                        freemem( lastcodestack, 4096 );
                                        freemem( codestack, 8192 );
                                        freemem( linebuffer, fi.width );
                                        UnpackImage := UnexpectedEOF;
                                        exit;
                                end;
                        end;
                        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
                        begin
                                blocksize := 0;
                                blockread( F, blocksize, 1);
                                if blocksize>0 then
                                begin
                                        p:=0;
                                        blockread( F, b, blocksize, q );
                                        if q<>blocksize then
                                        begin
                                                freemem( firstcodestack,
4096 );
                                                freemem( lastcodestack,
4096 );
                                                freemem( codestack, 8192
);
                                                freemem( linebuffer,
fi.width );
                                                UnpackImage :=
UnexpectedEOF;
                                                exit;
                                        end;
                                end else
                                begin
                                        freemem( firstcodestack, 4096 );
                                        freemem( lastcodestack, 4096 );
                                        freemem( codestack, 8192 );
                                        freemem( linebuffer, fi.width );
                                        UnpackImage := UnexpectedEOF;
                                        exit;
                                end;
                        end;
                        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
                                begin
                                        blocksize := 0;
                                        blockread( F, blocksize, 1);
                                        if blocksize>0 then
                                        begin
                                                p:=0;
                                                blockread( F, b,
blocksize, q );
                                                if q<>blocksize then
                                                begin
                                                        freemem(
firstcodestack, 4096 );
                                                        freemem(
lastcodestack, 4096 );
                                                        freemem(
codestack, 8192 );
                                                        freemem(
linebuffer, fi.width );
                                                        UnpackImage :=
UnexpectedEOF;
                                                        exit;
                                                end;
                                        end else
                                        begin
                                                freemem( firstcodestack,
4096 );
                                                freemem( lastcodestack,
4096 );
                                                freemem( codestack, 8192
);
                                                freemem( linebuffer,
fi.width );
                                                UnpackImage :=
UnexpectedEOF;
                                                exit;
                                        end;
                                end;
                                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 break;
                if thiscode > nextcode then
                begin
                        freemem( firstcodestack, 4096 );
                        freemem( lastcodestack, 4096 );
                        freemem( codestack, 8192 );
                        freemem( linebuffer, fi.width );
                        UnpackImage := BadCode;
                        exit;
                end;
                if thiscode = bits2 then
                begin
                        nextcode := bits2+2;
                        codesize := bits + 1;
                        codesize2 := 1 shl codesize;
                        oldtoken := NoCode;
                        OldCode := NoCode;
                        continue;
                end;
                u := 0;
                if thiscode = nextcode then
                begin
                        if oldcode = NoCode then
                        begin
                                freemem( firstcodestack, 4096 );
                                freemem( lastcodestack, 4096 );
                                freemem( codestack, 8192 );
                                freemem( linebuffer, fi.width );
                                UnpackImage := BadFirstCode;
                                exit;
                        end;
                        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;
                while true do
                begin
                        linebuffer^[byt] := thiscode;
                        inc( byt );
                        if byt >= fi.width then
                        begin
                                GifOutLineProc( linebuffer^, line,
fi.width );
                                byt := 0;
                                if fi.flags and $40 = $40 then
                                begin
                                        line := line + inctable[pass];
                                        if line >= fi.depth then
                                        begin
                                                inc(pass);
                                                line :=
starttable[pass];
                                        end;
                                end else inc(line);
                        end;
                        if u <= 0 then break;
                        dec( u );
                        thiscode := firstcodestack^[u];
                end;
                if (nextcode < 4096) and (oldcode <> NoCode) 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;
        end;
        freemem( firstcodestack, 4096 );
        freemem( lastcodestack, 4096 );
        freemem( codestack, 8192 );
        freemem( linebuffer, fi.width );
        UnpackImage := GoodRead;
end; { UnpackImage }

procedure SkipExtension( Var F : File );
var
        pt : PlainText;
        cb : ControlBlock;
        ap : Application;
        i : integer;
        a, n, c : byte;
        r : word;
begin
        blockread( F, c, 1 );
        case c of
                $01 :
                        begin
                                blockread( F, pt, sizeof( PlainText ) );
                                blockread( F, n, 1 );
                                while n > 0 do
                                begin
                                        for i := 0 to n-1 do
                                                blockread( F, a, 1 );
                                        blockread( F, n, 1 );
                                end;
                        end;
                $F9 :
                        blockread( F, cb, sizeof( ControlBlock ) );
                $FE :
                        begin
                                blockread( F, n, 1 );
                                while n > 0 do
                                begin
                                        for i:= 0 to n-1 do
                                                blockread( F, a, 1 );
                                        blockread( F, n, 1 );
                                end;
                        end;
                $FF :
                        begin
                                blockread( F, ap, sizeof( Application )
);
                                blockread( F, n, 1 );
                                while n > 0 do
                                begin
                                        for i := 0 to n-1 do
                                                blockread( F, a, 1 );
                                        blockread( F, n, 1 );
                                end;
                        end;
                else
                        begin
                                blockread( F, n, 1 );
                                for i := 0 to n-1 do
                                                blockread( F, a, 1 );
                        end;
        end;
end; { SkipExtension }

function UnpackGIF( Var F : File ) : integer;
var
        gh : GifHeader;
        iblk : ImageBlock;
        t : longint;
        b, c : integer;
        r : word;
        ch : char;
        fi : FileInfo;
begin
        blockread( F, gh, SizeOf(GifHeader), r );
        if ( gh.sig[1]+gh.sig[2]+gh.sig[3]<>'GIF' ) or (
r<>SizeOf(GifHeader) ) then
        begin
                UnpackGIF := BadFile;
                exit;
        end;
        fi.width := gh.screenwidth;
        fi.depth := gh.screendepth;
        fi.bits := gh.flags and $07 + 1;
        fi.background := gh.background;
        if ( gh.flags and $80 )=$80 then
        begin
                c:=3*( 1 shl fi.bits );
                blockread( F, fi.palette, c, r );
                if r<>c then
                begin
                        UnpackGIF := BadRead;
                        exit;
                end;
                for b := 0 to 255 do
                begin
                        GIFPalette[b*3] := fi.palette[b*3+1] shr 2;
                        GIFPalette[b*3+1] := fi.palette[b*3+2] shr 2;
                        GIFPalette[b*3+2] := fi.palette[b*3+3] shr 2;
                end;

        end;
        blockread( F, ch, 1 );
        while ( ch = ',' ) or ( ch = '!' ) or ( ch = #0 ) do
        begin
                case ch of
                        ',' : begin
                                                        blockread( F,
iblk, SizeOf(ImageBlock), r );
                                                        if
r<>SizeOf(ImageBlock) then
                                                        begin
                                                                UnpackGIF
:= BadRead;
                                                                Exit;
                                                        end;
                                                        fi.width :=
iblk.width;
                                                        fi.depth :=
iblk.depth;
                                                        if ( iblk.flags
and $80 )=$80 then
                                                        begin
                                                                b :=
3*(1 shl (iblk.flags and $07 + 1));
                                                                blockread(
F, fi.palette, b, r );
                                                                if r<>b
then
                                                                begin
                                                                        UnpackGIF
:= BadRead;
                                                                        Exit;
                                                                end;
                                                                for b :=
0 to 255 do
                                                                begin
                                                                        GIFPalette[b*3]
:= fi.palette[b*3+1] shr 2;
                                                                        GIFPalette[b*3+1]
:= fi.palette[b*3+2] shr 2;
                                                                        GIFPalette[b*3+1]
:= fi.palette[b*3+3] shr 2;
                                                                end;
                                                        end;
                                                        if EOF( F ) then
                                                        begin
                                                                UnpackGIF
:= BadFile;
                                                                Exit;
                                                        end;
                                                        c:=0;
                                                        blockread( F, c,
1 );
                                                        fi.flags:=iblk.flags;
                                                        t :=
UnpackImage( F, c, fi );
                                                        UnpackGif:=t;
                                                        exit;
                                                end;
                        '!' : SkipExtension( F );
                end;
        end;
end; { UnpackGIF }

function LoadGif;
var
        D: DirStr;
        N: NameStr;
        E: ExtStr;
        FileHandle : File;
begin
        FSplit( F, D, N, E );
        if E='' then E:='.GIF';
        F := D+N+E;
        {$I-}
                assign( FileHandle, F );
                reset( FileHandle, 1 );
        {$I+}
        if ioresult = 0 then
                LoadGif := UnpackGif( FileHandle )
        else
                LoadGif := NoFile;
        {$I-}
                close( FileHandle );
        {$I+}
end; { LoadGif }

function WriteScreenDesc( var fp : file; width, depth, bits, background
: integer; var palette ) : integer;
var
        gh : GIFHeader;
        i : integer;
        gifsig : string;
        pal : TByteArray absolute palette;
        a : byte;
begin
        FillChar( gh, sizeof(GIFHeader),0 );
        gifsig := 'GIF87a';
        move( gifsig[1], gh.sig[1], 6 );
        gh.screenwidth := width;
        gh.screendepth := depth;
        gh.background := background;
        gh.aspect := 0;
        gh.flags := $80 or ((bits-1) shl 4) or ((bits-1) and $07);
        blockwrite( fp, gh, sizeof(GIFHeader) );
        for i := 0 to (1 shl bits)*3-1 do
        begin
                a := pal[i] shl 2;
                blockwrite( fp, a, 1 );
        end;
        WriteScreenDesc := 0;
end;

function WriteImageDesc( var fp : file; left, top, width, depth, bits :
integer ) : integer;
var
        ib : ImageBlock;
        ch : char;
begin
        fillchar( ib, sizeof(ImageBlock), 0 );
        ch := ',';
        blockwrite( fp, ch, 1 );
        ib.left := left;
        ib.top := top;
        ib.width := width;
        ib.depth := depth;
        ib.flags := bits-1;
        blockwrite( fp, ib, sizeof(ImageBlock) );
        WriteImageDesc := 0;
end;

function CompressImage( var fp : file; mincodesize : word ) : integer;
var
        prefixcode, suffixchar, hx, d : integer;
        codebuffer, newcode : ^TByteArray;
        oldcode, currentcode : ^TIntArray;
        codesize, clearcode, eofcode, bitoffset,
        byteoffset, bitsleft, maxcode, freecode : integer;

        procedure InitTable( mincodesize : integer );
        var
                i : integer;
        begin
                codesize := mincodesize + 1;
                clearcode := 1 shl mincodesize;
                eofcode := clearcode+1;
                freecode := clearcode+2;
                maxcode := 1 shl codesize;
                for i := 0 to tablesize-1 do
                        currentcode^[i] := 0;
        end;

        procedure Deallocate;
        begin
                freemem( newcode, tablesize+1 );
                freemem( currentcode, (tablesize+1)*2 );
                freemem( oldcode, (tablesize+1)*2 );
                freemem( codebuffer, 260 );
        end;

        procedure FlushFile( var fp : file; n : integer );
        var
                a : byte;
        begin
                a := n;
                blockwrite( fp, a, 1 );
                blockwrite( fp, codebuffer^[0], n );
        end;

        procedure WriteCode( var fp : file; code : integer );
        var
                temp : longint;
        begin
                byteoffset := bitoffset shr 3;
                bitsleft := bitoffset and 7;
                if byteoffset >= 254 then
                begin
                        FlushFile( fp, byteoffset );
                        codebuffer^[0] := codebuffer^[byteoffset];
                        bitoffset := bitsleft;
                        byteoffset := 0;
                end;
                if bitsleft > 0 then
                begin
                        temp := ( longint(code) shl bitsleft ) or
codebuffer^[byteoffset];
                        codebuffer^[byteoffset] := temp;
                        codebuffer^[byteoffset+1] := temp shr 8;
                        codebuffer^[byteoffset+2] := temp shr 16;
                end else
                begin
                        codebuffer^[byteoffset] := code;
                        codebuffer^[byteoffset+1] := code shr 8;
                end;
                bitoffset := bitoffset + codesize;
        end;

begin
        if (mincodesize<2) or (mincodesize>9) then
                if mincodesize = 1 then
                        mincodesize := 2
                else
                begin
                        CompressImage := 1;
                        exit;
                end;
        getmem( codebuffer, 260 );
        getmem( oldcode, (tablesize+1)*2 );
        getmem( currentcode, (tablesize+1)*2 );
        getmem( newcode, tablesize+1 );
        bitoffset := 0;
        InitTable( mincodesize );
        blockwrite( fp, mincodesize, 1 );
        suffixchar := GIFInPixelProc;
        if suffixchar < 0 then
        begin
                CompressImage := 1;
                Deallocate;
                exit;
        end;
        prefixcode := suffixchar;
        suffixchar := GIFInPixelProc;
        while suffixchar>=0 do
        begin
                hx := (prefixcode xor (suffixchar shl 5)) mod tablesize;
                d := 1;
                while true do
                begin
                        if currentcode^[hx] = 0 then
                        begin
                                writecode( fp, prefixcode );
                                d := freecode;
                                if freecode <= largestcode then
                                begin
                                        oldcode^[hx] := prefixcode;
                                        newcode^[hx] := suffixchar;
                                        currentcode^[hx] := freecode;
                                        inc(freecode);
                                end;
                                if d=maxcode then
                                begin
                                        if codesize<12 then
                                        begin
                                                inc(codesize);
                                                maxcode := maxcode shl
1;
                                        end else
                                        begin
                                                writecode( fp, clearcode
);
                                                InitTable( mincodesize
);
                                        end;
                                end;
                                prefixcode := suffixchar;
                                break;
                        end;
                        if (oldcode^[hx] = prefixcode) and (newcode^[hx]
= suffixchar ) then
                        begin
                                prefixcode := currentcode^[hx];
                                break;
                        end;
                        hx := hx + d;
                        d := d + 2;
                        if hx >= tablesize then hx := hx - tablesize;
                end;
                suffixchar := GIFInPixelProc;
        end;
        writecode( fp, prefixcode );
        writecode( fp, eofcode );
        if bitoffset >0 then FlushFile( fp, (bitoffset+7) div 8 );
        FlushFile( fp, 0 );
        CompressImage := 0;
        Deallocate;
end;

function WriteGif( var fp : file; width, depth, bits : integer; var
palette ) : integer;
var
        ch : char;
begin
        if WriteScreenDesc( fp, width, depth, bits, 0, palette )>0 then
                WriteGIF := 1
        else
        if WriteImageDesc( fp, 0, 0, width, depth, bits )>0 then
                WriteGIF := 2
        else
        if CompressImage( fp, bits )>0 then
                WriteGIF := 3
        else
        begin
                WriteGIF := 0;
                ch := ';';
                blockwrite( fp, ch, 1 );
        end;
end;

function SaveGif( f : string; width, depth, bits : integer; var palette
) : integer;
var
        D: DirStr;
        N: NameStr;
        E: ExtStr;
        FileHandle : File;
begin
        FSplit( F, D, N, E );
        if E='' then E:='.GIF';
        F := D+N+E;
        {$I-}
                assign( FileHandle, F );
                rewrite( FileHandle, 1 );
        {$I+}
        if ioresult = 0 then
                SaveGif := WriteGif( FileHandle, width, depth, bits,
palette  )
        else
                SaveGif := NoFile;
        {$I-}
                close( FileHandle );
        {$I+}
end;

function GifError;
begin
        case ErrorCode of
                GoodRead : GifError := 'Ok';
                BadFile  : GifError := 'Bad File';
                BadRead  : GifError := 'Bad Read';
                UnexpectedEOF : GifError := 'Unexpected End';
                BadCode       : GifError := 'Bad LZW Code';
                BadFirstCode  : GifError := 'Bad First Code';
                BadSymbolSize : GifError := 'Bad Symbol Size';
                NoFile        : GifError := 'File Not Found';
                else GifError := 'Unknown';
        end;
end; { GifError }

end.

---------------- END OF GIFVIEWER --------------------------------

---------------- BEGIN OF BMPVIEWER -----------------------------

unit XBmp2;
{ ************************************************
  **    BMP Decoding and Encoding procedures    **
  **        for Borland/Turbo Pascal 7.0        **
  **                                            **
  **     Written by Tristan Tarrant, 1994       **
  **                                            **
        ************************************************ }

interface

uses
        Dos, XMisc2;

type
        BMPLineProcType = procedure( Var pixels; line, width : integer
);
        BMPPixelProcType = function( x, y : integer) : integer;

Var
        { Pointers to custom procedures to deal with lines.
BMPOutLineProc
                is called with three parameters : an untyped var,
containing
                the uncompressed data, and two integer values,
containing the
                line number and the width of the line.
                BMPInPixelProc should instead return a pixels value, -1
if at the
                end of the data. }

        BMPOutLineProc : BMPLineProcType;
{ BMPOutLineProc is called with an untyped variable containing a row's
        worth of pixels. The current line is given in line and the
number of
        pixels in a line is given in width}
        BMPInPixelProc : BMPPixelProcType;
{ BMPInPixelProc should return a pixel value, -1 if at the end of the
data.
        Data should be returned width first (i.e. all pixels in row 0,
then all
        pixels in row 1, etc.}
        BMPPalette : array[0..767] of byte;
{ BMPPalette is an array which contains the palette of the last loaded
        BMP file}

function SaveBMP( f : string; width, depth : integer; var palette ) :
boolean;
{ This function saves a BMP file f with using screen size width*depth
        and with a color resolution of 8 bits which translates to a 256
colour
        image.
        Palette contains the palette of the picture that is being saved.
        SaveBMP uses #BMPInPixelProc# to get the picture data from the
application.
        It returns TRUE if successful, FALSE otherwise}
function LoadBMP( f : string ) : boolean;
{ This function loads a BMP file f and returns TRUE if successful, FALSE
        otherwise.
        It uses the #BMPLineProc# procedure to send the decoded picture
        to the application. The palette of the picture is stored in the
        global variable #BMPPalette#}

implementation

type
        BMPHeader = record
                id : array[1..2] of char;
                filesize,
                reserved,
                headersize,
                infoSize,
                wid,
                hgt : longint;
                biPlanes, bits : integer;
                biCompression,
                biSizeImage,
                biXPel{*word*237}eter,
                biYPel{*word*237}eter,
                biClrUsed,
                biClrImportant : longint;
        end;

        BMPRGB = record
                b, g, r, f : byte;
        end;

(*function DecodeBMP( var f : file ) : boolean;
var
        BMPHead : BMPHeader;
        hgt, wid, index : integer;
        r, g, b : byte;
        ScreenLine : pointer;
        col : BMPRGB;

begin
        blockread( f, BMPHead, SizeOf( BMPHead ) );
        for index:=0 to 255 do
        begin
                blockread( f, col, SizeOf( BMPRGB ) );
                BMPPalette[index*3] := col.r shr 2;
                BMPPalette[index*3+1] := col.g shr 2;
                BMPPalette[index*3+2] := col.b shr 2;
        end;
        wid := BMPHead.wid;
        if wid mod 4<>0 then wid := wid + 4 - wid mod 4;
        GetMem( ScreenLine, wid );
        hgt := BMPHead.hgt-1;
        for index:=hgt downto 0 do
        begin
                blockread( f, ScreenLine^, wid );
                BMPOutLineProc( ScreenLine^, index, wid );
        end;
        DecodeBMP := true;
end;*)

function DecodeBMP( var f : file ) : boolean;
var
        BMPHead : BMPHeader;
        i,Aantal,hgt, wid, index,kl : integer;
(*      r, g, b : byte;*)
        P,ScreenLine : pointer;
        col : BMPRGB;
        B2,B1: Byte;

begin
        DecodeBMP := False;
        blockread( f, BMPHead, SizeOf( BMPHead ) );
        Case BMPHead.Bits of
          4: kl := 15;
          8: kl := 255;
        end; { CASE }
        for index:=0 to kl do
        begin
                blockread( f, col, SizeOf( BMPRGB ) );
                BMPPalette[index*3] := col.r shr 2;
                BMPPalette[index*3+1] := col.g shr 2;
                BMPPalette[index*3+2] := col.b shr 2;
        end;
        wid := BMPHead.wid;
        if wid mod 4<>0 then wid := wid + 4 - wid mod 4;
        Case kl of
          15:  Aantal := Wid div 2;
          255: Aantal := Wid;
        end; { CASE }
        GetMem( ScreenLine, Aantal );
        If kl = 15 then
           GetMem(P,Wid);
        hgt := BMPHead.hgt-1;
        for index:=hgt downto 0 do
        begin
                blockread( f, ScreenLine^, Aantal );
                Case kl of
                 15:
                   Begin
                    (* ASM
                       PUSH ES
                       LES  DI,ScreenLine
                       MOV AL,*)
                       For i := 0 to Aantal-1 do
                         Begin
                           B2 :=
Mem[Seg(ScreenLine^):Ofs(ScreenLine^)+i];
                           B1 := B2 SHR 4;
                           B2 := B2 AND $0F;
                           Mem[Seg(P^):Ofs(P^)+i*2] := B1;
                           Mem[Seg(P^):Ofs(P^)+i*2+1] := B2;
                         end; { FOR }
                     BMPOutLineProc( P^, index, Wid );
                   end;
                 255:
                  BMPOutLineProc( ScreenLine^, index, Aantal );
                 end; { CASE }
        end;
        DecodeBMP := true;
end;

function LoadBMP( F : string ) : boolean;
var
        D: DirStr;
        N: NameStr;
        E: ExtStr;
        FileHandle : File;
begin
        FSplit( F, D, N, E );
        if E='' then E:='.BMP';
        F := D+N+E;
        {$I-}
                assign( FileHandle, F );
                reset( FileHandle, 1 );
        {$I+}
        if ioresult = 0 then
                LoadBMP := DecodeBMP( FileHandle )
        else
                LoadBMP := false;
        {$I-}
                close( FileHandle );
        {$I+}
end; { LoadBMP }

function EncodeBMP( var f : file; width, depth : integer; var palette )
: boolean;
var
        BMPHead : BMPHeader;
        hgt, wid, index, index2 : integer;
        r, g, b : byte;
        ScreenLine : pointer;
        col : BMPRGB;
        ThePalette : TByteArray absolute palette;

begin
        fillchar( BMPHead, sizeof(BMPHeader),0 );
        with BMPHead do
        begin
                id := 'BP';
                headersize := 1078;
                filesize := headersize + width*depth;
                wid := width;
                hgt := depth;
                infosize := $28;
                bits := 8;
                biplanes := 1;
                biCompression := 0;
        end;

        blockwrite( f, BMPHead, SizeOf( BMPHead ) );
        for index:=0 to 255 do
        begin
                col.r := ThePalette[index*3] shl 2;
                col.g := ThePalette[index*3+1] shl 2;
                col.b := ThePalette[index*3+2] shl 2;
                blockwrite( f, col, SizeOf( BMPRGB ) );
        end;
        wid := width;
        if wid mod 4<>0 then wid := wid + 4 - wid mod 4;
        GetMem( ScreenLine, wid );
        hgt := BMPHead.hgt-1;
        for index:=hgt downto 0 do
        begin
                fillchar( ScreenLine^,wid,0);
                for index2 := 0 to width-1 do
                        TByteArray(ScreenLine^)[index2] :=
BMPInPixelProc(index2,index);
                blockwrite( f, ScreenLine^, wid );
        end;
        EncodeBMP := true;
end;

function SaveBMP( f : string; width, depth : integer; var palette ) :
boolean;
var
        D: DirStr;
        N: NameStr;
        E: ExtStr;
        FileHandle : File;
begin
        FSplit( F, D, N, E );
        if E='' then E:='.BMP';
        F := D+N+E;
        {$I-}
                assign( FileHandle, F );
                rewrite( FileHandle, 1 );
        {$I+}
        if ioresult = 0 then
                SaveBMP := EncodeBMP( FileHandle, width, depth, palette
)
        else
                SaveBMP := false;
        {$I-}
                close( FileHandle );
        {$I+}
end;

end.

------------------ END OF BMPVIEWER ------------------------------------

------------------ BEGIN OF PCXVIEWER ----------------------------------

unit PCX;

(* version 3.1
                             by Peter Donnelly
                              1301 Ryan Street
                                Victoria BC
                               Canada V8T 4Y8

   ??
   3    May be copied freely. If you make practical use of this unit,
3
   3         a contribution of $10 or more would be appreciated.
3    
   ??

   This is a unit to read .PCX files and put them in displayable form.
The
   actual work of decoding the file and moving the data into memory is
done
   in assembler. Version 6 of Turbo Pascal is required for compilation.

   The following display modes are supported:

          Mode      TP GraphMode     Resolution    Colors
          ~~~~      ~~~~~~~~~~~~     ~~~~~~~~~~    ~~~~~~
          $04       CGAC0 to C3      320 x 200         4
          $06       CGAHi            640 x 200         2
          $0D        ---             320 x 200        16
          $0E       EGALo/VGALo      640 x 200        16
          $10       EGAHi/VGAMed     640 x 350        16
          $12       VGAHi            640 x 480        16
          $13        ---             320 x 200       256

   Mode $13 is supported only for files containing palette information,
   i.e. not those produced by versions of Paintbrush earlier than 3.0.

   The unit has been optimized for speed rather than flexibility or
   compactness. In particular, the routine for displaying 16-color files
   (which require the most computation) has been improved and now runs    
   about 50 percent faster than that in version 2.

   It is assumed that the image is the width of and no taller than the
   screen, and that you will set the correct display mode. No checking
   is done to see that the .PCX file is compatible with the mode you've
set.
   You do, however, have to pass in the Turbo GraphDriver as a parameter
   for all but 256-color files, so that the data will be interpreted
   correctly. (For mode $0D, pass in 'EGA' or 'VGA', and see the comment
on
   palettes, below.)

   For the CGA formats, the data is put into two buffers on the heap,
from
   where it can be moved into the two display memory banks. See SHOWCGA
for
   an example. You can of course alter the unit to move the data
directly
   into display memory, but there is no great saving in time.

   For EGA and VGA formats, the data is written to page 0 of the video
   buffer. This can easily be changed by setting "page_addr" to a
different
   value. Three different techniques of hiding the image while it is
being
   written are demonstrated in SHOWEGA, SHOWVGA, and SHOW256. If for any
   reason you don't want to do this, you will want to rewrite the
palette-
   interpretation routines as separate procedures so you can set the
   palette before decoding the image data.

   References:
   ~~~~~~~~~~
   Richard F. Ferraro, "Programmer's Guide to the EGA and VGA Cards"
   (Addison-Wesley, 1988).

   Richard Wilton, "Programmer's Guide to PC and PS/2 Video Systems"
   (Microsoft, 1987).

   "Technical Reference Manual [for Paintbrush]" (Zsoft, 1988). The
   information in this booklet is also found in a file distributed with
   at least some versions of Microsoft/PC Paintbrush.

   Software:
   ~~~~~~~~
   Besides the various incarnations of Paintbrush (ZSoft and Microsoft),
   the excellent Deluxe Paint II Enhanced (Electronic Arts) can also
create
   files in .PCX format. Other graphics programs have conversion
utilities.
*)

{ =======================================================================

Quote
}

INTERFACE

uses DOS, GRAPH;

type    RGBrec = record
                   redval, greenval, blueval: byte;
                 end;

var     pcxfilename: pathstr;
        file_error: boolean;
        pal: palettetype;
        RGBpal: array[0..15] of RGBrec;
        RGB256: array[0..255] of RGBrec;
        page_addr: word;
        bytes_per_line: word;
        buff0, buff1: pointer;

        { CGA display memory banks: }
        screenbuff0: array[0..7999] of byte absolute $b800:$0000;
        screenbuff1: array[0..7999] of byte absolute $b800:$2000;

const   page0 = $A000;           { EGA/VGA display segment }

procedure SETMODE(mode: byte);
procedure SETREGISTERS(var palrec);
procedure READ_PCX_FILE(gdriver: integer; pfilename: pathstr);
procedure READ_PCX256(pfilename: pathstr);

{========================================================================}

IMPLEMENTATION

var     scratch, abuff0, abuff1: pointer;
        is_CGA, is_VGA: boolean;
        repeatcount: byte;
        datalength: word;
        columncount, plane, video_index: word;
        regs: registers;

const   buffsize = 65521;   { Largest possible }

{ -------------------------- BIOS calls
--------------------------------- }

{ For modes not supported by the BGI, use SetMode to initialize the
  graphics. Since SetRGBPalette won't work if Turbo hasn't done the
  graphics initialization itself, use SetRegisters to change the colors
  in mode $13. }

procedure SETMODE(mode: byte);

begin
regs.ah:= 0;                 { BIOS set mode function }
regs.al:= mode;              { Display mode }
intr($10, regs);             { Call BIOS }
end;

procedure SETREGISTERS(var palrec);

{ Palrec is any string of 768 bytes containing the RGB data. }

begin
regs.ah:= $10;               { BIOS color register function }
regs.al:= $12;               { Subfunction }
regs.es:= seg(palrec);       { Address of palette info. }
regs.dx:= ofs(palrec);
regs.bx:= 0;                 { First register to change }
regs.cx:= $100;              { Number of registers to change }
intr($10, regs);             { Call BIOS }
end;

{ ====================== EGA/VGA 16-color files
========================= }

procedure DECODE_16; assembler;

asm

(* Registers used:

   AL   data byte to be written to video
   AH   data bytes per scan line
   BX   end of input buffer
   CL   number of times data byte is to be written
   DL   current column in scan line
   ES   output segment
   DI   index into output buffer
   DS   segment of input buffer
   SI   index into input buffer
   BP   current color plane
*)

push    bp

{ ----------------- Assembler procedure for 16-color files
-------------- }

{ The first section is initialization done on each run through the
  input buffer. }

@startproc:
mov     bp, plane           { plane in BP }
mov     es, page_addr       { video display segment }
mov     di, video_index     { index into video segment }
mov     ah, byte ptr bytes_per_line  { line length in AH }
mov     dx, columncount     { column counter }
mov     bx, datalength      { no. of bytes to read }
xor     cx, cx              { clean up CX for loop counter }
mov     cl, repeatcount     { count in CX }
push    ds                  { save DS }
lds     si, scratch         { input buffer pointer in DS:SI }
 { We have to adjust datalength for comparison with SI. TP 6.0 pointers
are
   normalized, but the offset can still be 0 or 8. }
add     bx, si
cld                         { clear DF for stosb }
cmp     cl, 0               { was last byte a count? }
jne     @multi_data         { yes, so next is data }
jmp     @getbyte            { no, so find out what next is }

{ -------------- Procedure to write EGA/VGA image to video
-------------- }

{ The data in the .PCX file is organized by color plane, by line; that
is,
  all the data for plane 0 for line 1, then for plane 1, line 1, etc.
  Writing the data to display memory is just a matter of masking out the
  other planes while one plane is being written to. This is done with
the
  map mask register in the sequencer. All the other weird and wonderful
  registers in the EGA/VGA do just fine with their default settings,
thank
  goodness. }

@writebyte:
stosb                       { AL into ES:DI, inc DI }
inc     dl                  { increment column }
cmp     dl, ah              { reached end of scanline? }
je      @doneline           { yes }
loop    @writebyte          { no, do another }
jmp     @getbyte            {   or get more data }
@doneline:
shl     bp, 1               { shift to next plane }
cmp     bp, 8               { done 4 planes? }
jle     @setindex           { no }
mov     bp, 1               { yes, reset plane to 1 but don't reset
index }
jmp     @setplane
@setindex:
sub     di, dx              { reset to start of line }
@setplane:
push    ax                  { save AX }
cli                         { no interrupts }
mov     ax, bp              { plane is 1, 2, 4, or 8 }
mov     dx, 3C5h            { sequencer data register }
out     dx, al              { mask out 3 planes }
sti                         { enable interrupts }
pop     ax                  { restore AX }
xor     dx, dx              { reset column count }
loop    @writebyte          { do it again, or fetch more data }

{ -------------------- Loop through input buffer
------------------------ }

{ Here's how the data compression system works. Each byte is either
image
  data or a count byte that tells how often the next byte is to be
  repeated. The byte is image data if it follows a count byte, or if
  either of the top 2 bits is clear. Otherwise it is a count byte, with
  the count derived from the lower 6 bits. }

@getbyte:                   { last byte was not a count }
cmp     si, bx              { end of input buffer? }
je      @exit               { yes, quit }
lodsb                       { get a byte from DS:SI into AL, increment
SI }
cmp     al, 192             { test high bits }
jb      @one_data           { not set, it's data to be written once }
 { It's a count byte: }
xor     al, 192             { get count from 6 low bits }
mov     cl, al              { store repeat count }
cmp     si, bx              { end of input buffer? }
je      @exit               { yes, quit }
@multi_data:
lodsb                       { get data byte }
jmp     @writebyte          { write it CL times }
@one_data:
mov     cl, 1               { write byte once }
jmp     @writebyte

{ ---------------------- Finished with buffer
--------------------------- }

@exit:
pop     ds                  { restore Turbo's data segment }
mov     plane, bp           { save status for next run thru buffer }
mov     repeatcount, cl
mov     columncount, dx
mov     video_index, di
pop     bp
end;  { asm }

{ ===================== CGA 2- and 4-color files
======================== }

procedure DECODE_CGA; assembler;

asm

(* Registers used:

   AL   data byte to be written to video
   AH   data bytes per scan line
   BX   end of input buffer
   CL   number of times data byte is to be written
   DL   pointer to current column in screen row
   ES   output segment; temporarily used for input buffer segment
   DI   index into output buffer
   SI   index into input buffer
   BP   current video bank
*)

push    bp
jmp     @startproc

{ ------------- Procedure to store CGA image in buffers
----------------- }

@storebyte:
stosb                       { AL into ES:DI, increment DI }
inc     dx                  { increment column count }
cmp     dl, ah              { reached end of line? }
je      @row_ends           { yes }
loop    @storebyte          { not end of row, do another byte }
ret
@row_ends:
xor     bp, 1               { switch banks }
cmp     bp, 1               { is bank 1? }
je      @bank1              { yes }
mov     word ptr abuff1, di { no, save index into bank 1 }
les     di, abuff0          { bank 0 pointer into ES:DI }
xor     dx, dx              { reset column counter }
loop    @storebyte
ret
@bank1:
mov     word ptr abuff0, di { save index into bank 0 }
les     di, abuff1          { bank 1 pointer into ES:DI }
xor     dx, dx              { reset column counter }
loop    @storebyte
ret

{ ---------------- Main assembler procedure for CGA
--------------------- }

{ It's assumed that CGA files will require only one pass through the
  input buffer. }

@startproc:
mov     bp, 0                        { bank in BP }
mov     es, word ptr abuff0[2]       { segment of bank 0 buffer }
mov     di, word ptr abuff0          { offset of buffer }
mov     ah, byte ptr bytes_per_line  { line length in AH }
mov     bx, datalength               { no. of bytes to read }
xor     cx, cx                       { clean up CX for loop counter }
xor     dx, dx                       { initialize column counter }
mov     si, dx                       { initialize input index }
cld                                  { clear DF for stosb }

{ -------------------- Loop through input buffer
------------------------ }

@getbyte:
cmp     si, bx              { end of input buffer? }
je      @exit               { yes, quit }
push    es                  { save output pointer }
push    di
les     di, scratch         { get input pointer in ES:DI }
add     di, si              { add current offset }
mov     al, [es:di]         { get a byte }
inc     si                  { advance input index }
pop     di                  { restore output pointer }
pop     es
cmp     cl, 0               { was previous byte a count? }
jg      @multi_data         { yes, this is data }
cmp     al, 192             { no, test high bits }
jb      @one_data           { not set, not a count }
 { It's a count byte: }
xor     al, 192             { get count from 6 low bits }
mov     cl, al              { store repeat count }
jmp     @getbyte            { go get data byte }
@one_data:
mov     cl, 1               { write byte once }
call    @storebyte
jmp     @getbyte
@multi_data:
call    @storebyte          { CL already set }
jmp     @getbyte

{ ---------------------- Finished with buffer
--------------------------- }

@exit:
pop     bp
end;  { asm }

{ ============= Main procedure for CGA and 16-color files
=============== }

procedure READ_PCX_FILE(gdriver: integer; pfilename: pathstr);

type    ptrrec = record
                   segm, offs: word;
                 end;

var     entry, gun, pcxcode, mask, colorID: byte;
        palbuf: array[0..66] of byte;
        pcxfile: file;

begin   { READ_PCX_FILE }
is_CGA:= (gdriver = CGA);   { 2 or 4 colors }
is_VGA:= (gdriver = VGA);   { 16 of 256K possible colors }
                            { Otherwise EGA - 16 of 64 possible colors }
assign(pcxfile, pfilename);
{$I-} reset(pcxfile, 1);  {$I+}
file_error:= (IOresult <> 0);
if file_error then exit;

{ To minimize disk access and speed things up, we read the file into a
  scratchpad on the heap. Large files have to be done in two or more
  chunks because of the 64K limit on dynamic memory variables. }

getmem(scratch, buffsize);                 { Allocate scratchpad }
blockread(pcxfile, scratch^, 128);         { Get header into scratchpad

Quote
}

{ The .PCX file has a 128-byte header. Most of it can be ignored if
you're
  working with a known format. All we want is the palette information
and
  the length of the data line. }

move(scratch^, palbuf, 67);
bytes_per_line:= palbuf[66];

{------------------------ Setup for CGA
---------------------------------}

if is_CGA then
begin
  getmem(buff0, 8000);      { Allocate memory for output }
  getmem(buff1, 8000);
  abuff0:= buff0;           { Make copies of pointers }
  abuff1:= buff1;          
end else

{----------------------- Setup for EGA/VGA
------------------------------}

begin
  video_index:= 0;
  port[$3C4]:= 2;           { Index to map mask register }
  plane:= 1;                { Initialize plane }
  port[$3C5]:= plane;       { Set sequencer to mask out other planes }

{-------------------- Decipher EGA/VGA palette
--------------------------}

(* The palette information is stored in bytes 16-63 of the header. Each
of
   the 16 palette slots is allotted 3 bytes - one for each primary
color.
   Any of these bytes can have a value of 0-255.

   For the EGA there are just 4 significant settings, since only 64
   different colors (4 x 4 x 4) are available. Hence for EGA-format
images
   we divide the codes by 64. The absolute color number for the palette
   entry is derived by setting one of bits 0-2 and one of bits 3-5 with
the
   mask corresponding to the .PCX code byte. (In binary form, the
absolute
   color number may be thought of as 00RGBrgb.) This number is then
passed
   into Turbo's SetAllPalette procedure.

   For the VGA things work differently. Here we must use Turbo's
   SetRGBPalette procedure to change the red, green, and blue values in
the
   16 active color registers. The registers expect values in the range
0-63
   (64 x 64 x 64 = 256K, the number of possible colors), so we divide
the
   .PCX codes by 4. A further complication is that by default the
palette
   entries point to the color registers corresponding to the standard
EGA
   colors, so we must change them to point to registers 0-15 instead (or
   else modify registers 0-5, 20, 7, and 56-63). See SHOWVGA.PAS for an
   example of how to set the palette and the registers.

   Note that the palette works differently for the 200-line 16-color
modes,
   $0D and $0E. Because these modes use 4-bit palette entries, only the
   default colors are available on the EGA, and their IDs don't
correspond
   to those in 350-line mode (e.g. 20 is bright red, not brown).
Attempting
   to set the palette with the data from the .PCX header will lead to
odd
   results in these modes, and in any case should not be necessary.
*)

  for entry:= 0 to 15 do
  begin
    colorID:= 0;
    for gun:= 0 to 2 do
    begin
      pcxcode:= palbuf[16 + entry * 3 + gun];   { Get primary color
value }
      if not is_VGA then
      begin                                     { Interpret for EGA }
        case (pcxcode div $40) of
          0: mask:= $00;    { 000000 }
          1: mask:= $20;    { 100000 }
          2: mask:= $04;    { 000100 }
          3: mask:= $24;    { 100100 }
        end;
        colorID:= colorID or (mask shr gun);    { Define two bits }
      end  { not is_VGA }
      else
      begin  { is_VGA }
        with RGBpal[entry] do                   { Interpret for VGA }
        case gun of
          0: redval:= pcxcode div 4;
          1: greenval:= pcxcode div 4;
          2: blueval:= pcxcode div 4;
        end;
      end;  { is_VGA }
    end;  { gun }
    if is_VGA then pal.colors[entry]:= entry
              else pal.colors[entry]:= colorID;
  end;  { entry }
  pal.size:= 16;
end;   { not is_CGA }

{ ---------------- Read and decode the image data
----------------------- }

repeatcount:= 0;                        { Initialize assembler vars. }
columncount:= 0;
repeat
  blockread(pcxfile, scratch^, buffsize, datalength);
  if is_CGA then decode_CGA else decode_16;   { Call assembler routine }
until eof(pcxfile);
close(pcxfile);
if not is_CGA then port[$3C5]:= $F;     { Reset mask map }
freemem(scratch,buffsize);              { Discard scratchpad }
end;  { READ_PCX_FILE }

{ ========================= 256-color files
============================= }

procedure DECODE_PCX256; assembler;

(* Registers used:

   AL   data byte to be written to video
   BX   end of input buffer
   CL   number of times data byte is to be written
   ES   output segment
   DI   index into output buffer
   DS   segment of input buffer
   SI   index into input buffer
*)

asm
mov     es, page_addr       { video segment }
mov     di, video_index     { index into video }
xor     cx, cx              { clean up loop counter }
mov     cl, repeatcount     { count in CL }
mov     bx, datalength      { end of input buffer }
push    ds                  { save DS }
lds     si, scratch         { pointer to input in DS:SI }
add     bx, si              { adjust datalength - SI may not be 0 }
cld                         { clear DF }
cmp     cl, 0               { was last byte a count? }
jne     @multi_data         { yes, so next is data }

{ --------------------- Loop through input buffer
----------------------- }

@getbyte:                   { last byte was not a count }
cmp     si, bx              { end of input buffer? }
je      @exit               { yes, quit }
lodsb                       { get byte into AL, increment SI }
cmp     al, 192             { test high bits }
jb      @one_data           { not set, not a count }
{ It's a count byte }
xor     al, 192             { get count from 6 low bits }
mov     cl, al              { store repeat count }
cmp     si, bx              { end of input buffer? }
je      @exit               { yes, quit }
@multi_data:
lodsb                       { get byte into AL, increment SI }
rep     stosb               { write byte CX times }
jmp     @getbyte
@one_data:
stosb                       { byte into video }
jmp     @getbyte

{ ------------------------- Finished with buffer
------------------------ }

@exit:
pop     ds                  { restore Turbo's data segment }
mov     video_index, di     { save status for next run thru buffer }
mov     repeatcount, cl
end;  { asm }

{ ================= Main procedure for 256-color files
================== }

procedure READ_PCX256(pfilename: pathstr);

var     x, gun, pcxcode: byte;
        pcxfile: file;
        palette_start, total_read: longint;
        palette_flag: byte;
        version: word;

procedure CLEANUP;

begin
close(pcxfile);
freemem(scratch, buffsize);
end;

begin    { READ_PCX256 }
assign(pcxfile, pfilename);
{$I-} reset(pcxfile, 1);  {$I+}
file_error:= (IOresult <> 0);
if file_error then exit;
getmem(scratch, buffsize);                  { Allocate scratchpad }
blockread(pcxfile, version, 2);             { Read first two bytes }
file_error:= (hi(version) < 5);             { No palette info. }
if file_error then
begin
  cleanup; exit;
end;
palette_start:= filesize(pcxfile) - 769;

seek(pcxfile, 128);                        { S{*word*99} file header }
total_read:= 128;

repeatcount:= 0;                           { Initialize assembler vars.

Quote
}

video_index:= 0;

repeat
  blockread(pcxfile, scratch^, buffsize, datalength);
  inc(total_read, datalength);
  if (total_read > palette_start) then
      dec(datalength, total_read - palette_start);
  decode_pcx256;
until (eof(pcxfile)) or (total_read>= palette_start);

(* The last 769 btes of the file are palette information, starting with
a
   one-byte flag. Each group of three bytes represents the RGB values of
   one of the color registers. The values have to be divided by 4 to be
   brought within the range 0-63 expected by the registers. *)

seek(pcxfile, palette_start);
blockread(pcxfile, palette_flag, 1);
file_error:= (palette_flag <> 12);
if file_error then
begin
  cleanup; exit;
end;
blockread(pcxfile, RGB256, 768);         { Get palette info. }
for x:= 0 to 255 do
with RGB256[x] do
begin
  redval:= redval shr 2;
  greenval:= greenval shr 2;
  blueval:= blueval shr 2;
end;
cleanup;
end;  { READ_PCX256 }

{ ========================== Initialization
============================= }

BEGIN
page_addr:= page0;                      { Destination for EGA/VGA data }
END.

----------------- END OF PCXVIEWER
----------------------------------------

So, thats it folks! I'll hope you like the source.
Note: the Savegif and SaveBMP don't work very well. I'm looking for some
sources for writing GIF and others to disk. If you have something like
that, i'll be glad to have it.

GreetZ, Nico.