I put this together last night for a younger relative to play. It's the classic cups and ball, or shell game. The ball hides under a cup, cups are shuffled around, you click on the cup you think the ball is under. There's no score keeping, it just keeps looping over with a new game. Mildly entertaining to play for a while I suppose. The fun for me was making it. This uses the power of RotoZoom3 to animate/shuffle the cups.
- Dav
Code: (Select All)
'============
'FINDBALL.BAS
'============
'Classic Cups & Ball game (shell game)
'Coded by Dav, MAY/2022
'Cups will shuffle. Click the cup with the ball.
'If selected correctly, screen flashes green. If not,
'screen will flash red. This could be turned into a
'game easy, with score keeping and speed changes.
'For now it just loops over and over.
RANDOMIZE TIMER
SCREEN _NEWIMAGE(1000, 600, 32)
cup& = BASIMAGE1& 'decode cup image to use
ball& = BASIMAGE2& 'decode ball image to use
speed = 75 'speed for _LIMIT
moves = 15 'how many shuffle moves to do
DO
cupball = INT(RND * 3) + 1 'make random cupball number (1,2,or 3)
GOSUB ShowBall 'show where ball is first
'shuffle the cups
FOR m = 1 TO moves
SELECT CASE INT(RND * 6) + 1 'random move
CASE 1: GOSUB move1to2
CASE 2: GOSUB move1to3
CASE 3: GOSUB move2to1
CASE 4: GOSUB move2to3
CASE 5: GOSUB move3to1
CASE 6: GOSUB move3to2
END SELECT
NEXT
GOSUB PlaceCups 'make sure they are placed right
selected = 0 'not selected yet
DO
WHILE _MOUSEINPUT: WEND
IF _MOUSEBUTTON(1) THEN
mx = _MOUSEX: my = _MOUSEY
'clicked cup 1
IF mx > 114 AND mx < 316 AND my > 146 AND my < 439 THEN
IF cupball = 1 THEN selected = 1
EXIT DO
END IF
'clicked cup 2
IF mx > 378 AND mx < 600 AND my > 146 AND my < 439 THEN
IF cupball = 2 THEN selected = 1
EXIT DO
END IF
'clicked cup 3
IF mx > 694 AND mx < 911 AND my > 146 AND my < 439 THEN
IF cupball = 3 THEN selected = 1
EXIT DO
END IF
END IF
LOOP
'make sure mouse button up to continue
DO UNTIL _MOUSEBUTTON(1) = 0: m = _MOUSEINPUT: LOOP
'flash screen based on selection
IF selected = 0 THEN
'flash red - wrong one
LINE (0, 0)-(_WIDTH, _HEIGHT), _RGBA(255, 0, 0, 100), BF
_DISPLAY
_DELAY .25
ELSE
'flash green - selected right
LINE (0, 0)-(_WIDTH, _HEIGHT), _RGBA(0, 255, 0, 100), BF
_DISPLAY
_DELAY .25
END IF
GOSUB ShowBall 'show where ball is
LOOP
END
'===================================================================
PlaceCups: 'shows all cups in place
'=========
'Place all cups first
_PUTIMAGE (0, 0), back&
RotoZoom3 200, 300, cup&, 1, 1, 0
RotoZoom3 500, 300, cup&, 1, 1, 0
RotoZoom3 800, 300, cup&, 1, 1, 0
_DISPLAY
RETURN
'=====
'===================================================================
ShowBall: 'Raises cup to show ball
'=======
'make sure showing all cups first
GOSUB PlaceCups
_DISPLAY: _DELAY 1
'raise a cup based on cupball number
SELECT CASE cupball
CASE IS = 1 'raise cup 1
_PUTIMAGE (0, 0), back&
FOR y = 300 TO 175 STEP -7
_PUTIMAGE (0, 0), back&
RotoZoom3 500, 300, cup&, 1, 1, 0
RotoZoom3 800, 300, cup&, 1, 1, 0
RotoZoom3 210, 400, ball&, 1, 1, 0 'ball first
RotoZoom3 200, y, cup&, 1, 1, 0 'cup over
_DISPLAY
_LIMIT 50
NEXT
CASE IS = 2 'raise cup 2
_PUTIMAGE (0, 0), back&
FOR y = 300 TO 175 STEP -7
_PUTIMAGE (0, 0), back&
RotoZoom3 200, 300, cup&, 1, 1, 0
RotoZoom3 800, 300, cup&, 1, 1, 0
RotoZoom3 510, 400, ball&, 1, 1, 0 'ball first
RotoZoom3 500, y, cup&, 1, 1, 0 'cup over
_DISPLAY
_LIMIT 50
NEXT
CASE IS = 3 'raise cup 3
_PUTIMAGE (0, 0), back&
FOR y = 300 TO 175 STEP -7
_PUTIMAGE (0, 0), back&
RotoZoom3 200, 300, cup&, 1, 1, 0
RotoZoom3 500, 300, cup&, 1, 1, 0
RotoZoom3 810, 400, ball&, 1, 1, 0 'ball first
RotoZoom3 800, y, cup&, 1, 1, 0 'cup over
_DISPLAY
_LIMIT 50
NEXT
END SELECT
_DELAY 1 'pause to see ball
'now lower the same a cup
SELECT CASE cupball
CASE IS = 1 'lower cup 1
_PUTIMAGE (0, 0), back&
FOR y = 175 TO 300 STEP 7
_PUTIMAGE (0, 0), back&
RotoZoom3 500, 300, cup&, 1, 1, 0
RotoZoom3 800, 300, cup&, 1, 1, 0
RotoZoom3 210, 400, ball&, 1, 1, 0 'ball first
RotoZoom3 200, y, cup&, 1, 1, 0 'cup over
_DISPLAY
_LIMIT 50
NEXT
CASE IS = 2 'lower cup 2
_PUTIMAGE (0, 0), back&
FOR y = 175 TO 300 STEP 7
_PUTIMAGE (0, 0), back&
RotoZoom3 200, 300, cup&, 1, 1, 0
RotoZoom3 800, 300, cup&, 1, 1, 0
RotoZoom3 510, 400, ball&, 1, 1, 0 'ball first
RotoZoom3 500, y, cup&, 1, 1, 0 'cup over
_DISPLAY
_LIMIT 50
NEXT
CASE IS = 3 'lower cup 3
_PUTIMAGE (0, 0), back&
FOR y = 175 TO 300 STEP 7
_PUTIMAGE (0, 0), back&
RotoZoom3 200, 300, cup&, 1, 1, 0
RotoZoom3 500, 300, cup&, 1, 1, 0
RotoZoom3 810, 400, ball&, 1, 1, 0 'ball first
RotoZoom3 800, y, cup&, 1, 1, 0 'cup over
_DISPLAY
_LIMIT 50
NEXT
END SELECT
RETURN
'=====
'===================================================================
move1to2: 'moves cup 1 over to cup 2
'=======
cup1z = 1: cup2z = 1: cup3z = 1
FOR move = 1 TO 300 STEP 15
_PUTIMAGE (0, 0), back& 'redraw background
'cup 3 stays in place
RotoZoom3 800, 300, cup&, cup3z, cup3z, 0
'cup 2 shrinks, going under cup 1, moving left
RotoZoom3 500 - move, 300 - cup2z, cup&, cup2z, cup2z, 0
IF move > 150 THEN cup2z = cup2z + .03 ELSE cup2z = cup2z - .03
'cup 1 enlarges, going over cup 2, moving right
RotoZoom3 200 + move, 300 * cup1z, cup&, cup1z, cup1z, 0
IF move > 150 THEN cup1z = cup1z - .03 ELSE cup1z = cup1z + .03
_DISPLAY
_LIMIT speed
NEXT
'swap ball placement
SELECT CASE cupball
CASE 1: cupball = 2
CASE 2: cupball = 1
END SELECT
RETURN
'=====
'===================================================================
move1to3: 'move cup 1 over to cup 3
'=======
cup1z = 1: cup2z = 1: cup3z = 1
FOR move = 1 TO 300 STEP 8
_PUTIMAGE (0, 0), back&
'cup 3 shrinks, moves left two places
RotoZoom3 800 - (move * 2), 300 - cup3z, cup&, cup3z, cup3z, 0
IF move > 150 THEN cup3z = cup3z + .02 ELSE cup3z = cup3z - .02
'cup 2 stays in place
RotoZoom3 500, 300, cup&, cup2z, cup2z, 0
'cup 1 enlarges, moving right two places
RotoZoom3 200 + (move * 2), 300 * cup1z, cup&, cup1z, cup1z, 0
IF move > 150 THEN cup1z = cup1z - .02 ELSE cup1z = cup1z + .02
_DISPLAY
_LIMIT speed * 1.7
NEXT
SELECT CASE cupball
CASE 1: cupball = 3
CASE 3: cupball = 1
END SELECT
RETURN
'=====
'===================================================================
move2to1: 'move cup 2 over to cup 1
'=======
cup1z = 1: cup2z = 1: cup3z = 1
FOR move = 1 TO 300 STEP 15
_PUTIMAGE (0, 0), back&
'3rd cup stays in place
RotoZoom3 800, 300, cup&, cup3z, cup3z, 0
'cup 1 shrinks, moving right
RotoZoom3 200 + move, 300 - cup1z, cup&, cup1z, cup1z, 0
IF move > 150 THEN cup1z = cup1z + .03 ELSE cup1z = cup1z - .03
'cup 2 enlarges, moving left
RotoZoom3 500 - move, 300 * cup2z, cup&, cup2z, cup2z, 0
IF move > 150 THEN cup2z = cup2z - .03 ELSE cup2z = cup2z + .03
_DISPLAY
_LIMIT speed
NEXT
SELECT CASE cupball
CASE 1: cupball = 2
CASE 2: cupball = 1
END SELECT
RETURN
'=====
'===================================================================
move2to3: 'move cup 2 over to cup 3
'=======
cup1z = 1: cup2z = 1: cup3z = 1
FOR move = 1 TO 300 STEP 15
_PUTIMAGE (0, 0), back&
'cup 1 stays in place
RotoZoom3 200, 300, cup&, cup1z, cup1z, 0
'cup 3 shrinks under, moves left 1 cup,
RotoZoom3 800 - move, 300 - cup3z, cup&, cup3z, cup3z, 0
IF move > 150 THEN cup3z = cup3z + .03 ELSE cup3z = cup3z - .03
'cup 2 enlarges over, moves right 1 cup
RotoZoom3 500 + move, 300 * cup2z, cup&, cup2z, cup2z, 0
IF move > 150 THEN cup2z = cup2z - .03 ELSE cup2z = cup2z + .03
_DISPLAY
_LIMIT speed
NEXT
SELECT CASE cupball
CASE 2: cupball = 3
CASE 3: cupball = 2
END SELECT
RETURN
'===================================================================
move3to1: 'move cup 3 over to cup 1
'=======
cup1z = 1: cup2z = 1: cup3z = 1
FOR move = 1 TO 300 STEP 8
_PUTIMAGE (0, 0), back&
'cup 1 shrinks under, moving right two cup places,
RotoZoom3 200 + (move * 2), 300 - cup1z, cup&, cup1z, cup1z, 0
IF move > 150 THEN cup1z = cup1z + .02 ELSE cup1z = cup1z - .02
'cup2 stays in place
RotoZoom3 500, 300, cup&, cup2z, cup2z, 0
'cup 3 enlarges over, moving left two cup places,
RotoZoom3 800 - (move * 2), 300 * cup3z, cup&, cup3z, cup3z, 0
IF move > 150 THEN cup3z = cup3z - .02 ELSE cup3z = cup3z + .02
_DISPLAY
_LIMIT speed * 1.7
NEXT
SELECT CASE cupball
CASE 3: cupball = 1
CASE 1: cupball = 3
END SELECT
RETURN
'=====
'===================================================================
move3to2: 'move cup 3 over to cup2
'=======
cup1z = 1: cup2z = 1: cup3z = 1
FOR move = 1 TO 300 STEP 15
_PUTIMAGE (0, 0), back&
'cup1 stays in place
RotoZoom3 200, 300, cup&, cup1z, cup1z, 0
'cup 2 shrinks under, moves right 1 cup
RotoZoom3 500 + move, 300 - cup2z, cup&, cup2z, cup2z, 0
IF move > 150 THEN cup2z = cup2z + .03 ELSE cup2z = cup2z - .03
'cup 3 enlarges over, moves left 1 cup,
RotoZoom3 800 - move, 300 * cup3z, cup&, cup3z, cup3z, 0
IF move > 150 THEN cup3z = cup3z - .03 ELSE cup3z = cup3z + .03
_DISPLAY
_LIMIT speed
NEXT
SELECT CASE cupball
CASE 3: cupball = 2
CASE 2: cupball = 3
END SELECT
RETURN
SUB RotoZoom3 (X AS LONG, Y AS LONG, Image AS LONG, xScale AS SINGLE, yScale AS SINGLE, radianRotation AS SINGLE)
' This assumes you have set your drawing location with _DEST or default to screen.
' X, Y - is where you want to put the middle of the image
' Image - is the handle assigned with _LOADIMAGE
' xScale, yScale - are shrinkage < 1 or magnification > 1 on the given axis, 1 just uses image size.
' These are multipliers so .5 will create image .5 size on given axis and 2 for twice image size.
' radianRotation is the Angle in Radian units to rotate the image
' note: Radian units for rotation because it matches angle units of other Basic Trig functions
' and saves a little time converting from degree.
' Use the _D2R() function if you prefer to work in degree units for angles.
DIM px(3) AS SINGLE: DIM py(3) AS SINGLE ' simple arrays for x, y to hold the 4 corners of image
DIM W&, H&, sinr!, cosr!, i&, x2&, y2& ' variables for image manipulation
W& = _WIDTH(Image&): H& = _HEIGHT(Image&)
px(0) = -W& / 2: py(0) = -H& / 2 'left top corner
px(1) = -W& / 2: py(1) = H& / 2 ' left bottom corner
px(2) = W& / 2: py(2) = H& / 2 ' right bottom
px(3) = W& / 2: py(3) = -H& / 2 ' right top
sinr! = SIN(-radianRotation): cosr! = COS(-radianRotation) ' rotation helpers
FOR i& = 0 TO 3 ' calc new point locations with rotation and zoom
x2& = xScale * (px(i&) * cosr! + sinr! * py(i&)) + X: y2& = yScale * (py(i&) * cosr! - px(i&) * sinr!) + Y
px(i&) = x2&: py(i&) = y2&
NEXT
_MAPTRIANGLE _SEAMLESS(0, 0)-(0, H& - 1)-(W& - 1, H& - 1), Image TO(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
_MAPTRIANGLE _SEAMLESS(0, 0)-(W& - 1, 0)-(W& - 1, H& - 1), Image TO(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
END SUB
Help!!!
I've found this morning that I can't produce ANY new QB64 programs. When I write one, as simple as SCREEN 12 : PRINT "OK": STOP, I get an error "C++ compilation failed".
I can re-compile and run all my previous progs, even after making changes to them, but no new ones . What the...?
(I know this is headed as HELP, and should possibly be in the Help Me post, but it seems more related to QB64 questions, to me).
I know there is some documentation on $DEBUG, but I'm looking for documentation on how exactly to use the UI portion. I can use it somewhat, but I get the feeling I'm using only a minimal amount of functionality and would like to take full advantage of the feature.
Constructed from a series of letters that I posted in the QB ECHO of FIDONET quite a long time ago. Note that this tutorial was all about speeding things up which may not be quite the problem it was back then. Anyway, here is the original tutorial. In addition to the line drawing routine that is used to illustrate this tutorial on optimisation, I have included a couple of other graphics primitives routines. Fill is a seed fill routine and doros is an integer circle drawing routine. Doros is based on an algorithm discovered by a professor Doros and is a variation of the standard bresenham routine. The only drawback to it is that in order for it to produce circular circles it needs square pixels (i.e. SCREEN 12).
As there doesn't seem to be a lot of code floating around at present and we have quite a few newbies here I thought I would give an example of the way I have developed stuff in the past. Now as most people who are new to programming are interested in graphics I thought I'd use an example based in this area. Below is a small program that illustrates a different method of drawing a line on the screen than the one that is built into QB. The actual algorithm used is called a digital difference engine and while it is small it does have some drawbacks <g>.
Try it now and see if you can spot what they are. When you have done that go to the end of this message for an explanation of what they are and how the algorithm works.
Code: (Select All)
CONST FromX = 10
CONST FromY = 10
CONST ToX = 310
CONST ToY = 190
SCREEN 13
_FullScreen _SquarePixels
FOR index = 1 TO 5
LINE (FromX, FromY)-(ToX, ToY), 15
Sleep
DigitalDifferenceEngine FromX, FromY, ToX, ToY, 12
Sleep
NEXT index
SLEEP
END
SUB DigitalDifferenceEngine (X1, Y1, X2, Y2, C)
XS = 1
YS = 1
XI = 1
YI = 1
DX = X2 - X1
DY = Y2 - Y1
IF DX < 0 THEN XS = -1
IF DY < 0 THEN YS = -1
NX = ABS(DX)
NY = ABS(DY)
IF NX >= NY THEN
NP = NX
YI = NY / NX
ELSE
NP = NY
XI = NX / NY
END IF
FOR Q = 0 TO NP
X = X1 + XS * INT(Q * XI + .5)
Y = Y1 + YS * INT(Q * YI + .5)
PSET (X, Y), C
NEXT Q
END SUB
O.K. So first lets mention what is good about this routine. First the layout is almost perfect and second flow of control is good i.e. no spaghetti. Thirdly it does what it is supposed to do. So what's bad about it. Well the majority of the variable names are either one or two letters long which makes it a lot harder to understand than necessary. Apart from this it is *slow*. Its slow because it uses floating point routines instead of integer and it is not optimised at all. However, before we can optimise it we have to understand how it works. The first step to understanding how it works is too change the variable names to something more meaningful.
Code: (Select All)
CONST FromX = 10
CONST FromY = 10
CONST ToX = 310
CONST ToY = 190
SCREEN 13
_FullScreen _SquarePixels
FOR index = 1 TO 5
LINE (FromX, FromY)-(ToX, ToY), 15
Sleep
DigitalDifferenceEngine FromX, FromY, ToX, ToY, 12
Sleep
NEXT index
SLEEP
END
SUB DigitalDifferenceEngine (X1, Y1, X2, Y2, Colour)
DirectionX = 1
DirectionY = 1
XIncrement = 1
YIncrement = 1
DistanceX = X2 - X1
DistanceY = Y2 - Y1
IF DistanceX < 0 THEN DirectionX = -1
IF DistanceY < 0 THEN DirectionY = -1
NewDistanceX = ABS(DistanceX)
NewDistanceY = ABS(DistanceY)
IF NewDistanceX >= NewDistanceY THEN
NumberOfPoints = NewDistanceX
YIncrement = NewDistanceY / NewDistanceX
ELSE
NumberOfPoints = NewDistanceY
XIncrement = NewDistanceX / NewDistanceY
END IF
FOR PointNumber = 0 TO NumberOfPoints
X = X1 + DirectionX * INT(PointNumber * XIncrement + .5)
Y = Y1 + DirectionY * INT(PointNumber * YIncrement + .5)
PSET (X, Y), Colour
NEXT PointNumber
END SUB
So how does this work? First we set the variables that determine the direction that the line will be drawn in (i.e. up and to the right etc.) to one each. We also set the variables that determine the rate of change in both the X and Y directions, to one each. After this we determine the distance between the start and end points for both the X and Y directions. Having got a value for the distances we then test for these values being negative and if they are we correct the relevant direction variables to reflect this. We then make sure that we have positive values for both distance variables. We are now ready to determine how many points need to be set for our line. We do this by testing to see which of the two distance variables is the larger. Once we have determined this we set the number of points to be equal to the larger value. We also reduce the value held in the variable that determines the rate of change for the other direction. So if the distance between the 2 X coordinates is larger than that between the 2 Y coordinates we change the YIncrement variable. The new value that is assigned to this variable is less than one and is determined by dividing the smaller distance by the longer. We are now, finally, ready to draw our line. See if you can work out how the X and Y coordinates are finally determined in the body of the for-next loop.
OK so how do we go about optimising this? Well first we need to analyse it in a little more depth. Looking at it a bit more closely it becomes apparent that *both* the longest and shortest distances are important. We have already established that the longest distance is the number of pixels (-1) that we need to turn on for our line. The shortest distance is the number of times we need to alter our other coordinate. For example if the longest distance is in the X direction then we will need to change our Y coordinate DistanceY times. We can use this fact a little later to enable us to optimise our routine.
Now as our major concern is to speed this routine up, the most obvious change would be to convert it from floating point to integer because floating point operations are *slow* by comparison. This is easy enough until we get to the point where fractions are used. However there is a way around this. In order to illustrate this I will assume that the distance between the two X coordinates is the longest. Looking at our routine we can see that in this case our DistanceX corresponds to an IncrementX of precisely 1. What this does is to ensure that for every pass through our for-next loop, a new pixel is set in the X direction. We also see that our IncrementY is a fraction of 1. This means that it takes a more than 1 pass (except in one special case mentioned later) through our for-next loop before we change the Y coordinate of the pixels that we are setting. We can simulate this by use of a variable that holds an intermediate value. What we do is to assign a value of zero to this variable before we enter the for-next loop. Then on every pass through the loop we add the DistanceY to this variable and compare the result with our DistanceX. When the value in our variable equals or exceeds that of DistanceX we alter the Y coordinate and subtract the value of DistanceX from it.
We are now almost there. We can now (if we so desire) convert our line drawing routine from being floating point to integer. However there is still some optimisation we can do to our routine. Again the 2 distance variables are central to this. This is because there are some cases where we do not need to do any comparisons within the for-next loop. Remember, every time that we need to make a comparison we are using processor time. Fortunately these cases are easy enough to detect by examining the values of the 2 distance variables.
The first special case is detected when both distance variables hold the value zero. When this is the case it means that we are dealing with a single pixel that needs to set and not a line to be drawn so we can use PSET and return from our SUB.
The second case is where the DistanceX variable holds zero and DistanceY does not. This means that we need to draw a vertical line.
In the third case it is DistanceY that holds zero and DistanceX does not. In this case we need to draw a horizontal line.
The final special case is where neither distance variable holds zero but both contain the same value. This is where we need to draw a diagonal line at 45 degrees (at least in modes with square pixels). This means that for each new pixel there is a new X and Y coordinate pair.
This leaves the 2 cases that will be used most often. Where the DistanceX is greater than the DistanceY and where the DistanceY is greater than the DistanceX. As we have separated out the other 4 cases in the interests of speed optimisation it makes sense to do the same for this last pair of cases.
The final design decision that I have taken is to implement the whole thing as a number of SUBs. This makes it easier to test and also, I hope, easier to understand.
Code: (Select All)
CONST FromX = 10
CONST FromY = 10
CONST ToX = 310
CONST ToY = 190
SCREEN 13
_FullScreen _SquarePixels
FOR Index = 1 TO 5
LINE (FromX, FromY)-(ToX, ToY), 15
Sleep
DDE2 FromX, FromY, ToX, ToY, 12
Sleep
NEXT Index
SLEEP
END
SUB DDE2 (X1%, Y1%, X2%, Y2%, Colour%)
XLength% = X2% - X1%
XIncrement% = SGN(XLength%)
XLength% = XLength% * XIncrement%
YLength% = Y2% - Y1%
YIncrement% = SGN(YLength%)
YLength% = YLength% * YIncrement%
IF XLength% = 0 AND YLength% = 0 THEN
PSET (X1%, Y1%), Colour%
ELSEIF XLength% = YLength% THEN
Do45Degrees X1%, Y1%, XIncrement%, YIncrement%, XLength%, Colour%
ELSEIF XLength% = 0 THEN
DoVertical X1%, Y1%, Y2%, YIncrement%, Colour%
ELSEIF YLength% = 0 THEN
DoHorizontal X1%, X2%, Y1%, XIncrement%, Colour%
ELSEIF XLength% > YLength% THEN
XGreater X1%, Y1%, XLength%, YLength%, XIncrement%, YIncrement%, Colour%
ELSE
YGreater X1%, Y1%, XLength%, YLength%, XIncrement%, YIncrement%, Colour%
END IF
END SUB
SUB Do45Degrees (XStart%, YStart%, XIncrement%, YIncrement%, Length%, Colour%)
X% = XStart%
Y% = YStart%
PSET (X%, Y%), Colour%
FOR Index% = 1 TO Length%
X% = X% + XIncrement%
Y% = Y% + YIncrement%
PSET (X%, Y%), Colour%
NEXT Index%
END SUB
SUB DoHorizontal (X1%, X2%, Y%, XIncrement%, Colour%)
FOR X% = X1% TO X2% STEP XIncrement%
PSET (X%, Y%), Colour%
NEXT X%
END SUB
SUB DoVertical (X%, Y1%, Y2%, YIncrement%, Colour%)
FOR Y% = Y1% TO Y2% STEP YIncrement%
PSET (X%, Y%), Colour%
NEXT Y%
END SUB
SUB XGreater (XStart%, YStart%, XLength%, YLength%, XIncrement%, YIncrement%, Colour%)
X% = XStart%
Y% = YStart%
ChangeY% = 0
PSET (X%, Y%), Colour%
FOR Index% = 1 TO XLength%
X% = X% + XIncrement%
ChangeY% = ChangeY% + YLength%
IF ChangeY% >= XLength% THEN
Y% = Y% + YIncrement%
ChangeY% = ChangeY% - XLength%
END IF
PSET (X%, Y%), Colour%
NEXT Index%
END SUB
SUB YGreater (XStart%, YStart%, XLength%, YLength%, XIncrement%, YIncrement%, Colour%)
X% = XStart%
Y% = YStart%
ChangeX% = 0
PSET (X%, Y%), Colour%
FOR Index% = 1 TO YLength%
Y% = Y% + YIncrement%
ChangeX% = ChangeX% + XLength%
IF ChangeX% >= YLength% THEN
X% = X% + XIncrement%
ChangeX% = ChangeX% - YLength%
END IF
PSET (X%, Y%), Colour%
NEXT Index%
END SUB
Finally a few notes.
IMPORTANT - There is absolutely *no* error detection in either routine! So be careful and add them in yourself. This was done for clarity.
At this point you may be saying 'But QB already has a LINE command, why do we need another one? Not only that, but this new line does less than the built in one!' True, but the built-in commands won't work with any of the varieties of modex. And what happens if for some reason you need to write a line drawing routine in some other language say assembly? Well now you've got an algorithm that you can use.
Once you've run these routines you may be saying 'Well it appears to work but it doesn't draw exactly the same line as the built-in routine.' True again <g>. This just shows that there are a number of different algorithms that can be used to achieve the same end. I strongly suspect that the built-in routine is a variety of the more commonly used Bresenham algorithm. Because the Bresenham algorithm has error-correction built-in it draws a more accurate line, but this can slow the drawing down. Even though the Bresenham algorithm is more accurate both algorithms start and end at exactly the same point, so the choice is yours <g>.
Posted by: Pete - 05-08-2022, 06:11 PM - Forum: Programs
- No Replies
I built a game called Pecos Pete Poker around a couple of decades ago. I recently updated it to play on QB64, and I also got together with TheBOB who offered his graphics playing cards if I wanted to make a graphics version. I've been working on that, and since I love reinventing the wheel, I came up with a completely new poker hand evaluator to go with it. This hand evaluation model is written in SCREEN 0 but can be converted to evaluate graphics hands, which I'll work on next week.
You need jacks or better to display a "Pair" with a payout. Other lesser pairs are marked in grey. Press Enter or any non-number key to draw the next hand. Since it takes awhile to get hands like 4 of a kind, and especially a royal flush, I put number buttons in a menu. Press 1 to wait on a royal flush, 2 for a straight flush, 3 for 4 of a kind, 4 for a full house, etc. Press esc if you get tired of waiting, it will go back to one at a time display.
Code: (Select All)
' Jacks or better poker evaluator demo.
' Use keys 1 - 9 to search for particular hands, Royal Flush, Full HOuse, etc.
sw% = 55
sh% = 17
WIDTH sw%, sh%
PALETTE 7, 63
COLOR 0, 7: CLS
fontpath$ = ENVIRON$("SYSTEMROOT") + "\fonts\lucon.ttf"
font& = _LOADFONT(fontpath$, 40, "monospace")
_FONT font&
_DELAY .25
_SCREENMOVE 0, 0
msg$ = "Poker Hand Evaluator"
LOCATE 1, (sw% / 2) - (LEN(msg$) / 2): PRINT msg$;
msg$ = "Any Key or 1=RF 2=SF 3=4K 4=FH 5=F 6=S 7=3K 8=2P 9=P"
LOCATE sh%, (sw% / 2) - (LEN(msg$) / 2): PRINT msg$;
VIEW PRINT 3 TO sh% - 2: LOCATE 4, 1
h = 1 ' Number of hands.
noc = 5 ' Number of card.
DO
REDIM cardID$(1, 5)
REDIM taken(5)
taken(3) = 13: taken(4) = 26: taken(5) = 39
FOR i = 1 TO noc
DO
card = INT(RND * 52) + 1
FOR j = 1 TO i
IF taken(j) = card THEN flag = -1: EXIT FOR
NEXT
IF flag = 0 THEN taken(i) = card: EXIT DO ELSE flag = 0
LOOP
cardID$(h, i) = LTRIM$(STR$(y)) + "|" + LTRIM$(STR$(scol + (i - 1) * 120 + x)) + "#" + LTRIM$(STR$(card))
NEXT
IF POS(0) > 3 OR CSRLIN > 4 THEN PRINT: PRINT: PRINT: LOCATE CSRLIN - 1
LOCATE , 3
FOR j = 1 TO 5
a = VAL(MID$(cardID$(h, j), INSTR(cardID$(h, j), "#") + 1))
a1 = (a - 1) MOD 13 + 1
x$ = LTRIM$(STR$(a1))
b = (a + 12) \ 13
suite$ = CHR$(2 + b)
REM PRINT x$; suite$; " ";
IF suite$ = CHR$(3) OR suite$ = CHR$(4) THEN COLOR 4 ELSE COLOR 0
SELECT CASE VAL(x$)
CASE 1: PRINT "A"; suite$; " ";
CASE 13: PRINT "K"; suite$; " ";
CASE 12: PRINT "Q"; suite$; " ";
CASE 11: PRINT "J"; suite$; " ";
CASE 10: PRINT "10"; suite$; " ";
CASE ELSE: PRINT LTRIM$(STR$(VAL(x$))); suite$; " ";
END SELECT
NEXT
GOSUB eval
COLOR 1
LOCATE , 28
IF hand$ = "Pair" THEN
IF highkind >= 11 THEN COLOR 1: PRINT hand$; " (Pay Out)"; ELSE COLOR 8: PRINT hand$;
ELSE
PRINT hand$;
END IF
COLOR 1
IF search$ = "" THEN GOSUB getkey ELSE IF INKEY$ = CHR$(27) THEN search$ = ""
IF LEN(search$) THEN
IF hand$ = search$ THEN SLEEP: search$ = ""
END IF
LOOP
END
eval:
hand$ = ""
DO
' Look for flush, same suit.
samesuit = 0
FOR j = 1 TO noc
a = VAL(MID$(cardID$(h, j), INSTR(cardID$(h, j), "#") + 1))
b = (a + 12) \ 13
IF j > 1 AND b <> samesuit THEN flag = -1: EXIT FOR
samesuit = b
NEXT
IF flag = 0 THEN
' Flush or better.
hand$ = "Flush"
ELSE
flag = 0
END IF
' Look for staright, sequential order.
high = 0: low = 0: match$ = ""
FOR j = 1 TO noc
a = VAL(MID$(cardID$(h, j), INSTR(cardID$(h, j), "#") + 1))
a1 = (a - 1) MOD 13 + 1
match$ = match$ + CHR$(a1 + 64)
NEXT
IF INSTR(match$, CHR$(1 + 64)) THEN
IF INSTR(match$, CHR$(13 + 64)) THEN high = 14 ' Ace high straight possible.
END IF
FOR j = 1 TO noc
a = VAL(MID$(cardID$(h, j), INSTR(cardID$(h, j), "#") + 1))
a1 = (a - 1) MOD 13 + 1
IF j > 1 AND INSTR(match$, CHR$(a1 + 64)) <> j THEN match$ = "": EXIT FOR
IF low = 0 OR low > a1 THEN
IF a1 = 1 AND high = 14 THEN ELSE low = a1
END IF
IF high = 0 OR high < a1 THEN high = a1
NEXT
IF LEN(match$) AND high - low = noc - 1 THEN
IF hand$ = "Flush" THEN
IF high = 14 THEN
hand$ = "Royal Flush"
ELSE
hand$ = "Straight Flush": EXIT DO
END IF
ELSE
hand$ = "Straight": EXIT DO
END IF
END IF
' Look for number of kinds.
kinds = 1: highkind = -1
FOR j = 1 TO noc
kindcnt = 0
a = VAL(MID$(cardID$(h, j), INSTR(cardID$(h, j), "#") + 1))
a1 = (a - 1) MOD 13 + 1
IF a1 = 1 THEN ' Convert ace high.
a1 = 14
'' cardID$(h, j) = MID$(cardID$(h, j), 1, INSTR(cardID$(h, j), "#")) + "14"
END IF
FOR k = 1 TO noc
IF j <> k THEN
IF a1 = (VAL(MID$(cardID$(h, k), INSTR(cardID$(h, k), "#") + 1)) - 1) MOD 13 + 1 OR a1 = 14 AND (VAL(MID$(cardID$(h, k), INSTR(cardID$(h, k), "#") + 1)) - 1) MOD 13 + 1 = 1 THEN
kindcnt = kindcnt + 1: IF highkind < a1 OR highkind = 0 THEN highkind = a1
END IF
END IF
IF kinds <= kindcnt THEN kinds = kindcnt + 1
NEXT k
NEXT j
IF kinds = 4 THEN hand$ = "Four of a Kind": EXIT DO
IF kinds = 3 THEN ' Look for full house.
kinds = 0
FOR j = 1 TO noc
kindcnt = 0
a = VAL(MID$(cardID$(h, j), INSTR(cardID$(h, j), "#") + 1))
a1 = (a - 1) MOD 13 + 1
FOR k = 1 TO noc
IF j <> k AND a1 <> highkind THEN
IF a1 = (VAL(MID$(cardID$(h, k), INSTR(cardID$(h, k), "#") + 1)) - 1) MOD 13 + 1 THEN
kindcnt = kindcnt + 1
END IF
END IF
NEXT k
IF kinds < kindcnt THEN kinds = kindcnt + 1
NEXT j
IF kinds = 2 THEN
hand$ = "Full House": EXIT DO
ELSE
hand$ = "Three of a Kind": EXIT DO
END IF
END IF
IF kinds = 2 THEN
' Look for two pair.
kinds = 0
FOR j = 1 TO noc
kindcnt = 0
a = VAL(MID$(cardID$(h, j), INSTR(cardID$(h, j), "#") + 1))
a1 = (a - 1) MOD 13 + 1
FOR k = 1 TO noc
IF j <> k AND a1 <> highkind THEN
IF a1 = 1 AND highkind = 14 THEN
' Checks for ace as 1 here after previous highkind converion to 14.
ELSE
IF a1 = (VAL(MID$(cardID$(h, k), INSTR(cardID$(h, k), "#") + 1)) - 1) MOD 13 + 1 THEN
kindcnt = kindcnt + 1
END IF
END IF
END IF
NEXT k
IF kinds < kindcnt THEN kinds = kindcnt + 1
NEXT j
IF kinds = 2 THEN
hand$ = "Two Pair": EXIT DO
ELSE
hand$ = "Pair": EXIT DO
END IF
END IF
EXIT DO
LOOP
RETURN
getkey:
DO
_LIMIT 30
b$ = INKEY$
IF LEN(b$) THEN
IF b$ = CHR$(27) THEN SYSTEM
IF b$ >= "1" AND b$ <= "9" THEN
SELECT CASE VAL(b$)
CASE 1: search$ = "Royal Flush"
CASE 2: search$ = "Straight Flush"
CASE 3: search$ = "Four of a Kind"
CASE 4: search$ = "Full House"
CASE 5: search$ = "Flush"
CASE 6: search$ = "Straight"
CASE 7: search$ = "Three of a Kind"
CASE 8: search$ = "Two Pair"
CASE 9: search$ = "Pair"
END SELECT
EXIT DO
END IF
EXIT DO
END IF
LOOP
RETURN
Remade from an old game which I found in a magazine sitting dusty back on my shelves.
Code: (Select All)
Randomize Timer
start:
Cls
Color 7
Print "Welcome to STARS -- a remake of an Atari-BASIC game from the 80s!"
Print
Print "The rules are simple: I'm going to generate a number from 1 to 100, and you "
Print "have to guess it."
Print
Print "You have 7 tries to guess my number, and I'll offer you feedback in the form of "
Print "stars (*), depending on how close you are to my number."
Print
Print "If you're really close, I'll give you 7 stars (*******)."
Print "If you're really off from my number, I'll give you 1 star (*)."
Print "The more stars I give you, the closer you are to guessing my number!"
Print
Color 4
Print "Are you ready to begin? (Yes/Quit)"
Do
a$ = UCase$(Input$(1))
If a$ = "Q" Then System
Loop Until a$ = "Y"
num = Int(Rnd * 100) + 1
For i = 1 To 7
Color 7
Print "Give me your guess #"; i; "=>";
Input ; guess
Color 4
Select Case Abs(num - guess)
Case Is >= 64: Print "*"
Case Is >= 32: Print "**"
Case Is >= 16: Print "***"
Case Is >= 8: Print "****"
Case Is >= 4: Print "*****"
Case Is >= 2: Print "******"
Case Is = 1: Print "*******"
Case Is = 0
Print "You got it in "; i; "guesses!"
GoTo endchoice
End Select
Color 7
Next
Print "You failed to guess my number! It was "; num
endchoice:
Print
Color 4
Print "Press <Any Key> to restart"
_Delay 1
_KeyClear
Sleep
Color 7
GoTo start
Try to play without reading the source first. Once you read the source and know *exactly* what those stars represent, all the challenge goes out of the game.
It feels great that QB64 is once again alive and well. I'm not sure if it's realistic of me to expect it to be around FOREVER. I do have grand children who are now leaning to code at school and asking me questions. I hope to turn them onto QB64 basic language.
Given how we almost lost everything, I was wondering if there may be some kind of steps or ideas we should be considering that not only can avoid (if not just tone down) fatal arguments and perhaps we should also consider ways we can support key development members who may need a break or even retire. A way QB64 lives on after we are gone.
I guess ... once burned, twice shy ... being the selfish person I am, I'd hate to lose you all again.
Useful links QB64 : this would be the right place to post them
after converting the copy of the old forum unfortunately not complete in pdf format. then in text format. i assembled all the files in a single text file of about 200 mo. i have access to a lot of data on qb64. i found a lot of interesting links. i will post them here. if you have others. do the same :
From back in the day and made to work in QB64. All six are just the top level of each of the fractals. Of the six, three are not really suitable for zooming in.
It is said that Benois Mandlebrot used the Cantor Dust fractal to illustrate (to a group of electronic engineers) why just increasing the power of transmitted signals wouldn't illiminate the "random" errors they were observing but that some form of error checking would need to be devised.
Cantor.BAS (Not Zoom)
Code: (Select All)
Const Left = 1
Const Right = 640
Screen 2
_FullScreen _SquarePixels
Cls
CantorDust Left, Right, 1
End
Sub CantorDust (Start, Finish, Level)
Y = Level * 20
Line (Start, Y)-(Finish, Y), 1
Length = Finish - Start
If Length < 2 Then
Exit Sub
End If
Third = Length / 3
A = Start + Third - 1
B = 1 + Finish - Third
CantorDust Start, A, Level + 1
CantorDust B, Finish, Level + 1
End Sub
The second one is the Henon Fractal. This one achieves variety by asking you to input a number. For an interesting result try the value of PI. Not Zoom.
Henon.BAS
Code: (Select All)
xc = 320
yc = 240
xmul = 400
ymul = 360
Cls
Input "Enter the value for a"; a
Screen 12
_FullScreen _SquarePixels
Cls
For x = -.1 To .8 Step .05
For y = -.1 To .8 Step .05
x1 = x
y1 = y
For i% = 1 To 1000
If x1 > 1000 Or y1 > 1000 Or x1 < -1000 Or y1 < -1000 Then
i% = 1000
Else
ca = Cos(a)
sa = Sin(a)
yy = y1 - x1 * x1
xx = x1 * ca - yy * sa
y1 = x1 * sa + yy * ca
x1 = xx
PSet (xc + (x1 * xmul), yc + (y1 * ymul)), (i% Mod 17)
End If
Next i%
Next y
Next x
If you have a slow machine you may want to edit this one. That is because there is a FOR NEXT loop in it, that loops 20,000,000 times. That number is high in order to show most of the finer detail of this fractal. Watching as it builds has somewhat of a retro feel. Again don't bother adding a zoom feature.
Ikida.BAS
Code: (Select All)
x = 0
y = 0
p = 7.7
colour = 16
xc = 435
yc = 270
xmul = 240
ymul = 180
MaxColour = 16
Screen 12
_FullScreen _SquarePixels
Cls
For n& = 1 To 20000000
theta = .4 - (p / (1 + (x * x + y * y)))
ctheta = Cos(theta)
stheta = Sin(theta)
Point9x = .9 * x
Point9y = .9 * y
x1 = .85 + Point9x * ctheta - Point9y * stheta
y1 = Point9x * stheta + Point9y * ctheta
PSet (xc + (xmul * -x1), yc + (ymul * y1)), colour
x = x1
y = y1
colour = colour + 1
If colour > MaxColour Then
colour = 1
End If
Locate 6, 1
Print "Iterations = ";
Print Using "##,###,###"; n&;
Next n&
Next, here is the classic Mandlebrot fractal. You can add a zoom to this one if you want.
AngleR = -2
AngleL = -1.25
Side = 2.5
DistanceX = Side / MaxX%
DistanceY = Side / MaxY%
Screen 12
_FullScreen _SquarePixels
Cls
For Y = 1 To MaxY%
For X = 1 To MaxX%
CR = X * DistanceX + AngleR
CL = Y * DistanceY + AngleL
ZR = CR
ZL = CL
Iteration% = 0
Do
A = ZR * ZR
B = ZL * ZL
Length = A + B
ZL = 2 * ZR * ZL + CL
ZR = A - B + CR
Iteration% = Iteration% + 1
Loop Until Length > BailOut Or Iteration% > MaxIterations%
col = Iteration% Mod MaxCol%
PSet (X, Y), col
Next X
Next Y
It is said that for each chaotic point on a Mandlebrot fractal, there is a corresponding Julia fractal. Here is one -
AngleR = -2
AngleL = -1.25
CR = -1
CL = -.625
Side = 2.5
DistanceX = Side / MaxX%
DistanceY = Side / MaxY%
Screen 12
_FullScreen _SquarePixels
Cls
For Y = 1 To LastY%
For X = 1 To LastX%
ZR = X * DistanceX + AngleR
ZL = Y * DistanceY + AngleL
Iteration% = 0
Do
A = ZR * ZR
B = ZL * ZL
Length = A + B
ZL = 2 * ZR * ZL + CL
ZR = A - B + CR
Iteration% = Iteration% + 1
Loop Until Length > BailOut Or Iteration% > MaxIterations%
col = Iteration% Mod MaxCol%
PSet (X, Y), col
Next X
Next Y
Finally we have a pseudo fractal. At least the creator of this said that they didn't think it was really a fractal. You be the judge. A zoom feature can certainly be added and values tweaked repeatedly in order to make an animation.
Topham.BAS
Code: (Select All)
Screen 12
_FullScreen _SquarePixels
Cls
xpos = 320
ypos = 240
across = 640
down = 480
a = -1.5
b = -.5
c = 2.4
d = -.45
e = .5
xmin = -3.5
xmax = 4.5
ymin = -2
ymax = 2
maxiter = 70
cresh = 500
dx = (xmax - xmin) / across
dy = (ymax - ymin) / down
For ynn = 1 To down
For xnn = 1 To across
k = 0
xn = xmin + dx * xnn
yn = ymin + dy * ynn
Do
k = k + 1
xnsqr = xn * xn
ynsqr = yn * yn
If (xnsqr + ynsqr) > cresh Then
GoSub PlotPoint
Exit Do
End If
If k > maxiter Then
Exit Do
End If
xm = a + b * xn + c * ynsqr
yn = d + e * xn
xn = xm
Loop
Next xnn
Next ynn
End
PlotPoint:
Select Case (k Mod 7) + 1
Case 1
col = 12
Case 2
col = 10
Case 3
col = 14
Case 4
col = 9
Case 5
col = 15
Case 6
col = 11
Case 7
col = 13
End Select
PSet (xpos - .5 * across + xnn, ypos - .5 * down + ynn), col
Return
EDIT May 9, 2022: I have a new release that fixes one bug that could cause the dynamic font resizing to pick a font slightly smaller than the optimal. In addition, I created a new feature limited screensaver version of the program intended specifically to be used as a screensaver. That update, including the new screensaver edition, as well as all future updates can now be found on my GitHub page:
EDIT: You will want to remove the following line from the code since you won't have an icon for the program:
$ExeIcon:'WordClock.ico'
End Edit
This program was inspired by my favorite screensaver of all time; Word Clock, by Simon Heys. Unfortunately, that screensaver no longer works in Windows. For years now I have wondered how difficult it would be to make a program that was similar to that screensaver. I finally sat down a few days ago and created a proof of concept. It worked flawlessly and was a lot easier than I had expected, so I set about refining it and making it into the program you see here.
The program will display the time as a series of words on your screen with all months, days of the week, etc. being displayed, but only those reflecting the current time being highlighted.
By default, the program will open in full screen mode and will include a digital clock displayed on the last line of the screen. These, as well as other settings, can be altered by hotkeys as well as a file named WordClock.ini.
To use the program, simply run the executable. If you plan to use the WordClock.ini file, place it in the same folder with the program.
In windowed mode, you are free to resize the window. The font size will be dynamically adjusted to make best use of the available space.
Hotkeys
-------
The following hotkeys are available:
D : Toggle the digital display at the bottom of the screen on and off
F : Toggle in and out of fullscreen mode
H : Display program help
S : Display statistics / current values in use by the program
Any other Key will exit the program
Using the WorkClock.ini file
----------------------------
The following are examples of entries that can be placed in the WordClock.ini. Any settings in this file will override the default settings in the program.
: This is a comment - Comments start with a ":" as the first character and are ignored by the program.
: Windowed mode entries
Font:lucon.ttf - The font to be used in windowed mode. Font name only, no path.
Fontsize:14 - * Size of font used in windowed mode.
WindowHorizontal:800 - Horizontal resolution (width) used in windowed mode.
WindowVertical:600 - Vertical resolution (height) used in windowed mode.
: Full screen mode entries
FullscreenFont:lucon.ttf - The font to be used in fullscreen mode. Font name only, no path.
FullscreenFontSize:32 - * Size of font used in fullscreen mode.
StartFullscreen:Y - Specify Y to start in fullscreen mode, N to start windowed.
: Other entries
ShowDigitalTime:Y - Display the digital time on the last line of the screen.
HandleErrors:Y - Enables the error handling routies. Disable if you need to see original QB64 error message(s).
* Note that the program now dynamically adjusts the font size so the font size entries are obsolete. However, they may still
serve one purpose: When the program begins performing dynamic adjustment of the font size, it will use the specified font
size as a starting point. If you have an especially large monitor and a very large font is needed, specifying a font that
is precisely correct, or just close, may enable the dynamic adjustment to determine a solution more quickly.
Future Plans
------------
This a "1.0" release of the program. In the future, I hope to make some improvements such as adding the ability to modify colors and maybe allow for other types of information rather than a digital clock to be displayed on the bottom line.
In addition, I should have a slimmed down version ready to be used as a screensaver in a few days.
Code: (Select All)
Option _Explicit
Option Base 1
' Hannes' Word Clock
' 2022 by Hannes Sehestedt
' Version 1.0.0.5
' May 7, 2022
$ExeIcon:'WordClock.ico'
$VersionInfo:CompanyName=Hannes Sehestedt
$VersionInfo:FILEVERSION#=1,0,0,5
$VersionInfo:ProductName=Hannes Word Clock
$VersionInfo:LegalCopyright=(c) 2022 by Hannes Sehestedt
$Resize:On
ProgramStart:
' In the event that we need to restart the program as a result of an error, we will clear all current
' variables and start over completely clean
Clear
Dim AdjustmentsMade As String ' Flag to indicate that screen resolution adjustments were made automatically to avoid illegal conditions
Dim AllText As String ' Contains a copy of all text that will be displayed on screen. Used to test font sizes.
Dim AM_PM As String ' This flag will be set to either "AM" or "PM"
Dim CharPerLine As Integer ' Number of characters that can fit on a line at a given screen and font size
Dim CharPosition As Integer ' Used to keep track of character positioning while manipulating strings
Dim CurrentDate As String ' Hold the entire date (Month / Day / Year) as a string
Dim CurrentMode As String ' Tracks the current mode. "Y" for fullscreen mode, "N" for windowed mode.
Dim CurrentTime As String ' Hold the entire time (Hours / Minutes / Seconds) as a string
Dim Day As Integer ' Day of the month (1-31) as a number
Dim DayOfWeek As Integer ' Day of the week (1-7) as a number
Dim DayOfWeekString(7) As String ' An array holding each day of the week as an English word
Dim DayString(31) As String ' An array holding each day of the month (1-31) as a string
Dim Decade As Integer ' The numerical value of the last 2 digits of the year
Dim DeskWidth As Long ' The width of the desktop in pixels
Dim DeskHeight As Long ' The height of the desktop in pixels
Dim DigitalHour As String ' Hours converted to a 2 digital string
Dim ff As Integer ' Used to store free file number
Dim FileLine As String ' Line read from a file
Dim Font As Long ' Handle to a font
Dim FontHeight As Integer ' Height of a font in windowed mode
Dim FontPath As String ' The name of the font, with path, used in windowed mode
Dim FontSize As Integer ' The fontsize used in windowed mode
Dim FontSizeToTest As Integer ' In the routine that tests fit of a font on the screen, this holds the current font size to be tested
Dim FontTooLarge As String ' Flag to indicate when a font is too large to properly display all text
Dim FontWidth As Integer ' Width of a font in windowed mode
Dim FullscreenFontHeight As Integer
Dim FullscreenFontPath As String ' The name of the font, with path, used in fullscreen mode
Dim FullscreenFontSize As Integer ' The fontsize used in fullscreen mode
Dim FullscreenFontWidth As Integer ' Width of a font in fullscreen mode
Dim handle As Long ' Stores a handle to the screen
Dim HandleErrors As String ' If set to "Y" then error handling is enabled, otherwise it is disabled
Dim High As Integer ' The height of a font undergoing testing to see if it allows text to properly fit on screen
Dim Horizontal As Integer ' The horizontal resolution used in windowed mode
Dim Hour As Integer ' Numerical value holding the current hour (0-23)
Dim HourString(12) As String ' The current hour as an English word. Since we use AM / PM this holds only one through twelve.
Dim KeyPress As String ' Used to sore keystrokes from Inkey$
Dim LeapYear As Integer ' To to indicate if current year is a leap year. 1 = Leap Year, 0 = No Leap Year
Dim LineCount As Integer ' In the routine to set font sizes, this keeps track of how many lines of text a given font size will occupy
Dim MaxLines As Integer ' The maximum number of lines of text that will fit on the screen at a given screen and font size
Dim Minute As Integer ' The current minute as a numeral from 0 to 59
Dim MinuteString(59) As String ' An array hold minutes as English words from one to fifty-nine
Dim Month As Integer ' The current month as a number from 1 to 12
Dim MonthString(12) As String ' The current month as an English word (January, February, ... , November, December).
Dim MonthTable(12) As Integer ' A table with an offset for each month used to calculate what day of the week it is (Monday, Tuesday, etc).
Dim oldimage As Long ' holds the handle of a screen that is about to be removed from memory
Dim OldSecond As Integer ' A variable that is used to determine if the seconds have changed from the last time we checked
Dim ProgramVersion As String ' Holds the current program version
Dim Result1 As Integer ' A temporary variable
Dim Result2 As Integer ' A temporary variable
Dim Result3 As Integer ' A temporary variable
Dim Second As Integer ' The current seconds as a number (0-59)
Dim SecondString(59) As String ' The current seconds as an English word from one through fifty-nine
Dim ShowDigitalTime As String ' Set to "Y" to show digital time on the last line of the screen
Dim StartFullscreen As String ' Set to "Y" to start the program in fullscreen mode, "N" to start in windowed mode
Dim Temp As Integer ' A temporary variable
Dim Temp2 As Integer ' A temporary variable
Dim TempString As String ' A temporary string of characters, used mainly in string manipulation routines
Dim Vertical As Integer ' Vertical resolution used in windowed mode
Dim Wide As Integer ' The width of a font undergoing testing to see if it allows text to properly fit on screen
Dim x As Integer ' General purpose counter used in FOR...NEXT loops
Dim Year As Integer ' Stores the current year
ProgramVersion$ = "1.0.0.5"
_Title "Hannes' Word Clock " + ProgramVersion$
' Default values used for entries not available from a .ini file and initialization of other variables
' If a .ini file exists, open it and parse it. Values found in the .ini will override the defaults
' defined above.
If _FileExists("WordClock.ini") Then
ff = FreeFile
Open "WordClock.ini" For Input As #ff
Do Until EOF(ff)
Line Input #ff, FileLine$
' If line starts with a colon (:), it is a comment. Ignore it.
If Left$(FileLine$, 1) = ":" Then _Continue
' If line starts with "FONT:" then we are reading in the name of the font to be used. This is NOT case sensitive.
If UCase$(Left$(FileLine$, 5)) = "FONT:" Then
FontPath$ = Environ$("SYSTEMROOT") + "\fonts\" + Right$(FileLine$, (Len(FileLine$) - 5))
End If
' If line starts with "FONTSIZE:" then we are reading in the size of the font to be used. This is NOT case sensitive.
If UCase$(Left$(FileLine$, 9)) = "FONTSIZE:" Then
FontSize = Val(Right$(FileLine$, (Len(FileLine$) - 9)))
End If
' If line starts with "FULLSCREENFONT:" then we are reading in the name of the font to be used
' in fullscreen mode. This is NOT case sensitive.
If UCase$(Left$(FileLine$, 15)) = "FULLSCREENFONT:" Then
FullscreenFontPath$ = Environ$("SYSTEMROOT") + "\fonts\" + Right$(FileLine$, (Len(FileLine$) - 15))
End If
' If line starts with "FULLSCREENFONTSIZE:" then we are reading in the size of the font to be used
' in fullscreen mode. This is NOT case sensitive.
If UCase$(Left$(FileLine$, 19)) = "FULLSCREENFONTSIZE:" Then
FullscreenFontSize = Val(Right$(FileLine$, (Len(FileLine$) - 19)))
End If
' If line starts with "WINDOWHORIZONTAL:", use value to set the horizontal window size.
If UCase$(Left$(FileLine$, 17)) = "WINDOWHORIZONTAL:" Then
Horizontal = Val(Right$(FileLine$, (Len(FileLine$) - 17)))
End If
' If line starts with "WINDOWVERTICAL:", use value to set the vertical window size.
If UCase$(Left$(FileLine$, 15)) = "WINDOWVERTICAL:" Then
Vertical = Val(Right$(FileLine$, (Len(FileLine$) - 15)))
End If
' If line starts with "STARTFULLSCREEN:", read value that will determine if the program is to be
' started fullscreen or in a window.
If UCase$(Left$(FileLine$, 16)) = "STARTFULLSCREEN:" Then
StartFullscreen$ = UCase$(Right$(FileLine$, (Len(FileLine$) - 16)))
End If
' If line starts with "SHOWDIGITALTIME:", read value that will determine if digital time is
' to be displayed on the last line of the screen.
If UCase$(Left$(FileLine$, 16)) = "SHOWDIGITALTIME:" Then
ShowDigitalTime$ = UCase$(Right$(FileLine$, (Len(FileLine$) - 16)))
End If
' If line starts with "HANDLEERRORS:", read value that will determine if error handling is to be
' enabled or not.
If UCase$(Left$(FileLine$, 13)) = "HANDLEERRORS:" Then
HandleErrors$ = UCase$(Right$(FileLine$, (Len(FileLine$) - 13)))
End If
Loop
Close #ff
' If HandleErrors$ is set to "Y" then enable error handling
If HandleErrors$ = "Y" Then
On Error GoTo HandleErrors
End If
End If
' Setup screen for either fullscreen or windowed mode
' Read the spelled out version of various elements into arrays. This will save time later so that we don't have to constantly
' parse this over and over in out main program loop.
Restore DayOfWeek
For x = 1 To 7
Read DayOfWeekString$(x)
Next x
Restore Day
For x = 1 To 31
Read DayString$(x)
Next x
Restore Month
For x = 1 To 12
Read MonthString$(x)
Next x
Restore Hour
For x = 1 To 12
Read HourString$(x)
Next x
Restore Minute
For x = 1 To 59
Read MinuteString$(x)
Next x
Restore Second
For x = 1 To 59
Read SecondString$(x)
Next x
Restore MonthTable
For x = 1 To 12
Read MonthTable(x)
Next x
Cls
' Clear the keyboard buffer before we enter the main program loop.
Do While InKey$ <> ""
Loop
' This is the main loop that retrieves the date and time, breaks it down into individual components, and then
' displays the time and date in words.
Do
_Limit 60 ' Limit the number of times that we perform this loop to a maximum of 60 iterations per second
If _Resize Then
'If we are NOT running fullscreen, then resize the screen appropriately.
If (_ResizeWidth <> _DesktopWidth) And (_ResizeHeight <> _DesktopHeight) Then
Horizontal = _ResizeWidth: Vertical = _ResizeHeight
oldimage& = handle&
handle& = _NewImage(Horizontal, Vertical, 256)
Screen handle&
_FullScreen _Off
_FreeImage oldimage&
Sleep 1
GoSub FindLargestFontSize
Font& = _LoadFont(FontPath$, FontSize, "MONOSPACE")
_Font Font&
High = _FontHeight
Wide = _FontWidth
MaxLines = Int(Vertical / High)
FontWidth = _FontWidth
FontHeight = _FontHeight
End If
End If
' The lines below check for any keypresses. If a hotkey is pressed, then we take the appropriate action.
' Pressing any other key will exit the program. This is most useful when the program is being used as a
' screensaver.
KeyPress$ = InKey$
Select Case KeyPress$
Case ""
Exit Select
' The lines commented out below are for testing purposes. When enabled, the allow the use of the
' "+" and "-" keys to increase and decrease the font size. Since the program now employs automatic
' font resizing, this should no longer be needed.
' At the end of the loop that displays the time on the screen, we set OldSecond to the current seconds. When we reach
' this point again, if the current seconds are still the same, we skip the display process since there are no changes.
' If the seconds have changed, then proceed with updating the display.
If (OldSecond = Second) Then GoTo DisplayFinished
' Calculate the day of the week
' IMPORTANT: The calculations below are valid through 2099.
' Step 1: Add the day of the month and the number from the month table. We will read the values from the month table.
Temp = Day + MonthTable(Month)
' Step 2: If the number calculated above is greater than 6, then subtract the highest multiple of 7 from this number.
If Temp > 6 Then
Temp2 = Int(Temp / 7)
Temp = Temp - (Temp2 * 7)
End If
Result1 = Temp
' Step 3: From the last two digits of the year, subtract the year that has the highest multiple of 28.
Temp = Decade
If Decade > 27 Then
Temp2 = Int(Temp / 28)
Temp = Decade - (Temp2 * 28)
End If
Result2 = Temp
' Step 4: Take the last 2 digits of the year, divide by 4, and drop anything after the decimal point. Add that value to Result2.
Temp = 0
If Decade > 3 Then
Temp = Int(Decade / 4)
End If
Result3 = Result2 + Temp
' Step 5: If the month is Jan or Feb AND the year is a leap year, subtract 1 from Result3.
If Month < 3 Then
If (Year / 4) = (Int(Year / 4)) Then
LeapYear = 1
Else
LeapYear = 0
End If
Result3 = Result3 - LeapYear
End If
' Step 6: Add Result1 and Result3. Subtract the highest multiple of 7. The result will be 0-6 with 0 being Sat, and 6 being Fri.
Result3 = Result3 + Result1
If Result3 > 6 Then
Temp = Int(Result3 / 7)
Result3 = Result3 - (Temp * 7)
End If
' To make handling easier, we will add 1 to result so that the day of the week will now be a number from 1 to 7. The
' end result is that Sat = 1, Fri = 7.
DayOfWeek = Result3 + 1
' End calculation of the day of the week.
' Set the default color of items printed to the screen to grey on black. Current values will be highlighted.
' Currently, this means white text on a red background, but we intend to allow customization later in a future
' version of the program. For now, we are simply hard coding it.
Locate 1, 1
Color 8, 0
' Print all days of the week
For x = 1 To 7
If x = DayOfWeek Then
Color 15, 4: Print DayOfWeekString$(x);: Color 8, 0: GoSub LeftJustify
Else
Print DayOfWeekString$(x);: GoSub LeftJustify
End If
Next x
' Always print the word "the" in the highlight color
Color 15, 4: Print "the";: Color 8, 0: GoSub LeftJustify
' Print the day of the month
For x = 1 To 31
If x = Day Then
Color 15, 4: Print DayString$(x);: Color 8, 0: GoSub LeftJustify
Else
Print DayString$(x);: GoSub LeftJustify
End If
Next x
' Always print the word "of" in the highlight color
Color 15, 4: Print "of";: Color 8, 0: GoSub LeftJustify
' Print the month
For x = 1 To 12
If x = Month Then
Color 15, 4: Print MonthString$(x);: Color 8, 0: GoSub LeftJustify
Else
Print MonthString$(x);: GoSub LeftJustify
End If
Next x
' Always print a comma (,) in the highlight color
Color 15, 4: Print ",";: Color 8, 0: GoSub LeftJustify
' Print the hour. Hours are numbered from 0 to 23. Since we are using AM and PM we need to manipulate the hours a little bit
' and set an AM / PM flag.
' Set an AM / PM Flag. AM_PM$ will be set to either "AM" or "PM".
Select Case Hour
Case 0 To 11
AM_PM$ = "AM"
Case Else
AM_PM$ = "PM"
End Select
' Convert 24 hour time to AM / PM (12 hour) format
Select Case Hour
Case 0
Hour = Hour + 12
Exit Select
Case 13 To 23
Hour = Hour - 12
Exit Select
End Select
For x = 1 To 12
If x = Hour Then
Color 15, 4: Print HourString$(x);: Color 8, 0: GoSub LeftJustify
Else
Print HourString$(x);: GoSub LeftJustify
End If
Next x
' If minutes are equal to zero, highlight the word "o'clock".
If (Minute = 0) Then
Color 15, 4: Print "o'clock";: Color 8, 0: GoSub LeftJustify
Else
Print "o'clock";: GoSub LeftJustify
End If
' Print the minute. Minutes are numbered from 0 to 59. If seconds are 0, then we highlight the word "precisely",
' otherwise we highlight the word "and" and the appropriate second following the minutes.
For x = 1 To 59
If x = Minute Then
Color 15, 4: Print MinuteString$(x);: Color 8, 0: GoSub LeftJustify
Else
Print MinuteString$(x);: GoSub LeftJustify
End If
Next x
' Print the AM and PM indicators.
Select Case AM_PM$
Case "AM"
Color 15, 4: Print "AM";: Color 8, 0: GoSub LeftJustify: Print "PM";: GoSub LeftJustify
Case "PM"
Print "AM";: GoSub LeftJustify: Color 15, 4: Print "PM";: Color 8, 0: GoSub LeftJustify
End Select
' If seconds are 0, then highlight the word "precisely", otherwise, highlight the word "and".
Select Case Second
Case 0
Print "and";: GoSub LeftJustify
Color 15, 4: Print "precisely";: Color 8, 0: GoSub LeftJustify
Case Else
Color 15, 4: Print "and";: Color 8, 0: GoSub LeftJustify
Print "precisely";: GoSub LeftJustify
End Select
' Print the second. Seconds are numbered from 0 to 59.
For x = 1 To 59
If Second = x Then
Color 15, 4: Print SecondString$(x);: Color 8, 0: GoSub LeftJustify
Else
Print SecondString$(x);: GoSub LeftJustify
End If
Next x
' Highlight the word "second" if Second = 1, otherwise highlight "seconds" if Second > 1.
Select Case Second
Case 0
Print "second";: GoSub LeftJustify: Print "seconds";
Case 1
Color 15, 4: Print "second";: Color 8, 0: GoSub LeftJustify: Print "seconds";
Case Else
Print "second";: GoSub LeftJustify: Color 15, 4: Print "seconds";: Color 8, 0
End Select
OldSecond = Second
DisplayFinished:
If CurrentMode$ = "FULLSCREEN" Then
CharPerLine = Int(_DesktopWidth / Wide)
Else
CharPerLine = Int(Horizontal / Wide)
End If
Locate MaxLines, (CharPerLine / 2) - 5
If ShowDigitalTime$ = "N" Then
Print " ";
GoTo EndShowDigitalTime
End If
Select Case Hour
Case 0
DigitalHour$ = "12"
Case 1 To 9
DigitalHour$ = "0" + LTrim$(Str$(Hour))
Case 10 To 12
DigitalHour$ = LTrim$(Str$(Hour))
Case 13 To 21
DigitalHour$ = "0" + LTrim$(Str$(Hour - 12))
Case 22, 23
DigitalHour$ = LTrim$(Str$(Hour - 12))
End Select
Color 0, 2
Print DigitalHour$; ":"; Mid$(CurrentTime$, 4, 2); ":"; Right$(CurrentTime$, 2);
Color 8, 0
Print " ";: Color 0, 2: Print AM_PM$;
Color 8, 0
EndShowDigitalTime:
Loop
' SUBROUTINES
LeftJustify:
' This routine ensures that spaces are not printed in the first column of a line. This has the effect
' of ensuring that all lines are left justified.
If Pos(0) > 1 Then Print " ";
Return
Help:
' Display help and usage instructions for the program.
_FullScreen _Off
Screen 0
Width 120, 30
Print "This program was inspired by a screen saver authored by Simon Heys many years ago and called Word Clock. To use the"
Print "program effectivly, you should know how about the following two items:"
Print
Print "1) The WordClock.ini file"
Print "2) Program hotkeys"
Print "3) Program defaults"
Print
Input "Press <ENTER> to continue...", Temp
Cls
Print "The WordClock.ini File"
Print "-------------------------"
Print
Print "Entries in the WordClock.ini file are not case sensitive. You can use uppercase, lowercase, or mixedcase. Any line"
Print "that starts with a colon (:) as the first character is considered a comment and will be ignored by the program. The"
Print "entries that the program recognizes are described below. Please note that the .ini file should be placed in the same"
Print "location as the program itself. Follow each entry with a colon and a value. See examples below."
Print
Print ": This is a comment - Comments start with a "; Chr$(34); ":"; Chr$(34); " as the first character and are ignored by the program."
Print ": Windowed mode entries"
Print "Font:lucon.ttf - The font to be used in windowed mode. Font name only, no path."
Print "Fontsize:14 - * Size of font used in windowed mode. Font name only, no path."
Print "WindowHorizontal:800 - Horizontal resolution (width) used in windowed mode."
Print "WindowVertical:600 - Vertical resolution (height) used in windowed mode."
Print ": Full screen mode entries"
Print ""
Print "FullscreenFont:lucon.ttf - The font to be used in fullscreen mode."
Print "FullscreenFontSize:32 - * Size of font used in fullscreen mode."
Print "StartFullscreen:Y - Specify Y to start in fullscreen mode, N to start windowed."
Print ": Other entries"
Print "ShowDigitalTime:Y - Display the digital time on the last line of the screen."
Print "HandleErrors:Y - Enables error handling routies. Disable if you need to see original QB64 error message(s)."
Print
Print "* Note that the program now dynamically adjust the font size so the font size entries are obsolete. However, they may"
Print " still serve one purpose: When the program begins performing dynamic adjustment of the font size, it will use the"
Print " specified fontsize as a starting point. If you have an especially large monitor and a very large font is needed,"
Print " specifying a font that is close to right size may enable the dynamic adjustment to determine a solution more quickly."
Print
Input "Press <ENTER> to continue...", Temp
Cls
Print "Program Hotkeys"
Print "---------------"
Print
Print "Hotkeys (Note case sensitivity)"
Print
' The two comments below can be removed if the "+" and "-" ket functionality is re-enabled for troubleshooting. These hotkeys
' were used to allow the user to change the font size before dynamic resizing was implemented.
' Print "+ : Increases font size. NOTE: Once screen starts flashing, you have gone too large. Back off one size on the font."
' Print "- : Decreases the size of the font."
Print "D or d : Toggles between displaying / not displaying digital time at the bottom of the screen."
Print "F or f : Toggle in and out of fullscreen mode."
Print "H or h : Displays help for the program."
Print "S or s : Display statistics / current values of options."
Print
Print "Any other Key will exit the program."
Print
Print "Please note that the values shown by the Statistics hotkey are the current values in use in the program. As an example,"
Print "if you have changed the screen size in the windowed mode, the windowed mode width and height will reflect the current"
Print "settings, not the program default settings or the settings you provide in the WordClock.ini file."
Print
Input "Press <ENTER> to continue...", Temp
Cls
Print "Program Defaults"
Print "----------------"
Print
Print "If no WordClock.ini file is present, or for any missing items in that file, the following defaults are used:"
Print
Print "Font:lucon.ttf"
Print "FontSize:14"
Print "WindowHorizontal:800"
Print "WindowVertical:600"
Print "FullscreenFont:lucon.ttf"
Print "FullscreenFontSize:40"
Print "StartFullscreen:Y"
Print "ShowDigitalTime:Y"
Print
Input "Press <ENTER> to continue...", Temp
Cls
' Set the screen back to the mode it was in before we called help.
If CurrentMode$ = "FULLSCREEN" Then
handle& = _NewImage(_DesktopWidth, _DesktopHeight, 256)
Screen handle&
Sleep 1
_FullScreen
Font& = _LoadFont(FullscreenFontPath$, FullscreenFontSize, "MONOSPACE")
_Font Font&
High = _FontHeight
Wide = _FontWidth
MaxLines = Int(_DesktopHeight / High)
FullscreenFontWidth = _FontWidth
FullscreenFontHeight = _FontHeight
End If
If CurrentMode = "WINDOWED" Then
handle& = _NewImage(Horizontal, Vertical, 256)
Screen handle&
Sleep 1
_FullScreen _Off
Font& = _LoadFont(FontPath$, FontSize, "MONOSPACE")
_Font Font&
High = _FontHeight
Wide = _FontWidth
MaxLines = Int(Vertical / High)
FontWidth = _FontWidth
FontHeight = _FontHeight
End If
Return
DisplayStats:
' Display current settings being used in the program. This includes fullscreen / windowed height / width, etc.
' Once a user has settings dialed in where they want, this is a helpful way of getting all the values needed
' to plug into the .ini file.
Screen 0
Width 120, 30
_FullScreen Off
_FreeImage handle&
Cls
Print "The values shown below are current values, not program default settings or the settings from the WordClock.ini file."
Print "Note that a value may shows up as "; Chr$(34); "0"; Chr$(34); ", if that mode has not been used yet. For example, windowed font width and height"
Print "may show as zero until you use windowed mode for the first time. Use the WordClock.ini file to alter the default"
Print "behavior of the program."
Print
Print " Windowed Mode Options"
Print "-------------------------------"
Print "Font used in windowed mode: "; FontPath
Print "Font size in windowed mode:"; FontSize
Print "Windowed screen font height:"; FontHeight
Print "Windowed screen font width:"; FontWidth
Print "Windowed mode width:"; Horizontal
Print "Windowed mode height:"; Vertical
Print
Print " Full Screen Mode Options"
Print "-------------------------------"
Print "Font used in fullscreen mode: "; FullscreenFontPath
Print "Font size in fullscreen mode:"; FullscreenFontSize
Print "Full screen font height:"; FullscreenFontHeight
Print "Full screen font width:"; FullscreenFontWidth
Print "Fullscreen width (cannot be changed):"; DeskWidth
Print "Fullscreen height (cannot be changed):"; DeskHeight
Print
Print " Other Options"
Print "-------------------------------"
Print "Show digital time at bottom of screen:"; ShowDigitalTime$
Print "Error handling routines:"; HandleErrors$
Print
Input "Press <ENTER> to continue...", Temp
Cls
' Set the screen back to the mode it was in before we called help.
If CurrentMode$ = "FULLSCREEN" Then
handle& = _NewImage(_DesktopWidth, _DesktopHeight, 256)
Screen handle&
Sleep 1
_FullScreen
Font& = _LoadFont(FullscreenFontPath$, FullscreenFontSize, "MONOSPACE")
_Font Font&
High = _FontHeight
Wide = _FontWidth
MaxLines = Int(_DesktopHeight / High)
FullscreenFontWidth = _FontWidth
FullscreenFontHeight = _FontHeight
End If
If CurrentMode = "WINDOWED" Then
handle& = _NewImage(Horizontal, Vertical, 256)
Screen handle&
Sleep 1
_FullScreen _Off
Font& = _LoadFont(FontPath$, FontSize, "MONOSPACE")
_Font Font&
High = _FontHeight
Wide = _FontWidth
MaxLines = Int(Vertical / High)
FontWidth = _FontWidth
FontHeight = _FontHeight
End If
Return
FindLargestFontSize:
GoSub ValidateScreen
' This subroutine will determine what the largest font size is that all allow all text to be displayed on the screen.
' This subroutine will in turn call the subroutine "FontSizeTest".
' We will begin our testing with the currently set font size
Select Case CurrentMode$
Case "FULLSCREEN"
FontSizeToTest = FullscreenFontSize
Case "WINDOWED"
FontSizeToTest = FontSize
End Select
' Start testing font sizes to see if they are too large. We begin by testing one size larger than the initial font size
' specified. Once we encounter a failure then we back off the size until it passes. Once we have a pass we then have the
' largest font size that works. Before testing a font size, load all the text to be displayed into AllText$.
Do
FontSizeToTest = FontSizeToTest + 1
Restore AllText
Do
Read TempString$
If TempString$ = "EOF" Then Exit Do
AllText$ = AllText$ + TempString$
Loop
GoSub FontSizeTest
Loop Until FontTooLarge$ = "Y"
Do
FontSizeToTest = FontSizeToTest - 1
Restore AllText
AllText$ = ""
Do
Read TempString$
If TempString$ = "EOF" Then Exit Do
AllText$ = AllText$ + TempString$
Loop
GoSub FontSizeTest
Loop Until FontTooLarge$ = "N"
' We reach this point when the largest font size has been determined.
' Assign this font size to either the FontSize or FullscreenFontSize variable.
Select Case CurrentMode$
Case "FULLSCREEN"
FullscreenFontSize = FontSizeToTest
Case "WINDOWED"
FontSize = FontSizeToTest
End Select
' We are reserving the last line for use by the Digital Clock option, so we are subtracting 1 line from MaxLines
MaxLines = MaxLines - 1
End Select
LineCount = 0 ' Set an initial value before entering the loop
Do
' If AllText$ has a space as the first character, remove it. Since we always left justify the output,
' a space at the beginning of a line is dropped and should not count toward the character limit for a line.
AllText$ = LTrim$(AllText$)
' If AllText$ has zero length after trimming, then font size is not too large and there is nothing
' more to be done so we exit from this test.
If Len(AllText$) = 0 Then
FontTooLarge$ = "N"
Exit Do
End If
' If the length of the AllText$ is greater than the number of characters that we can fit on a line, then
' read the number of characters a line can hold plus one more. By doing this, we can check the last
' character to see if it is a space. If it is a space then the last character on the line is the
' last character of a word. However, if that character is a letter, then we are cutting off a word
' and need to determine where that word started.
If Len(AllText$) > CharPerLine Then
TempString$ = Left$(AllText$, CharPerLine + 1)
If Right$(TempString$, 1) = " " Then
AllText$ = LTrim$(Right$(AllText$, (Len(AllText$) - CharPerLine)))
Else
CharPosition = _InStrRev(TempString$, " ")
TempString$ = Left$(TempString$, CharPosition - 1)
AllText$ = Right$(AllText$, Len(AllText$) - Len(TempString$))
End If
LineCount = LineCount + 1
If LineCount > MaxLines Then
FontTooLarge$ = "Y"
Exit Do
Else
FontTooLarge$ = "N"
_Continue
End If
_Continue
End If
' If the number of characters left in AllText$ is <= to the max length of line, then
' we can increment the LineCount and exit this loop.
If Len(AllText$) <= CharPerLine Then
LineCount = LineCount + 1
If LineCount > MaxLines Then
FontTooLarge$ = "Y"
Exit Do
Else
FontTooLarge$ = "N"
End If
Exit Do
End If
Loop
Return
' Check for invalid screen sizes (smaller than 200 x 200)
ValidateScreen:
AdjustmentsMade$ = "N" ' Set initial value
If Horizontal >= _DesktopWidth Then
Horizontal = _DesktopWidth - 1
AdjustmentsMade$ = "Y"
End If
If Vertical >= _DesktopHeight Then
Vertical = _DesktopHeight - 1
AdjustmentsMade$ = "Y"
End If
If Horizontal < 200 Then
Horizontal = 200
AdjustmentsMade$ = "Y"
End If
If Vertical < 200 Then
Vertical = 200
AdjustmentsMade$ = "Y"
End If
' At the time of this writing, there are no known errors that need to be handled.
'
' Please note that error handling can be disabled by adding an entry to the WordClock.ini file like this
''
Resume ProgramStart
' End of main program
End
' DATA section
DayOfWeek:
Data "Saturday","Sunday","Monday","Tuesday","Wednesday","Thursday","Friday"
Day:
Data "first","second","third","fourth","fifth","sixth","seventh","eighth","ninth","tenth","eleventh","twelfth","thirteenth"
Data "fourteenth","fifteenth","sixteenth","seventeenth","eighteenth","nineteenth","twentieth","twenty-first","twenty-second"
Data "twenty-third","twenty-fourth","twenty-fifth","twenty-sixth","twenty-seventh","twenty-eighth","twenty-ninth","thirtieth","thirty-first"
Month:
Data "January","February","March","April","May","June","July","August","September","October","November","December"
Hour:
Data "one","two","three","four","five","six","seven","eight","nine","ten","eleven","twelve"
Minute:
Data "oh-one","oh-two","oh-three","oh-four","oh-five","oh-six","oh-seven","oh-eight","oh-nine","ten","eleven","twelve","thirteen"
Data "fourteen","fifteen","sixteen","seventeen","eighteen","nineteen","twenty","twenty-one","twenty-two","twenty-three","twenty-four"
Data "twenty-five","twenty-six","twenty-seven","twenty-eight","twenty-nine","thirty","thirty-one","thirty-two","thirty-three"
Data "thirty-four","thirty-five","thirty-six","thirty-seven","thirty-eight","thirty-nine","forty","forty-one","forty-two","forty-three"
Data "forty-four","forty-five","forty-six","forty-seven","forty-eight","forty-nine","fifty","fifty-one","fifty-two","fifty-three"
Data "fifty-four","fifty-five","fifty-six","fifty-seven","fifty-eight","fifty-nine"
Second:
Data "one","two","three","four","five","six","seven","eight","nine","ten","eleven","twelve","thirteen"
Data "fourteen","fifteen","sixteen","seventeen","eighteen","nineteen","twenty","twenty-one","twenty-two","twenty-three","twenty-four"
Data "twenty-five","twenty-six","twenty-seven","twenty-eight","twenty-nine","thirty","thirty-one","thirty-two","thirty-three"
Data "thirty-four","thirty-five","thirty-six","thirty-seven","thirty-eight","thirty-nine","forty","forty-one","forty-two","forty-three"
Data "forty-four","forty-five","forty-six","forty-seven","forty-eight","forty-nine","fifty","fifty-one","fifty-two","fifty-three"
Data "fifty-four","fifty-five","fifty-six","fifty-seven","fifty-eight","fifty-nine"
MonthTable:
Data 0,3,3,6,1,4,6,2,5,0,3,5
AllText:
Data "Saturday Sunday Monday Tuesday Wednesday Thursday Friday the first second third fourth fifth sixth seventh eighth ninth tenth eleventh "
Data "twelfth thirteenth fourteenth fifteenth sixteenth seventeenth eighteenth nineteenth twentieth twenty-first twenty-second twenty-third "
Data "twenty-fourth twenty-fifth twenty-sixth twenty-seventh twenty-eighth twenty-ninth thirtieth thirty-first of January February March April "
Data "May June July August September October November December , one two three four five six seven eight nine ten eleven twelve o'clock oh-one "
Data "oh-two oh-three oh-four oh-five oh-six oh-seven oh-eight oh-nine ten eleven twelve thirteen fourteen fifteen sixteen seventeen eighteen "
Data "nineteen twenty twenty-one twenty-two twenty-three twenty-four twenty-five twenty-six twenty-seven twenty-eight twenty-nine thirty "
Data "thirty-one thirty-two thirty-three thirty-four thirty-five thirty-six thirty-seven thirty-eight thirty-nine forty forty-one forty-two "
Data "forty-three forty-four forty-five forty-six forty-seven forty-eight forty-nine fifty fifty-one fifty-two fifty-three fifty-four "
Data "fifty-five fifty-six fifty-seven fifty-eight fifty-nine AM PM and precisely one two three four five six seven eight nine ten eleven "
Data "twelve thirteen fourteen fifteen sixteen seventeen eighteen nineteen twenty twenty-one twenty-two twenty-three twenty-four twenty-five "
Data "twenty-six twenty-seven twenty-eight twenty-nine thirty thirty-one thirty-two thirty-three thirty-four thirty-five thirty-six "
Data "thirty-seven thirty-eight thirty-nine forty forty-one forty-two forty-three forty-four forty-five forty-six forty-seven forty-eight "
Data "forty-nine fifty fifty-one fifty-two fifty-three fifty-four fifty-five fifty-six fifty-seven fifty-eight fifty-nine second seconds"
Data "EOF"
' End of DATA section
'''''''''''''''''''
' Release History '
'''''''''''''''''''
' 1.0.0.5 - First stable build release.
