'---------------------------------------------------------------------
'|                     A Screensaver type thing                      |
'|                         Uses Screen 12                            |
'|            Runs until mouse moves, or key is pressed              |
'|      Has midnite rollover checking and should run about the       |
'|                   same speed on any CPU.                          |
'|    As a screensaver, it's pretty lame, but I actually use it!     |
'|    I hot-key into it from Win95, with properties set to give      |
'|    it priority.  It keeps the hard-disk from thrashing while a    |
'|        real screensaver runs, because I set the properties        |
'|              to keep the real screen from starting!               |
'---------------------------------------------------------------------

'Blankbox.BAS by Mike Anderson
'Draws a screen full of ellipses, erases them one at a time
' then draws a screen full of rectangles and erases them one
' at a time.  Runs until mouse or keyboard action.

DEFINT A-Z
DECLARE SUB MIDNITE ()
DECLARE SUB Dlay (Sng!)
DECLARE SUB Mouse (m1%, m2%, m3%, m4%)
DECLARE SUB Mousenow (leftbutton%, rightbutton%, xmouse%, ymouse%)
DECLARE FUNCTION MouseInstall% ()
DECLARE FUNCTION DrawBox ()
DECLARE FUNCTION DrawCirc ()

CONST TRUE = -1
CONST FALSE = NOT TRUE

' $INCLUDE: 'qb.bi'
RANDOMIZE TIMER

'  The following structures are used to erase the randomly
'  drawn figures.

TYPE Circs
	R AS INTEGER     'R is horiz. pos of center
	T AS INTEGER     'T is vert.   "  "    "
	L AS INTEGER     'L is Radius
	A AS SINGLE      'A is aspect ratio (we're really drawing
END TYPE             '     ellipses)

TYPE Boxes
	R AS INTEGER     'R is Right edge
	L AS INTEGER     '  Left edge
	T AS INTEGER     '  Top
	B AS INTEGER     '  Bottom
END TYPE

DIM SHARED AllCircles(50) AS Circs  'Array of Ellipses drawn
DIM SHARED AllBoxes(50) AS Boxes    'Array of Boxes drawn
DIM SHARED ThisCirc AS Circs        'Ellipse buffer
DIM SHARED ThisBox AS Boxes         'Box buffer

SCREEN 12
CLS

x = MouseInstall                    'check for mouse

IF x THEN                           'If found,
	xmouse% = 0                     ' store the position
	ymouse% = 0
	Mousenow lbut, rbut, startx, starty
END IF

x = TRUE
DO
	IF x THEN
		x = DrawCirc       'DrawCirc is a function - returns TRUE
	ELSE                   'Until finished, then returns false
		x = DrawBox        'DrawBox function returns false until
	END IF                 'finished, then returns true

	'After each circle or box check the mouse position
	'and quit if it has moved
	Mousenow lbut, rbut, xnow, ynow
	IF xnow <> startx AND ynow <> starty THEN SYSTEM
   
	'If the mouse hasn't moved, check the keyboard
	'and quit on any key.
	R$ = INKEY$
	IF LEN(R$) THEN SYSTEM
LOOP

SUB Dlay (Sng!)

Now! = TIMER
DO
	TElapsed! = TIMER - Now!
	IF TElapsed! < 0 THEN     'Midnite hath passed!
		MIDNITE               ' Announce it!
		EXIT SUB              ' Possible change - announce
	END IF                    ' every hour, half-hour, or 1/4 hour

LOOP WHILE TElapsed! < Sng!

END SUB

FUNCTION DrawBox STATIC

DrawBox = FALSE
Dlay (.2)

L = INT(640 * RND): ThisBox.L = L
R = INT(640 * RND): ThisBox.R = R
T = INT(480 * RND): ThisBox.T = T
B = INT(480 * RND): ThisBox.B = B
C = INT(15 * RND) + 1

AllBoxes(count%) = ThisBox      'save characteristic of ThisBox
								'to array of all boxes
Numbox = 50                     ' 50 fills the screen nicely - if
								' you change it, change the DIM statement
								' for AllBoxes also.
IF count% >= Numbox THEN
	IF erased% >= Numbox THEN   'If all are drawn, and all are erased
		count% = 0              ' start over
		erased% = 0
		DrawBox = TRUE          ' Return TRUE, to switch to ellipses
		Dlay (.4)
	ELSE    '(keep erasing)
			' Watch it - the next line is a long one!
		LINE (AllBoxes(erased%).L, AllBoxes(erased%).T)-(AllBoxes(erased%).R, AllBoxes(erased%).B), 0, B
		erased% = erased% + 1
	END IF
ELSE    '(keep drawing)
	LINE (L, T)-(R, B), C, B
	count% = count% + 1
END IF

END FUNCTION

FUNCTION DrawCirc STATIC

DrawCirc = TRUE
Dlay (.2)
L = INT(240 * RND)      'set the "Radius"

A! = INT(10 * RND) + 1  'Set the aspect ratio
H = INT(2 * RND) + 1    ' Flip a coin
IF H = 1 THEN A! = 1 / A! ' If "heads" then invert the aspect ratio

'This next bit of gymnastics keeps the entire figure on the screen
IF A! < 1 THEN
	R = INT(RND * (640 - (2 * L))) + L
	T = INT(RND * (480 - (2 * A! * L))) + (A! * L)
ELSE
	R = INT(RND * (640 - (2 * (1 / A!) * L))) + ((1 / A!) * L)
	T = INT(RND * (480 - (2 * L))) + L
END IF

C = INT(15 * RND) + 1  'Pick a color, except black

ThisCirc.R = R
ThisCirc.T = T
ThisCirc.L = L
ThisCirc.A = A!
AllCircles(count%) = ThisCirc   'save the characteristics in the array

Numbox = 50         '50 is a nice number - if changed, be sure to change
					'the DIM statement for AllCircles array

IF count% >= Numbox THEN        'Have we drawn all 50?
	IF erased% >= Numbox THEN   'Yes.  Have we erased all 50?
		count% = 0              'Yes, so clean up
		erased% = 0
		DrawCirc = FALSE        'Return FALSE, to switch to boxes
		Dlay (.4)
	ELSE                        'No - Keep erasing.
					'Next line is a long one - watch for wrapping
		CIRCLE (AllCircles(erased%).R, AllCircles(erased%).T), AllCircles(erased).L, 0, , , AllCircles(erased%).A
		erased% = erased% + 1
	END IF
ELSE      'Not done drawing -
	CIRCLE (R, T), L, C, , , A!  'Draw next one
	count% = count% + 1
END IF


END FUNCTION

DEFSNG A-Z
SUB MIDNITE
CLS
'Announce that Midnite has passed

LOCATE 12, 36
COLOR 15
PRINT "MIDNITE"
' Play a tune

SOUND 1300, 12
SOUND 30000, 2
SOUND 1000, 12
SOUND 30000, 2
SOUND 1150, 12
SOUND 30000, 2
SOUND 760, 12
SOUND 30000, 2
SOUND 760, 12
SOUND 30000, 2
SOUND 1150, 12
SOUND 30000, 2
SOUND 1300, 12
SOUND 30000, 2
SOUND 1000, 16

COLOR 7
CLS

END SUB

DEFINT A-Z
SUB Mouse (m1%, m2%, m3%, m4%)
		'Mouse interrupt handler
	   DIM InRegs AS RegType, OutRegs AS RegType
	   InRegs.ax = m1%
	   InRegs.bx = m2%
	   InRegs.cx = m3%
	   InRegs.dx = m4%
	   INTERRUPT &H33, InRegs, OutRegs
	   m1% = OutRegs.ax
	   m2% = OutRegs.bx
	   m3% = OutRegs.cx
	   m4% = OutRegs.dx
END SUB

FUNCTION MouseInstall%
'Checks for existance
	   mflag% = FALSE   'Assume it's not there
	   Mouse mflag%, 0, 0, 0
	   MouseInstall% = mflag%
END FUNCTION

SUB Mousenow (leftbutton%, rightbutton%, xmouse%, ymouse%)
	   Mouse 3, m2%, xmouse%, ymouse%
	   leftbutton% = ((m2% AND 1) <> 0)
	   rightbutton% = ((m2% AND 2) <> 0)
END SUB