DECLARE SUB createbitmap (file%, xdim!, ydim!) '
DECLARE SUB putfilestats (file%, xdim!, ydim!)
DECLARE SUB textprogbar (x%, y%, curr%, max%)
DECLARE SUB clearbitmap (file%)
DECLARE SUB putrgb (file%, x%, y%, bout%, gout%, rout%)
DECLARE SUB getrgb (file%, x%, y%, bin%, gin%, rin%)
DECLARE SUB getfilestats (file%, mem!, xdim!, ydim!)
DECLARE SUB plotfrombinary (x%, y%, b%, g%, r%)
DECLARE FUNCTION MouseInit% ()
DECLARE SUB MouseCall ()
DECLARE SUB MouseGetPressInfo (LBtn%, RBtn%, MBtn%, Count%, HPosn%, VPosn%)
DECLARE SUB MouseGetReleaseInfo (LBtn%, RBtn%, MBtn%, Count%, HPosn%, VPosn%)
DECLARE SUB MouseGetStatus (LBtn%, RBtn%, MBtn%, HPosn%, VPosn%)
DECLARE SUB MouseHide ()
DECLARE SUB MouseReadCounters (HCount%, VCount%)
DECLARE SUB MouseSetHorizRange (HMin%, HMax%)
DECLARE SUB MouseSetPosn (HPosn%, VPosn%)
DECLARE SUB MouseSetup ()
DECLARE SUB MouseSetVertRange (VMin%, VMax%)
DECLARE SUB MouseShow ()
TYPE MouseRegs
AX AS INTEGER
BX AS INTEGER
CX AS INTEGER
DX AS INTEGER
ES AS INTEGER
END TYPE
DIM SHARED MReg AS MouseRegs
REDIM SHARED MouseRoutine%(0 TO 19)
DIM SHARED MouseReady%
MouseReady% = 0
MouseSetup
MouseReady% = MouseInit
DEFINT A-Z
TYPE TextMask
Bg AS INTEGER
Fg AS INTEGER
char AS INTEGER
Mask AS INTEGER
END TYPE
RANDOMIZE TIMER
'
' basfunct.bas - Some Qbasic functions of mine
' The mouse functions are public domain code I downloaded. (I did not write them)
' The bitmap functions are my own, and are available to anyone.
' Current version last updated 02/25/04
'
'ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ

'ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ
zzzzzz: CLOSE : END

SUB clearbitmap (file%)
'
' Clears values in a 24-bit BMP file
'
' file% - Number of open file to be cleared
'
CALL getfilestats(file%, mem!, xdim!, ydim!)
xdrf! = (4 - (xdim! * 3) MOD 4) MOD 4

n! = 54

DO WHILE n! < mem!

	IF (mem! - n!) > 2048 THEN
		blanks! = 2048
	ELSE
		blanks! = mem! - n!
	END IF

	a$ = SPACE$(blanks!)
	a$ = STRING$(blanks!, 0)
	PUT file%, n!, a$
	n! = n! + blanks!

LOOP

END SUB

SUB createbitmap (file%, xdim!, ydim!)

BMint$ = "424D360C000000000000360000002800000020000000200000000100180000000000000C000000000000000000000000000000000000"
PUT file%, 1, BMint$

xdrf! = ((4 - xdim! * 3) MOD 4) MOD 4
mem! = 54 + (xdim! * 3 + xdrf!) * ydim!

CALL putfilestats(file%, xdim!, ydim!)

END SUB

SUB getfilestats (file%, mem!, xdim!, ydim!)

mem$ = SPACE$(4): GET file%, 3, mem$
xdim$ = SPACE$(4): GET file%, 19, xdim$
ydim$ = SPACE$(4): GET file%, 23, ydim$

FOR n = 3 TO 0 STEP -1
		mem! = mem! + ASC(MID$(mem$, n + 1, 1)) * (256! ^ n)
		xdim! = xdim! + ASC(MID$(xdim$, n + 1, 1)) * (256! ^ n)
		ydim! = ydim! + ASC(MID$(ydim$, n + 1, 1)) * (256! ^ n)
NEXT n

mem! = INT(mem!)
xdim! = INT(xdim!)
ydim! = INT(ydim!)

END SUB

SUB getrgb (file%, x%, y%, bin%, gin%, rin%)

' file%  - FILE NUMBER
' x%, y% - COORDINATES OF READ
' bin%, gin%, rin% - BGR VALUES OF PIXEL IN FILE

		CALL getfilestats(file%, mem!, xdim!, ydim!)
		xdrf! = ((4 - xdim! * 3) MOD 4) MOD 4

		IF x% < 0 OR x% > (xdim! - 1) OR y% < 0 OR y% > (ydim! - 1) THEN
				EXIT SUB
		END IF

		a$ = SPACE$(3)
		a! = 55 + (3 * INT((y% * xdim!) + x%)) + (xdrf! * y%)

		GET file%, a!, a$

		bin% = ASC(MID$(a$, 1, 1))
		gin% = ASC(MID$(a$, 2, 1))
		rin% = ASC(MID$(a$, 3, 1))

END SUB

SUB MouseCall
'*
'* Call mouse using current values in MReg registers
'*
	DEF SEG = VARSEG(MouseRoutine%(0))
	Addr% = VARPTR(MouseRoutine%(0))
	CALL Absolute(MReg, Addr%)
	DEF SEG
END SUB

SUB MouseGetPressInfo (LBtn%, RBtn%, MBtn%, Count%, HPosn%, VPosn%)
'*
'* Gets info about last mouse click
'* Set LBtn%, RBtn%, or MBtn% <> 0 for button to query
'* LBtn%, RBtn%, or MBtn% return 1 to show which
'* button is currently down or 0 to show which button
'* is currently up
'* Count% has count of clicks since last call
'* HPosn% and VPosn% are horizontal and vertical position
'* of cursor at last click
'*
	IF MouseReady% THEN
		IF (LBtn% OR RBtn% OR MBtn%) <> 0 THEN
			MReg.AX = 5
			IF LBtn% THEN MReg.BX = 0
			IF RBtn% THEN MReg.BX = 1
			IF MBtn% THEN MReg.BX = 2
			MouseCall
			LBtn% = MReg.AX AND 1
			RBtn% = (MReg.AX AND 2) \ 2
			MBtn% = (MReg.AX AND 4) \ 4
			Count% = MReg.BX
			HPosn% = MReg.CX
			VPosn% = MReg.DX
		ELSE
			CALL MouseGetStatus(LBtn%, RBtn%, MBtn%, HPosn%, VPosn%)
			Count% = 0
		END IF
	ELSE
		LBtn% = 0: RBtn% = 0: MBtn% = 0
		Count% = 0
		HPosn% = -1: VPosn% = -1
	END IF
END SUB

SUB MouseGetReleaseInfo (LBtn%, RBtn%, MBtn%, Count%, HPosn%, VPosn%)
'*
'* Gets info about last mouse release
'* Set LBtn%, RBtn%, or MBtn% <> 0 for button query
'* LBtn%, RBtn%, or MBtn% return 1 to show which
'* button is currently down or 0 to show which
'* button is currently up
'* Count% has count of releases since last call
'* HPosn% and VPosn% are horizontal and vertical position
'* of cursor at last release
'*
	IF MouseReady% THEN
		IF (LBtn% OR RBtn% OR MBtn%) <> 0 THEN
			MReg.AX = 6
			IF LBtn% THEN MReg.BX = 0
			IF RBtn% THEN MReg.BX = 1
			IF MBtn% THEN MReg.BX = 2
			MouseCall
			LBtn% = MReg.AX AND 1
			RBtn% = (MReg.AX AND 2) \ 2
			MBtn% = (MReg.AX AND 4) \ 4
			Count% = MReg.BX
			HPosn% = MReg.CX
			VPosn% = MReg.DX
		ELSE
			CALL MouseGetStatus(LBtn%, RBtn%, MBtn%, HPosn%, VPosn%)
			Count% = 0
		END IF
	ELSE
		LBtn% = 0: RBtn% = 0: MBtn% = 0
		Count% = 0
		HPosn% = -1: VPosn% = -1
	END IF
END SUB

SUB MouseGetStatus (LBtn%, RBtn%, MBtn%, HPosn%, VPosn%)
'*
'* Gets current mouse status
'* LBtn%, RBtn%, and MBtn% return
'* 1 if button is down or 0 if button is up
'* HPosn% returns horizontal position
'* VPosn% returns vertical position
'*
	IF MouseReady% THEN
		MReg.AX = 3
		MouseCall
		LBtn% = MReg.BX AND 1
		RBtn% = (MReg.BX AND 2) \ 2
		MBtn% = (MReg.BX AND 4) \ 4
		HPosn% = MReg.CX
		VPosn% = MReg.DX
	ELSE
		LBtn% = 0: RBtn% = 0: MBtn% = 0
		HPosn% = -1: VPosn% = -1
	END IF
END SUB

SUB MouseHide
'*
'* Hide the mouse cursor
'* Decrement the mouse cursor flag
'* Cursor hidden if flag <> 0
'* MouseInit sets flag to -1
'*
	IF MouseReady% THEN
		MReg.AX = 2
		MouseCall
	END IF
END SUB

FUNCTION MouseInit%
'*
'* Initialize mouse and return
'* number of buttons
'* Return 0 if mouse driver
'* unavailable or mouse not
'* present
'*
	DEF SEG = 0
	Sum% = 0
	FOR i% = &H33 * 4 TO &H33 * 4 + 3
		Sum% = Sum% + PEEK(i%)
	NEXT i%
	IF Sum% = 0 THEN
		MouseInit% = 0
		EXIT FUNCTION
	END IF
	MReg.AX = 0
	MouseCall
	IF MReg.AX = 0 THEN
		MouseInit% = 0
	ELSE
		MouseInit% = MReg.BX
	END IF
END FUNCTION

SUB MouseReadCounters (HCount%, VCount%)
'*
'* Returns mouse movement relative to
'* the last time this function was called
'* Measurements are in "mickeys". By default,
'* 1 mickey = 1 pixel horizontally and
'* 2 mickeys = 1 pixel vertically
'*
	IF MouseReady% THEN
		MReg.AX = 11
		MouseCall
		HCount% = MReg.CX
		VCount% = MReg.DX
	END IF
END SUB

SUB MouseSetHorizRange (HMin%, HMax%)
'*
'* Sets the minimum and maximum horizontal
'* range of the mouse cursor.
'* Moves the cursor inside the range if it's
'* outside.
'*
	IF MouseReady% THEN
		MReg.AX = 7
		MReg.CX = HMin%
		MReg.DX = HMax%
		MouseCall
	END IF
END SUB

SUB MouseSetPosn (HPosn%, VPosn%)
'*
'* Sets mouse cursor to HPosn and VPosn
'*
	IF MouseReady% THEN
		MReg.AX = 4
		MReg.CX = HPosn%
		MReg.DX = VPosn%
		MouseCall
	END IF
END SUB

SUB MouseSetup
'*
'* Setup to use mouse
'* MUST be called before
'* MouseInit or any other
'* mouse calls
'*
Mint$ = "5589E5568B76068B048B5C028B4C048B54068E4408CD338C4408895406894C04895C0289045E5DCB"
	DEF SEG = VARSEG(MouseRoutine%(0))
	Addr% = VARPTR(MouseRoutine%(0))
	FOR i = 0 TO 39
		POKE Addr% + i, VAL("&H" + MID$(Mint$, (i * 2) + 1, 2))
	NEXT i
	DEF SEG
END SUB

SUB MouseSetVertRange (VMin%, VMax%)
'*
'* Sets the minimum and maximum vertical
'* range of the mouse cursor
'* Moves the cursor inside the range if it's
'* outside
	IF MouseReady% THEN
		MReg.AX = 8
		MReg.CX = VMin%
		MReg.DX = VMax%
		MouseCall
	END IF
END SUB

SUB MouseShow
'*
'* Display the mouse cursor
'* Increments mouse cursor flag
'* Cursor is displayed if flag is 0
'* MouseInit sets flag to -1
'*
	IF MouseReady% THEN
		MReg.AX = 1
		MouseCall
	END IF
END SUB

SUB plotfrombinary (x%, y%, b%, g%, r%)
'
' Û Plots a rudimentary 4-bit pixel from a 24-bit RGB code
' Û where RGB values sent to SUB range from 0-255,
' Û x% is horizontal coordinate starting from LEFT,
' Û y% is vertical coordinate starting from BOTTOM
' Û (consistent with 24-bit BMP format)
'
	col% = 0
	IF b% + g% + r% > 384 THEN col% = col% + 8
	IF r% > 128 THEN col% = col% + 4
	IF g% > 128 THEN col% = col% + 2
	IF b% > 128 THEN col% = col% + 1
	PSET (x%, 479! - y%), col%
END SUB

SUB PrintChar (char%, xx%, yy%, fco%, bco%, sz%)
IF bco% >= 16 THEN trans% = -1: bco% = bco% - 16
FOR y! = 0 TO 7 STEP (8 / sz%)
		FOR x! = 0 TO 7 STEP (8 / sz%)
		a$ = SPACE$(1)
		GET 99, 1 + (char% * 64) + (INT(y!) * 8 + INT(x!)), a$

		xpl% = (xx%) + x! * (sz% / 8)
		ypl% = (yy%) + (7 - y! * (sz% / 8))

		co% = -(ASC(a$) > 0) * fco%

		IF ASC(a$) > 0 THEN PSET (xpl%, ypl%), co%: GOTO plotted:
		IF trans% THEN GOTO plotted:
		PSET (xpl%, ypl%), bco%
plotted:
NEXT x!, y!
END SUB

SUB putfilestats (file%, xdim!, ydim!)

xdrf! = ((4 - xdim! * 3) MOD 4) MOD 4
mem! = 54 + (xdim! * 3 + xdrf!) * ydim!

FOR n = 3 TO 0 STEP -1

		mem$ = mem$ + CHR$(INT(mem! / (256! ^ n)))
		mem! = mem! - INT(mem! / (256! ^ n)) * (256! ^ 2)

		xdim$ = xdim$ + CHR$(INT(xdim! / (256! ^ n)))
		xdim! = xdim! - INT(xdim! / (256! ^ n)) * (256! ^ 2)

		ydim$ = ydim$ + CHR$(INT(ydim! / (256! ^ n)))
		ydim! = ydim! - INT(ydim! / (256! ^ n)) * (256! ^ 2)

NEXT n

PUT file%, 3, mem$
PUT file%, 19, xdim$
PUT file%, 23, ydim$

END SUB

SUB putrgb (file%, x%, y%, bout%, gout%, rout%)
'
' Û Puts RGB color values at coordinates x%, y%
' Û in a 24-bit BMP file number file%
' Û
' Û xdim!(file%) (horizontal dimension of file%),
' Û ydim!(file%) (vertical dimension of file%), and
' Û xdrf!(file%) (horizontal dimension remainder correction
' Û   factor inherent to Windows 24-bit BMP format) must be shared
' Û variables and be determined before calling SUB
'
		CALL getfilestats(1, mem!, xdim!, ydim!)
		xdrf! = ((4 - xdim! * 3) MOD 4) MOD 4

		IF x% < 0 OR x% > (xdim! - 1) OR y% < 0 OR y% > (ydim! - 1) THEN EXIT SUB

		IF bout% > 255 THEN bout% = 255
		IF gout% > 255 THEN gout% = 255
		IF rout% > 255 THEN rout% = 255

		IF bout% < 0 THEN bout% = 0
		IF gout% < 0 THEN gout% = 0
		IF rout% < 0 THEN rout% = 0

		a$ = CHR$(bout%) + CHR$(gout%) + CHR$(rout%)
		a! = 55 + (3 * INT((y% * xdim!) + x%)) + (xdrf! * y%)
		PUT file%, a!, a$

END SUB

SUB textprogbar (x%, y%, curr%, max%)

'
' This prints a progress bar at a selected location on the screen (text format).
'       x%, y% - screen coordinates
'       curr%  - Current value of variable in loop
'       max%   - Maximum value of variable (end of loop)

LOCATE x%, y%
a$ = "###%: " + STRING$((curr% / max%) * 48, 219)
PRINT USING a$; (curr% / max%) * 100

END SUB