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

    program Bitmapld;
    Uses
      DOS,
      CRT;

    {FUNCTION:
      Loads and displays a mono .BMP bitmap file in
      Colour EGA/VGA text mode.
    }

    const
      CHAR_WIDTH = 8; {Width of chars in usable pixels}

    {*********** `Spare' characters overwitten by bitmap}
    {Edit this to suit your requirements}
      GRABCHRS_STR : String =
      #0#1#2#3#4#5#6#7#8#9#10#11#12#13#14#15 +
      #16#17#18#19#20#21#22#23#24#25#26#27#28#29#30#31 +
      '!"#$%&'#39'()*+,-./' +
      '0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVW' +
      'XYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~' +
      '€������������������������™�������¡¢£¤¥¦§' +
      '¨©ª«�®¯°±²³´µ�·¸¹º»¼½¾¿' +
      'àáâãäåæçèéêëìíîïðñòóôõö÷' +
      'øùúûüýþÿ';

    type
    {*********** .BMP file data structures}
      TBitMapFileHeader = record
        bfType           : Word;
        bfSize           : LongInt;
        bfReserved1      : Word;
        bfReserved2      : Word;
        bfOffbits        : LongInt;
      end; {TBitMapFileHeader}

      TRgbQuad          = record
        rgbBlue	     : Byte;
        rgbGreen	     : Byte;
        rgbRed	     : Byte;
        rgbReserved	     : Byte;
      end; {TRgbQuad}

      TBitMapInfoHeader = record
        biSize           : LongInt;
        biWidth	     : LongInt;
        biHeight	     : LongInt;
        biPlanes	     : Word;
        biBitCount	     : Word;

        biCompression    : LongInt;
        biSizeImage	     : LongInt;
        biXPelsPerMeter  : LongInt;
        biYPelsPerMeter  : LongInt;
        biClrUsed	     : LongInt;
        biClrImportant   : LongInt;
      end; {TBitMapInfoHeader}

      TBitMapInfo       = record
        bmHeader         : TBitMapInfoHeader;
        bmiColors        : array [0..0] of TRgbQuad;
      end; {TBitMapInfo}

      TBitMapContents  = record
        case Boolean of
        True:   (bmcHeader  : TBitMapFileHeader;
                 bmcInfo    : TBitMapInfo);
        False:  (bmcByte    : array[0..100] of Byte);
       end; {TBitMapContents}

      PBitMapContents = ^TBitMapContents;

    {*********** Character Map Structures}
      TCharMap = array[0..31] of Byte;
      TCharMapArray = array[0..255] of TCharMap;

    {*********** Global variables}
    var
      { Addresses assume colour EGA/VGA }
      CRT_COLS        : Word absolute $0040:$004A;
      CRT_ROWS_MINUS_1: Byte absolute $0040:$0084;
      POINTS          : Word absolute $0040:$0085;

      CharMapArray    : TCharMapArray
                             absolute $A000:$0000;
      ScreenBuffer    : array[0..$fff] of Byte
                             absolute $B800:0000;
      TempVideoBuffer : array[0..$fff] of Byte;

      {Shorthand for GRABCHRS' length byte}
      NOGRABCHRS : byte absolute GRABCHRS_STR;
      {Easy access to GRABCHRS}
      GRABCHRS : array[-1..255] of Byte
                                absolute GRABCHRS_STR;
      {Stores default Exit procedure pointer}
      ExitSave : Pointer;

    {*********** Code begins}

    function LoadBitMapFile(fname : String;
                            var FSize : LongInt)
                                      : Pointer;
    var
      buffer : Pointer;
      Infile : File;
    begin
      Assign(Infile, fname);
    {$I-}
      Reset(Infile,1);
      if IOresult <> 0 then
      begin
        Writeln('Error opening file ',fname);
        Exit;
      end;
    {$I+}
      FSize := FileSize(Infile);
      GetMem(buffer,Fsize);
      Reset(Infile,Fsize);
      if buffer <> nil then
        BlockRead(Infile,buffer^,1)
      else
        WriteLn('Error: File too big to load');
      Close(Infile);
      LoadBitMapFile := Buffer;
    end; {LoadBitMapFile}

    procedure ProcessBitMap(Buffer : PBitMapContents;
                                     row, col : Byte);
    { Displays the bitmap Buffer, with top left
      corner at position (row, col)             }

    type
      TByteBuffer = array[0..32767] of Byte;
      TSeqAndGCparms = array [0..3] of Word;

    const
      SeqparmsSet : TSeqAndGCparms =
        ($100, $402, $704, $300);
      GCParmsSet  : TSeqAndGCparms =
        ($204, $005, $006, 0);
      SeqparmsClr : TSeqAndGCparms =
        ($100, $302, $304, $300);
      GCParmsClr  : TSeqAndGCparms =
        ($004, $1005, $0E06, 0);

    var
      BMData : ^TByteBuffer;
      BMBytesPerRow,
      CurX, CurY,
      WidthInChars, HeightInChars,
      CharsUsedUp : Integer;
      CharMap : TCharMap;
      lastrow, endrow, endmask : Byte;

      procedure SetUp;
      var
        PixelWidth : Word;
        CRT_ROWS   : Byte;
      begin
        {Get start address of bitmap data}
        with Buffer^ do
          BMData := @bmcByte[bmcHeader.bfOffBits];

        with Buffer^.bmcInfo.bmHeader do
        begin
          BMBytesPerRow := 4 * ((biWidth + 31) div 32);
          {Get Clipped Width}
          if biWidth > (CHAR_WIDTH * CRT_COLS) then
            biWidth := (CHAR_WIDTH * CRT_COLS);
          WidthInChars := (biWidth + CHAR_WIDTH - 1)
                                      div CHAR_WIDTH;
          if biWidth = (WidthInChars * CHAR_WIDTH) then
            endmask := $FF
          else
            endmask := Byte($FF shl (CHAR_WIDTH -
                              biWidth mod CHAR_WIDTH));
          CRT_ROWS := Succ(CRT_ROWS_MINUS_1);
          {Get Clipped Height}
          if biHeight > (POINTS * CRT_ROWS) then
            biHeight := (POINTS * CRT_ROWS);
          HeightInChars := (biHeight + Pred(POINTS))
                                            div POINTS;
          endrow := POINTS - Pred(biHeight) mod POINTS;
        end; {with}
      end; {SetUp}

    procedure cGenMode(var Seqparms, GCparms:
                                       TSeqAndGCparms);
    var i : Integer;
    begin
      asm cli end; {Disable interrupts}
      for i := 0 to 3 do
        PortW[$03c4] := Seqparms[i];
      asm sti end;
      for i := 0 to 2 do
        PortW[$03ce] := GCparms[i];
    end;

      procedure MapToChar;
      var
        i, offset : Integer;
        mask : Byte;
      begin
        if CurX = WidthInChars - 1 then
          mask := endmask
        else
          mask := $FF;
        offset := Succ(CurY) * POINTS * BMBytesPerRow
                                                 + CurX;
        CharMap[POINTS] := 0; {Zero checksum}
        for i := 0 to POINTS - 1 do
        begin
          if i >= lastrow  then
            CharMap[i] := BMData^[offset] and mask
          else
            CharMap[i] := 0;
          Inc(CharMap[POINTS], CharMap[i]);
          Dec(offset,BMBytesPerRow);
        end;
      end; {MapToChar}

      procedure PlotChar(character : Byte);
      begin
        TempVideoBuffer[((HeightInChars - CurY + row - 1)
                        * CRT_COLS + CurX + col) * 2]
                                            := character;
      end; {PlotChar}

      function FoundInStore : Boolean;

        function Comp(var Buf1, Buf2 : TCharMap;
                          POINTS     : Word)
                                  : Boolean; assembler;
        asm
          push	ds
    { Move default return to ax - 'True'}
          mov       ax, 1
          lds	si, Buf1
          add       si, [POINTS]
          les	di, Buf2
          add       di, [POINTS]
          mov	cx, [POINTS]
          inc       cx
    { Search backwards to find checksum 1st}
          std
          rep	cmpsb
          je	@@Exit
    { Flag failed match in return }
          xor	ax, ax
    @@Exit:
          pop	ds
    end;

      var
        i : Integer;
      begin
        FoundInStore := True;
        for i := 0 to Pred(CharsUsedUp) do
          if Comp(CharMapArray[GRABCHRS[i]],
                   CharMap,POINTS)            then
          begin
            PlotChar(GRABCHRS[i]);
            Exit;
          end;
        FoundInStore := False;
      end;

    begin  { ProcessBitMap }
      Setup;
      Move(ScreenBuffer, TempVideoBuffer,
                         Sizeof(TempVideoBuffer));
      cGenMode(SeqparmsSet, GCParmsSet);
      CharsUsedUp := 0; lastrow := 0;
      CurX := 0; CurY := 0;
      repeat
        MapToChar;
        if not FoundInStore then
        begin
          Move(CharMap,
               CharMapArray[GRABCHRS[CharsUsedUp]],
               Succ(Points));
          PlotChar(GRABCHRS[CharsUsedUp]);
          Inc(CharsUsedUp);
        end;
        CurX := (CurX + 1) mod WidthInChars;
        if (CurX = 0) then
        begin
          Inc(CurY);
          if CurY = HeightInChars - 1 then
            lastrow := endrow
        end;
      until (CharsUsedUp = NOGRABCHRS) or
            (CurY = HeightInChars);
      cGenMode(SeqparmsClr, GCParmsClr);
      Move(TempVideoBuffer, ScreenBuffer,
           Sizeof(TempVideoBuffer));

    end; {ProcessBitMap}

    procedure DisplayBitMap;
    var
      BitMapBuffer : PBitMapContents;
      FileSize : LongInt;
    begin
      if ParamStr(1) = '' then
      begin
        WriteLn('USAGE: BITMAPLD <file.bmp>');
        Exit;
      end;
      BitMapBuffer :=
                LoadBitMapFile(ParamStr(1),FileSize);
      if BitMapBuffer<> nil then
      begin
        ProcessBitMap(BitMapBuffer,0,0);
        FreeMem(BitMapBuffer, FileSize);
      end;
    end; {DisplayBitMap}

    procedure ResetFont; far;
    {This is called as an exit procedure, so the screen
     is always restored, even if something goes wrong...
     not that it will...   }
    var
      regs : Registers;
    begin
      ExitProc := ExitSave; {Restore default exit proc}
      regs.ah := $11;
      case POINTS of {Select correct ROM font}
        16: {Load 8 x 16 font}
          regs.al := 4;
        8:  {Load 8 x 8 font}
          regs.al := 2;
        else {Choose 8 x 14 - it's the safest}
          regs.al := 1;
      end; {case}
      regs.bl := 0;
      intr($10,regs);
    end; {ResetFont}

    {*********** Main program }

    begin
      ExitSave := ExitProc; ExitProc := @ResetFont;
      ClrScr;
      DisplayBitMap;
      ReadKey;
    end.

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