Uncompressed 8 bit bitmap reader->
Hi,
Feeling like playing with Quick Basic I extended and improved a bitmap reader I wrote a long time ago:
Code:
''256 Color Bitmap Reader add-on, by: Peter Swinkels.
DEFINT A-Z
DECLARE FUNCTION OpenBinary (FileName$)
DECLARE SUB DisplayBitmap (FileH, XOffset, YOffset, SCREENWIDTH, SCREENHEIGHT, ImageWidth AS LONG, ImageHeight AS LONG)
DECLARE SUB Main ()
DECLARE SUB SetPalette (FileH)
CALL Main
SUB DisplayBitmap (FileH, XOffset, YOffset, SCREENWIDTH, SCREENHEIGHT, ImageWidth AS LONG, ImageHeight AS LONG)
CONST BITMAP = 1078
CONST DIMENSIONS = 19
DIM Canvas(16000) AS LONG
DIM Position AS LONG
DIM Row$, x, y
STATIC Padding
IF ImageWidth = 0 AND ImageHeight = 0 THEN
SEEK FileH, DIMENSIONS
ImageWidth = CVL(INPUT$(4, FileH))
ImageHeight = CVL(INPUT$(4, FileH))
IF SCREENHEIGHT > ImageHeight THEN SCREENHEIGHT = ImageHeight
Padding = ((LOF(FileH) - BITMAP) / ImageHeight) - ImageWidth
END IF
Position = (LOF(FileH) - ((ImageWidth + Padding) * (YOffset + SCREENHEIGHT)))
IF Position > BITMAP THEN SEEK FileH, Position ELSE SEEK FileH, BITMAP
Canvas(0) = &HC80A00
FOR y = SCREENHEIGHT - 1 TO 0 STEP -1
IF Position > 0 AND LOC(FileH) < LOF(FileH) THEN
Row$ = INPUT$(ImageWidth + Padding, FileH)
FOR x = 0 TO SCREENWIDTH - 1 STEP 4
IF x + XOffset < ImageWidth AND y + YOffset < ImageHeight THEN
Canvas((((SCREENWIDTH / 4) * y) + (x / 4)) + 1) = CVL(MID$(Row$, x + XOffset + 1, 4))
END IF
NEXT x
END IF
Position = Position + (ImageWidth + Padding)
NEXT y
PUT (0, 0), Canvas
END SUB
SUB Main
CONST SCREENHEIGHT = 200
CONST SCREENWIDTH = 320
DIM ImageHeight AS LONG
DIM ImageWidth AS LONG
DIM FileH, FileName$, Key$, x, y
SCREEN 0: WIDTH 40: WIDTH 80, 25: COLOR 7, 0: CLS
COLOR 0, 7: PRINT " BITMAP FILES: " + SPACE$(65)
COLOR 7, 0: FILES "*.bmp"
PRINT STRING$(80, "=")
LINE INPUT "SPECIFY BITMAP: ", FileName$
IF LTRIM$(RTRIM$(FileName$)) = "" THEN EXIT SUB
SCREEN 13
FileH = OpenBinary(FileName$)
SetPalette FileH
x = 0
y = 0
DO
CLS
DisplayBitmap FileH, x, y, SCREENWIDTH, SCREENHEIGHT, ImageWidth, ImageHeight
DO
Key$ = INKEY$
LOOP WHILE Key$ = ""
SELECT CASE Key$
CASE CHR$(0) + "H"
y = y - (SCREENHEIGHT / 4)
CASE CHR$(0) + "P"
y = y + (SCREENHEIGHT / 4)
CASE CHR$(0) + "K"
x = x - (SCREENWIDTH / 4)
CASE CHR$(0) + "M"
x = x + (SCREENHEIGHT / 4)
CASE "1"
x = x - SCREENWIDTH
y = y + SCREENHEIGHT
CASE "2"
y = y + SCREENHEIGHT
CASE "3"
x = x + SCREENWIDTH
y = y + SCREENHEIGHT
CASE "4"
x = x - SCREENWIDTH
CASE "6"
x = x + SCREENWIDTH
CASE "7"
x = x - SCREENWIDTH
y = y - SCREENHEIGHT
CASE "8"
y = y - SCREENHEIGHT
CASE "9"
x = x + SCREENWIDTH
y = y - SCREENHEIGHT
CASE "i", "I"
PALETTE: CLS
PRINT USING "X: ####"; x
PRINT USING "Y: ####"; y
PRINT USING "Width: ####"; ImageWidth
PRINT USING "Height: #### "; ImageHeight
DO: LOOP WHILE INKEY$ = ""
SetPalette FileH
CASE CHR$(27)
EXIT DO
END SELECT
IF x < 0 THEN x = 0
IF y < 0 THEN y = 0
LOOP
CLOSE FileH
END SUB
FUNCTION OpenBinary (FileName$)
DIM FileH
FileH = FREEFILE
OPEN FileName$ FOR INPUT AS FileH: CLOSE FileH
OPEN FileName$ FOR BINARY AS FileH
OpenBinary = FileH
END FUNCTION
SUB SetPalette (FileH)
CONST COLORS = 55
DIM Blue AS LONG
DIM Green AS LONG
DIM Red AS LONG
DIM ColorIndex, Null$
SEEK FileH, COLORS
FOR ColorIndex = 0 TO 255
Blue = (ASC(INPUT$(1, FileH)) \ &H4) * &H10000
Green = (ASC(INPUT$(1, FileH)) \ &H4) * &H100
Red = ASC(INPUT$(1, FileH)) \ &H4
PALETTE ColorIndex, Red OR Green OR Blue
Null$ = INPUT$(1, FileH)
NEXT ColorIndex
END SUB
The program is meant to run in low resolution VGA (screen mode 13) and supports scrolling through the use of the arrow keys/numeric keypad. A few optimizations I made are:
1. Reading an entire row of pixels at a time instead of one at a time. Apparently calling the INPUT$ function once to read several bytes is faster than individual calls. On the downside you have to be careful not to try to read to much due to datatype/memory limitations.
2. The program now focusses on only processing the portion of the image that will fit on the screen instead of blindly drawing outside the screen borders.
3. The image is drawn to a buffer (an array called Canvas) which is then drawn using the PUT graphics statement. This appears to be slightly faster than separate calls to the PSET statement. At least the image appears all at once instead of slowly appearing line by line.
4. Added scrolling - made possible by the DisplayBitmap procedure now accepting x/y offset values.
This program likely doesn't have much practical value, but it was entertaining to squeeze as much as possible out of such an old programming language as Quick Basic. :-) The program should work in Qbasic/Quick Basic/Visual Basic for DOS and probably Turbo/Power Basic as well.
Re: Uncompressed 8 bit bitmap reader->
And here's the SVGA version of the above program:
Code:
'256 Color Bitmap Reader add-on, by: Peter Swinkels.
DEFINT A-Z
TYPE InformationType
ModeAttributes AS INTEGER
WinAAttributes AS STRING * 1
WinBAttributes AS STRING * 1
WinGranularity AS INTEGER
WinSize AS INTEGER
WinASegment AS INTEGER
WinBSegment AS INTEGER
WinFuncPointer AS LONG
BytesPerScanLine AS INTEGER
XResolution AS INTEGER
YResolution AS INTEGER
XCharSize AS STRING * 1
YCharSize AS STRING * 1
NumberOfPlanes AS STRING * 1
BitsPerPixel AS STRING * 1
NumberOfBanks AS STRING * 1
MemoryModel AS STRING * 1
BankSize AS STRING * 1
NumberOfImagePages AS STRING * 1
SizeOfBank AS STRING * 1
RedMaskSize AS STRING * 1
RedFieldPosition AS STRING * 1
GreenMaskSize AS STRING * 1
GreenFieldPosition AS STRING * 1
BlueMaskSize AS STRING * 1
BlueFieldPosition AS STRING * 1
RsvdMaskSize AS STRING * 1
RsvdFieldPosition AS STRING * 1
DirectColorInformation AS STRING * 1
Reserved AS STRING * 216
END TYPE
TYPE RegTypeX
ax AS INTEGER
bx AS INTEGER
cx AS INTEGER
dx AS INTEGER
bp AS INTEGER
si AS INTEGER
di AS INTEGER
flags AS INTEGER
ds AS INTEGER
es AS INTEGER
END TYPE
TYPE VGAInfoType
VESASignature AS STRING * 4
VESAVersion AS INTEGER
OEMStringPTR AS LONG
Capabilities AS STRING * 4
VideoModePTR AS LONG
TotalMemory AS INTEGER
Reserved AS STRING * 236
END TYPE
DECLARE FUNCTION OpenBinary (FileName$)
DECLARE FUNCTION SetVESAMode (VIDEOMODE)
DECLARE FUNCTION VESAPresent ()
DECLARE SUB DisplayBitmap (FileH, XOffset, YOffset, ScreenWidth, SCREENHEIGHT, ImageWidth AS LONG, ImageHeight AS LONG)
DECLARE SUB GetVESAInformation (VIDEOMODE, Information AS InformationType)
DECLARE SUB INTERRUPTX (intnum AS INTEGER, inreg AS RegTypeX, outreg AS RegTypeX)
DECLARE SUB Main ()
DECLARE SUB ResetVideo ()
DECLARE SUB SetPalette (FileH)
DECLARE SUB SetVESABank (Bank)
CALL Main
SUB DisplayBitmap (FileH, XOffset, YOffset, ScreenWidth, SCREENHEIGHT, ImageWidth AS LONG, ImageHeight AS LONG)
CONST BITMAP = 1078
CONST DIMENSIONS = 19
DIM Bank
DIM CurrentBank
DIM Offset AS LONG
DIM Position AS LONG
DIM Row$
DIM x
DIM y
STATIC Padding
IF ImageWidth = 0 AND ImageHeight = 0 THEN
SEEK FileH, DIMENSIONS
ImageWidth = CVL(INPUT$(4, FileH))
ImageHeight = CVL(INPUT$(4, FileH))
IF SCREENHEIGHT > ImageHeight THEN SCREENHEIGHT = ImageHeight
Padding = ((LOF(FileH) - BITMAP) / ImageHeight) - ImageWidth
END IF
Position = (LOF(FileH) - ((ImageWidth + Padding) * (YOffset + SCREENHEIGHT)))
IF Position > BITMAP THEN SEEK FileH, Position ELSE SEEK FileH, BITMAP
DEF SEG = &HA000
CurrentBank = 0
SetVESABank CurrentBank
FOR y = SCREENHEIGHT - 1 TO 0 STEP -1
IF Position > 0 AND LOC(FileH) < LOF(FileH) THEN
Row$ = INPUT$(ImageWidth + Padding, FileH)
FOR x = 0 TO ScreenWidth - 1
Offset = CLNG(CLNG(y) * CLNG(ScreenWidth)) + CLNG(x)
Bank = Offset \ &H10000
IF NOT Bank = CurrentBank THEN
SetVESABank Bank
CurrentBank = Bank
END IF
IF x + XOffset < ImageWidth AND y + YOffset < ImageHeight THEN
POKE Offset AND &HFFFF&, ASC(MID$(Row$, x + XOffset + 1, 1))
ELSE
POKE Offset AND &HFFFF&, &H0
END IF
NEXT x
ELSE
FOR x = 0 TO ScreenWidth - 1
Offset = CLNG(CLNG(y) * CLNG(ScreenWidth)) + CLNG(x)
Bank = Offset \ &H10000
IF NOT Bank = CurrentBank THEN
SetVESABank Bank
CurrentBank = Bank
END IF
POKE Offset AND &HFFFF&, &H0
NEXT x
END IF
Position = Position + (ImageWidth + Padding)
NEXT y
END SUB
SUB GetVESAInformation (VIDEOMODE, Information AS InformationType)
DIM Registers AS RegTypeX
Registers.ax = &H4F01
Registers.cx = VIDEOMODE
Registers.es = VARSEG(Information)
Registers.di = VARPTR(Information)
INTERRUPTX &H10, Registers, Registers
END SUB
SUB Main
CONST VIDEOMODE = &H101
DIM FileH
DIM FileName$
DIM ImageHeight AS LONG
DIM ImageWidth AS LONG
DIM Key$
DIM Success
DIM VESAInformation AS InformationType
DIM x
DIM y
IF NOT VESAPresent THEN
PRINT "No VESA found."
END
END IF
GetVESAInformation VIDEOMODE, VESAInformation
ResetVideo
COLOR 0, 7: PRINT " BITMAP FILES: " + SPACE$(65)
COLOR 7, 0: FILES "*.bmp"
PRINT STRING$(80, "=")
LINE INPUT "SPECIFY BITMAP: ", FileName$
IF LTRIM$(RTRIM$(FileName$)) = "" THEN EXIT SUB
Success = SetVESAMode(VIDEOMODE)
IF NOT Success THEN
PRINT "Could not initialize VESA."
END
END IF
FileH = OpenBinary(FileName$)
SetPalette FileH
x = 0
y = 0
DO
CLS
DisplayBitmap FileH, x, y, VESAInformation.XResolution, VESAInformation.YResolution, ImageWidth, ImageHeight
DO
Key$ = INKEY$
LOOP WHILE Key$ = ""
SELECT CASE Key$
CASE CHR$(0) + "H"
y = y - (VESAInformation.YResolution / 4)
CASE CHR$(0) + "P"
y = y + (VESAInformation.YResolution / 4)
CASE CHR$(0) + "K"
x = x - (VESAInformation.XResolution / 4)
CASE CHR$(0) + "M"
x = x + (VESAInformation.YResolution / 4)
CASE "1"
x = x - VESAInformation.XResolution
y = y + VESAInformation.YResolution
CASE "2"
y = y + VESAInformation.YResolution
CASE "3"
x = x + VESAInformation.XResolution
y = y + VESAInformation.YResolution
CASE "4"
x = x - VESAInformation.XResolution
CASE "6"
x = x + VESAInformation.XResolution
CASE "7"
x = x - VESAInformation.XResolution
y = y - VESAInformation.YResolution
CASE "8"
y = y - VESAInformation.YResolution
CASE "9"
x = x + VESAInformation.XResolution
y = y - VESAInformation.YResolution
CASE "i", "I"
ResetVideo
PRINT USING "X: ####"; x
PRINT USING "Y: ####"; y
PRINT USING "Width: ####"; ImageWidth
PRINT USING "Height: #### "; ImageHeight
DO: LOOP WHILE INKEY$ = ""
Success = SetVESAMode(VIDEOMODE)
SetPalette FileH
CASE CHR$(27)
ResetVideo
EXIT DO
END SELECT
IF x < 0 THEN x = 0
IF y < 0 THEN y = 0
LOOP
CLOSE FileH
END SUB
FUNCTION OpenBinary (FileName$)
DIM FileH
FileH = FREEFILE
OPEN FileName$ FOR INPUT AS FileH: CLOSE FileH
OPEN FileName$ FOR BINARY AS FileH
OpenBinary = FileH
END FUNCTION
SUB ResetVideo
SCREEN 1
SCREEN 0
PALETTE
WIDTH 40
WIDTH 80, 25
COLOR 7, 0
CLS
END SUB
SUB SetPalette (FileH)
CONST COLORS = 55
DIM Blue AS LONG
DIM ColorIndex
DIM Green AS LONG
DIM Null$
DIM Red AS LONG
SEEK FileH, COLORS
FOR ColorIndex = 0 TO 255
Blue = ASC(INPUT$(1, FileH)) \ &H4
Green = ASC(INPUT$(1, FileH)) \ &H4
Red = ASC(INPUT$(1, FileH)) \ &H4
OUT 968, ColorIndex
OUT 969, Red
OUT 969, Green
OUT 969, Blue
Null$ = INPUT$(1, FileH)
NEXT ColorIndex
END SUB
SUB SetVESABank (Bank)
DIM Registers AS RegTypeX
Registers.ax = &H4F05
Registers.bx = &H0
Registers.dx = Bank
INTERRUPTX &H10, Registers, Registers
END SUB
FUNCTION SetVESAMode (VIDEOMODE)
DIM Registers AS RegTypeX
Registers.ax = &H4F02
Registers.bx = VIDEOMODE
INTERRUPTX &H10, Registers, Registers
SetVESAMode = (Registers.ax = &H4F)
END FUNCTION
FUNCTION VESAPresent
DIM Information AS VGAInfoType
DIM Registers AS RegTypeX
Registers.ax = &H4F00
Registers.es = VARSEG(Information)
Registers.di = VARPTR(Information)
INTERRUPTX &H10, Registers, Registers
VESAPresent = (Registers.ax = &H4F)
END FUNCTION
This one only works with those versions of Basic that have a library containing the INTERRUPTX statement. Quick Basic and Visual Basic for DOS but not Qbasic for example.