Stars of Shareware: Programmierung/SOURCE.mdf/programm/msdos/pascal/rehack/demosrc/pcxtool.pas

Pascal/Delphi Source File | 1991-04-12 | 16.0 KB | 462 lines

{**************************************************************************
 **************************************************************************
                            PCXTOOL UNIT
 **************************************************************************
  By: Mark Betz, 76605, 2346
 Developed on: 1-4-91
 Last update:  4-8-91
 **************************************************************************
 **************************************************************************}

Unit PCXTOOL;

interface

Uses
    DOS, CRT;
const
    size_of_pcx : word = 64500;          {size of the unpacked PCX}

type
    palette_rec   = record               {palette entry storage structure}
                         red : byte;
                         green : byte;
                         blue : byte;
                    end;

    Header_struc = record                              {PCX header structure}
                     mfg : byte;                       {manufacturer}
                     ver : byte;                       {version}
                     enc : byte;                       {encoding}
                     bpp : byte;                       {bits per pixel}
                     xmin, ymin : integer;             {picture origin}
                     xmax, ymax : integer;             {picture dimensions}
                     hres : integer;                   {horizontal resolution}
                     vres : integer;                   {vertical resolution}
                     palette : array[0..47] of byte;   {palette area for 16 clr}
                     res : byte;                       {reserved}
                     clr_plns : byte;                  {color planes}
                     bpl : integer;                    {bytes per line}
                     pal_type : integer;               {palette type}
                     filler : array[0..57] of byte;    {filler}
                   end;

var
    current_pal : array[0..255] of palette_rec;
    saved_pal   : array[0..255] of palette_rec;
    test_pal    : array[0..255] of palette_rec;
    Cpal_ptr    : pointer;
    Spal_ptr    : pointer;
    PCXHead     : Header_struc;               {PCX header structure}
    PicFile     : file;                       {current picture file}
    read_ahed   : array[0..9999] of byte;
    ra_buf_pos  : integer;

{----------------------------------Interface Procedure definitions------------}

Procedure InitGraphics;                       {set up mode 19}
Procedure Restoretext;                        {restore to text mode}
Function  LoadPcx(pcxfile : pathstr):pointer; {load a PCX file into buffer}
Procedure FadeInPcx(buf_ptr : pointer);       {fade in a pcx file}
Procedure FadeOutPcx;                         {remove from screen}
Procedure FreePcxMem(buf_ptr : pointer);      {deallocate memory}

implementation
var
    file_size : longint;       {holds the size of the pcx}

{*****************************************************************************
    Procedure InitGraphics-
    task: set graphics card to VGA mode 19, 320 x 200 x 256
 *****************************************************************************}

Procedure InitGraphics;
var
    regs : registers;
begin
    regs.ax := $0013;          {load ah = 00, al = video mode $13}
    Intr($10,regs);            {call BIOS to set video mode}
end;

{*****************************************************************************
    Procedure RestoreText-
    task: restore graphics card to mode 3, 80 x 25 16 color text
 *****************************************************************************}

Procedure RestoreText;
var
    regs : registers;
begin
    regs.ax := $0003;          {load ah = 00, al = video mode $3}
    Intr($10,regs);
end;

{*****************************************************************************
    Function Check_exist-
    task: called with a path and filename it will return true and set the
          value of file_size if the requested filename exists. Returns false
          if file not found
 *****************************************************************************}

Function Check_exist(check_file : pathstr) : boolean;
var
    file_attrib : word;
    file_rec    : searchrec;
begin
    file_attrib := $3F;
    findfirst(check_file,file_attrib,file_rec);
    case doserror of
        0  : begin
                 Check_exist := true;
                 file_size := file_rec.size;
             end;
        else
             Check_exist := false;
    end;
end;

{*****************************************************************************
    Procedure ShiftPalette;
    task: shifts the contents of the passed palette structure right by 2 bits
 *****************************************************************************}

Procedure ShiftPalette(SPal : pointer);
var
    cntr        : integer;
begin
    cntr := 0;
    while cntr<768 do begin
        mem[seg(Spal^):ofs(Spal^)+cntr] := mem[seg(Spal^):ofs(Spal^)+cntr] SHR 2;
        inc(cntr,1);
    end;
end;

{*****************************************************************************
    Procedure LoadPalette-
    task: loads the passed palette into the VGA Dac registers
 *****************************************************************************}

Procedure LoadPalette(LPal : pointer);
var
    regs : registers;
begin
    regs.ax := $1012;                      {interrupt 10h, function 12h}
    regs.bx := $0;                         {start with first palette reg}
    regs.cx := $100;                       {load all 256 registers}
    regs.es := seg(LPal^);
    regs.dx := ofs(LPal^);
    intr($10,regs);
end;

{*****************************************************************************
    Procedure ReadPalette-
    task: reads the VGA DAC registers into the test_pal palette structure
 *****************************************************************************}

Procedure ReadPalette;
var
    regs : registers;
    cntr : byte;

begin
    regs.ax := $1017;
    regs.bx := $0;
    regs.cx := $100;
    regs.es := seg(test_pal);
    regs.dx := ofs(test_pal);
    intr($10,regs);
end;

{*****************************************************************************
    Procedure ClearPalette-
    task: clear all rgb values in the passed palette to 0
 *****************************************************************************}

Procedure ClearPalette(Palette : pointer);
var
    cntr        : integer;
    segmnt      : word;
    offs        : word;
begin
    cntr := 0;
    segmnt := seg(palette^);
    offs   := ofs(palette^);
    while cntr<768 do begin
        mem[segmnt:offs+cntr] := 0;
        inc(cntr,1);
    end;
end;

{*****************************************************************************
    Procedure SelectRefresh-
    task: enable disable screen refresh. on = 1, off = 0.
 *****************************************************************************}

Procedure SelectRefresh(on_off : byte);
var
    regs : registers;
begin
    regs.ah := $12;
    regs.bl := $32;
    regs.al := on_off;
    intr($10,regs);
end;

{*****************************************************************************
    Procedure InitReadAheadBuffer-
    task: load the first 10000 bytes of PicFile into the read-ahead buffer,
          and initialize the position counter to 0
 *****************************************************************************}

Procedure InitReadAheadBuffer;
begin
    blockread(PicFile,read_ahed,10000);
    ra_buf_pos := 0;
end;

{*****************************************************************************
    Function GetNextByte-
    task: manage the read-ahead buffer and return the next physical byte to
          the unpacking routine in LoadPcx.
 *****************************************************************************}

Function GetNextByte : byte;
begin
    if ra_buf_pos <= SizeOf(read_ahed) then begin
        GetNextByte := read_ahed[ra_buf_pos];
        inc(ra_buf_pos,1);
    end else begin
        if (File_size - FilePos(PicFile)) > 10000 then begin
            blockread(PicFile,read_ahed,10000);
        end else begin
            blockread(PicFile,read_ahed,(File_size-FilePos(PicFile)));
        end;
        ra_buf_pos := 0;
        GetNextByte := read_ahed[ra_buf_pos];
        inc(ra_buf_pos,1);
    end;
end;

{*****************************************************************************
    Function LoadPcx -
    task: called with a path and filename it attempts to decode the pcx file
          into a heap variable, and returns a pointer to the buffer if succ-
          essful. No error recovery is implemented. If the load fails the
          program halts.
 *****************************************************************************}

{$I-}
Function LoadPcx;

var
    width       : word;          {pic dimension width in bytes}
    depth       : word;          {depth in lines}
    bytes       : word;          {bytes per line}
    pal_check   : byte;          {palette tag check var}
    num_read    : word;          {number of palette entries read}
    ln_cntr     : word;          {line counter for unpacking}
    file_val    : byte;          {used in line unpack block}
    run_length  : byte;          {length of compressed string}
    byte_cntr   : word;          {counts bytes in line processed}
    p           : pointer;       {temp pointer for mem allocation}

begin
    if check_exist(PcxFile) = true then begin      {check that file exists}
        assign(PicFile,PcxFile);                   {assign it}
        reset(PicFile,1);                          {open it}
        if IOResult <> 0 then begin                {check for I/O error}
            writeln('IO error ',IOResult);
            halt(0);
        end;
    end else begin
        writeln('file not found ', PcxFile);
        halt(0);
    end;
    GetMem(p, size_of_pcx);                        {allocate buffer}
    LoadPcx := p;                                  {return the pointer}
    seek(PicFile,file_size-769);                   {seek start of palette}
    BlockRead(PicFile,pal_check,1);                {check for palette tag}
    if pal_check <> $0C then begin
        writeln('error seeking to palette');       {error if tag not $0C}
        halt(0);
    end;
    BlockRead(PicFile,Current_pal,SizeOf(Current_pal),num_read);  {get palette}
    if num_read <> SizeOf(Current_Pal) then begin                 {check size}
        writeln('error in palette size. size = ',num_read);
        halt(0);
    end;
    move(Current_pal,saved_pal,SizeOf(Current_pal));      {copy to saved palette}
    Cpal_ptr := ptr(seg(current_pal),ofs(current_pal));   {setup palette ptrs}
    Spal_ptr := ptr(seg(saved_pal),ofs(saved_pal));
    Seek(PicFile,0);                                          {start of file}
    BlockRead(PicFile,PCXHead,Sizeof(PCXHead));               {read header}
    if (PCXhead.mfg <> $0A) or (PCXHead.ver <> 5) then begin  {check mfg and ver}
        writeln('not a 256 color PCX file');
        halt(0);
    end;
    depth := 200;                          {set dimensions in bytes}
    width := 320;
    bytes := 320;                          {bytes = bytes per line}
    ln_cntr := 0;
    InitReadAheadBuffer;
    while ln_cntr<=depth do begin
        byte_cntr := 0;                                {set byte counter to 0}
        while byte_cntr<bytes do begin
            File_val := GetNextByte;                   {get the first byte}
            if (File_Val AND $C0) = $C0 then begin     {are high bits set?}
                run_length := (File_Val AND $3F);      {and off the high bits}
                File_val := GetNextByte;               {get the run byte}
                while run_length <> 0 do begin         {run the byte}

                    mem[seg(p^):(ln_cntr*320)+byte_cntr] := File_val;
                    inc(byte_cntr,1);
                    dec(run_length,1);
                end;
            end else begin                             {simply store}

                mem[seg(p^):(ln_cntr*320)+byte_cntr] := File_Val;
                inc(byte_cntr,1);
            end;
        end;
        inc(ln_cntr,1);
    end;
    close(PicFile);
end;

{$I+}

{*****************************************************************************
    Procedure FadeInPcx-
    task: sets all VGA dac palette entries to 0, loads the decoded PCX into
          video memory, and then cycles through the palette, increasing the
          value of each entry until it matches the picture defaults. Current_
          pal holds the display palette, while Saved_pal holds the picture
          default palette.
 *****************************************************************************}

Procedure FadeInPcx;
const
    total_slots : integer = 256;           {total number of palette entries}
    fade_percent : byte = 15;              {brightness gradiant in percent}
var
    resolved : integer;                    {number of palette entries resolved}
    cntr : integer;                        {points to entry being manipulated}

begin
    ClearPalette(Cpal_ptr);                {zero the display palette}
    LoadPalette(CPal_ptr);                 {load it}
    ShiftPalette(Spal_ptr);                {shift the saved palette}
    ReadPalette;                           {TESTING LINE - REMOVE}
    resolved := 0;
    cntr := 0;

    {move the pcx data into memory}
    move(buf_ptr^,ptr($a000,0)^,size_of_pcx);
    {while some bytes unresolved}
    while resolved < total_slots do begin

        {each pass through this loop processes one DAC triplet of 3 bytes}
        {while cntr less than total number of palette bytes}
        while cntr <= total_slots do begin
            {with display palette structure}
            with Current_pal[cntr] do begin
                {if this red byte unresolved (<> default value)}
                if red <> saved_pal[cntr].red then begin
                   {add to it a percentage of the saved red value}
                   red := round(red+((fade_percent/100)*Saved_pal[cntr].red));
                   {if it now equals or is greater than the saved red value}
                   if red >= saved_pal[cntr].red then begin
                       {set it to the saved red value}
                       red := saved_pal[cntr].red;
                       {one more byte resolved (=default value)}
                       inc(resolved,1);
                   end;
                end;

                {process blue and green as in red, above}
                if blue <> saved_pal[cntr].blue then begin
                   blue := round(blue+((fade_percent/100)*saved_pal[cntr].blue));
                   if blue >= saved_pal[cntr].blue then begin
                       blue := saved_pal[cntr].blue;
                       inc(resolved,1);
                   end;
                end;
                if green <> saved_pal[cntr].green then begin
                   green := round(green+((fade_percent/100)*saved_pal[cntr].green));
                   if green >= saved_pal[cntr].green then begin
                       green := saved_pal[cntr].green;
                       inc(resolved,1);
                   end;
                end;
            end;
            inc(cntr,1);
        end;
        LoadPalette(CPal_ptr);          {load the display palette}
        cntr := 0;
    end;
end;

{*****************************************************************************
    Procedure FadeOutPcx-
    task: cycles through the DAC palette reducing all values by fade_percent
          until the entire palette is zeroed. Does not affect video memory
    note: functionally equivalent to above procedure

 ***************************************************************************}

Procedure FadeOutPcx;
const
    total_slots : integer = 256;           {total number of palette entries}
    fade_percent : byte = 15;              {brightness gradiant in percent}
var
    regs : registers;
    resolved : integer;                    {number of palette entries resolved}
    cntr : integer;                  {points to entry being manipulated}
begin
    resolved := 0;
    cntr := 0;
    while resolved < total_slots do begin
        while cntr <= total_slots do begin
            with Current_pal[cntr] do begin
                if red <> 0 then begin
                   red := round(red-((fade_percent/100)*saved_pal[cntr].red));
                   if red <= 0 then begin
                       red := 0;
                       inc(resolved,1);
                   end;
                end;
                if blue <> 0 then begin
                   blue := round(blue-((fade_percent/100)*saved_pal[cntr].blue));
                   if blue <= 0 then begin
                       blue := 0;
                       inc(resolved,1);
                   end;
                end;
                if green <> 0 then begin
                   green := round(green-((fade_percent/100)*saved_pal[cntr].green));
                   if green <= 0 then begin
                       green := 0;
                       inc(resolved,1);
                   end;
                end;
            end;
            inc(cntr,1);
        end;
        LoadPalette(Cpal_ptr);
        cntr := 0;
    end;
end;

{*****************************************************************************
    Procedure FreePcxMem-
    task: deallocates the memeory assigned to the passed pointer. No checking
          is performed so a valid pointer must be passed. Zeros both palette
          structures.
 *****************************************************************************}

Procedure FreePcxMem;
begin
    FreeMem(buf_ptr,SizeOf(buf_ptr^));
end;

end.