[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]