| Welcome, Guest |
You have to register before you can post on our site.
|
| Latest Threads |
Curious if I am thinking ...
Forum: Help Me!
Last Post: Dimster
1 hour ago
» Replies: 30
» Views: 462
|
Trojan infection !
Forum: Help Me!
Last Post: PhilOfPerth
7 hours ago
» Replies: 4
» Views: 97
|
Qix line monster
Forum: Programs
Last Post: Abazek
9 hours ago
» Replies: 0
» Views: 35
|
Tenary operator in QB64 w...
Forum: Utilities
Last Post: eoredson
11 hours ago
» Replies: 8
» Views: 313
|
_IIF limits two question...
Forum: General Discussion
Last Post: NakedApe
Today, 01:19 AM
» Replies: 10
» Views: 442
|
Aloha from Maui guys.
Forum: General Discussion
Last Post: SMcNeill
Yesterday, 10:38 PM
» Replies: 17
» Views: 496
|
Glow Bug
Forum: Programs
Last Post: SierraKen
Yesterday, 06:33 PM
» Replies: 7
» Views: 139
|
ADPCM compression
Forum: Petr
Last Post: Petr
Yesterday, 03:13 PM
» Replies: 0
» Views: 44
|
Who wants to PLAY?
Forum: QBJS, BAM, and Other BASICs
Last Post: dbox
Yesterday, 02:47 PM
» Replies: 15
» Views: 248
|
BAM Sample Programs
Forum: QBJS, BAM, and Other BASICs
Last Post: CharlieJV
Yesterday, 02:50 AM
» Replies: 36
» Views: 2,004
|
|
|
| Where to place prog with several files |
|
Posted by: PhilOfPerth - 05-05-2022, 05:47 AM - Forum: General Discussion
- Replies (2)
|
 |
I have written a program that has a number of files that it accesses, and I want to place it for comments/suggestions. Can I do this,? If so, I guess it goes in the Programs section, but I'm not sure how to do this with the other files being available to it. Also, how many files can it have associated with it?
|
|
|
| Triangle Dissection |
|
Posted by: bplus - 05-05-2022, 03:33 AM - Forum: bplus
- Replies (1)
|
 |
Can't think of a category for this one.
Code: (Select All) Option _Explicit
_Define A-Z As _FLOAT
_Title "Triangle Dissection 2 user click" 'B+ 2020-01-29
' Turn a triangle into a square (and back)
' 2020-01-30 now for any triangle, oh and swap points around until back to original dissection! nice :)
' 2020-01-30 Oh now let user click his own triangle for dissection
Const xmax = 800, ymax = 740, blu = &H880000FF, red = &H88FF0000
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 300, 0
Dim Ax, Ay, Fx, Fy, Jx, Jy '3 corners A is apex, F and J form iso triangle
Dim Bx, By, Cx, Cy 'midpoint AF and AJ
Dim Gx, Gy, Hx, Hy '1/4 lengths of base
Dim distFJ, aJ ' to calc points G and H
Dim Dx, Dy, Ex, Ey 'two crital points for forming 90 degree angles
Dim D2x, D2y, E2x, E2y, G2x, G2y 'copy points to move as independent blocks
Dim a, cnt, cc 'a = angle in degrees loop counter, cycle counter
Dim tx, ty ' for temp holders to swap points 3 way swap not 2 way
Dim mx(3), my(3), pi, oldMouse 'for mouse user input
getUserTri:
cc = 0
Cls: Circle (400, 370), 200
While pi < 3 'get 3 mouse clicks
_PrintString (5, 5), Space$(20)
_PrintString (5, 5), "Need 3 clicks inside circle, have" + Str$(pi)
While _MouseInput: Wend
mx(0) = _MouseX: my(0) = _MouseY
If _MouseButton(1) And oldMouse = 0 Then 'new mouse down
If Sqr((mx(0) - 400) ^ 2 + (my(0) - 370) ^ 2) < 200 Then
pi = pi + 1
mx(pi) = mx(0): my(pi) = my(0)
Circle (mx(pi), my(pi)), 2
End If
End If
oldMouse = _MouseButton(1)
_Display
_Limit 60
Wend
Ax = mx(1): Ay = my(1)
Jx = mx(2): Jy = my(2)
Fx = mx(3): Fy = my(3)
'initial triangle
'Ax = 400: Ay = 200: Fx = 200: Fy = 500: Jx = 600: Jy = 500 'jx = 600, jy = 500
restart:
cc = cc + 1
If cc = 4 Then pi = 0: GoTo getUserTri
Bx = (Ax + Fx) / 2: By = (Ay + Fy) / 2: Cx = (Ax + Jx) / 2: Cy = (Ay + Jy) / 2
distFJ = _Hypot(Fx - Jx, Fy - Jy)
aJ = _Atan2(Jy - Fy, Jx - Fx)
Gx = Fx + .25 * distFJ * Cos(aJ)
Gy = Fy + .25 * distFJ * Sin(aJ)
Hx = Fx + .75 * distFJ * Cos(aJ)
Hy = Fy + .75 * distFJ * Sin(aJ)
circleTangentXY Gx, Gy, Cx, Cy, Bx, By, Dx, Dy
circleTangentXY Gx, Gy, Cx, Cy, Hx, Hy, Ex, Ey
D2x = Dx: D2y = Dy
E2x = Ex: E2y = Ey
G2x = Gx: G2y = Gy
'draw traingle for check
'ln Ax, Ay, Fx, Fy
'ln Ax, Ay, Jx, Jy
'ln Fx, Fy, Jx, Jy
'ln Gx, Gy, Cx, Cy
'ln Dx, Dy, Bx, By
'ln Ex, Ey, Hx, Hy
'_DISPLAY
'_DELAY 1
'draw our starter triangle
Cls
fquad Ax, Ay, Cx, Cy, Dx, Dy, Bx, By, blu
fquad Bx, By, D2x, D2y, Gx, Gy, Fx, Fy, blu
fquad Cx, Cy, Jx, Jy, Hx, Hy, Ex, Ey, blu
ftri Hx, Hy, G2x, G2y, E2x, E2y, blu
_Display
_Delay 1
'start dissection with all points needed
a = 1: cnt = 0
While cnt < 180
Cls
fquad Ax, Ay, Cx, Cy, Dx, Dy, Bx, By, blu
rotate D2x, D2y, Bx, By, a
rotate Gx, Gy, Bx, By, a
rotate Fx, Fy, Bx, By, a
fquad Bx, By, D2x, D2y, Gx, Gy, Fx, Fy, blu
rotate Jx, Jy, Cx, Cy, -a
rotate Hx, Hy, Cx, Cy, -a
rotate Ex, Ey, Cx, Cy, -a
fquad Cx, Cy, Jx, Jy, Hx, Hy, Ex, Ey, blu
rotate G2x, G2y, Cx, Cy, -a
rotate E2x, E2y, Cx, Cy, -a
ftri Hx, Hy, G2x, G2y, E2x, E2y, blu
_Display
_Limit 60
cnt = cnt + 1
Wend
cnt = 0
While cnt < 180
Cls
fquad Ax, Ay, Cx, Cy, Dx, Dy, Bx, By, blu
fquad Bx, By, D2x, D2y, Gx, Gy, Fx, Fy, blu
fquad Cx, Cy, Jx, Jy, Hx, Hy, Ex, Ey, blu
rotate G2x, G2y, Hx, Hy, -a
rotate E2x, E2y, Hx, Hy, -a
ftri Hx, Hy, G2x, G2y, E2x, E2y, blu
cnt = cnt + 1
_Display
_Limit 60
Wend
_Delay 1
cnt = 0
While cnt < 180
Cls
fquad Ax, Ay, Cx, Cy, Dx, Dy, Bx, By, blu
fquad Bx, By, D2x, D2y, Gx, Gy, Fx, Fy, blu
fquad Cx, Cy, Jx, Jy, Hx, Hy, Ex, Ey, blu
rotate G2x, G2y, Hx, Hy, a
rotate E2x, E2y, Hx, Hy, a
ftri Hx, Hy, G2x, G2y, E2x, E2y, blu
cnt = cnt + 1
_Display
_Limit 60
Wend
cnt = 0
While cnt < 180
Cls
fquad Ax, Ay, Cx, Cy, Dx, Dy, Bx, By, blu
rotate D2x, D2y, Bx, By, -a
rotate Gx, Gy, Bx, By, -a
rotate Fx, Fy, Bx, By, -a
fquad Bx, By, D2x, D2y, Gx, Gy, Fx, Fy, blu
rotate Jx, Jy, Cx, Cy, a
rotate Hx, Hy, Cx, Cy, a
rotate Ex, Ey, Cx, Cy, a
fquad Cx, Cy, Jx, Jy, Hx, Hy, Ex, Ey, blu
rotate G2x, G2y, Cx, Cy, a
rotate E2x, E2y, Cx, Cy, a
ftri Hx, Hy, G2x, G2y, E2x, E2y, blu
cnt = cnt + 1
_Display
_Limit 60
Wend
_Delay 1
'swap points for different dissection
tx = Ax: ty = Ay
Ax = Jx: Ay = Jy
Jx = Fx: Jy = Fy
Fx = tx: Fy = ty
GoTo restart
Sub rotate (x, y, cx, cy, rAngle) 'replace x, y with new position
Dim angle, distance
angle = _Atan2(y - cy, x - cx)
distance = ((x - cx) ^ 2 + (y - cy) ^ 2) ^ .5
x = cx + distance * Cos(angle + _D2R(rAngle))
y = cy + distance * Sin(angle + _D2R(rAngle))
End Sub
Sub circleTangentXY (X1, Y1, X2, Y2, xC, yC, findXperp, findYperp)
'p1 and p2 form a line, with slop and y intersect y0
'xC, yC is a circle origin
'we find X, Y such that line x, y to xC, yC is perpendicular to p1, p2 line that is radius of tangent circle
Dim slope, y0, A, B
If X2 <> X1 Then
slope = (Y2 - Y1) / (X2 - X1)
y0 = slope * (0 - X1) + Y1
A = slope ^ 2 + 1
B = 2 * (slope * y0 - slope * yC - xC)
findXperp = -B / (2 * A)
findYperp = slope * findXperp + y0
Else
findXperp = X1
findYperp = yC
End If
End Sub
'SUB drawLine (x1, y1, x2, y2, K AS _UNSIGNED LONG)
' slope = (y2 - y1) / (x2 - x1)
' y0 = slope * (0 - x1) + y1
' LINE (0, y0)-(_WIDTH, slope * _WIDTH + y0), &HFF0000FF
'END SUB
Sub ln (x1, y1, x2, y2)
Line (x1, y1)-(x2, y2)
End Sub
'2019-12-16 fix by Steve saves some time with STATIC and saves and restores last dest
Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
Dim D As Long
Static a&
D = _Dest
If a& = 0 Then a& = _NewImage(1, 1, 32)
_Dest a&
_DontBlend a& ' '<<<< new 2019-12-16 fix
PSet (0, 0), K
_Blend a& '<<<< new 2019-12-16 fix
_Dest D
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
End Sub
'update 2019-12-16 needs updated fTri 2019-12-16
'need 4 non linear points (not all on 1 line) list them clockwise so x2, y2 is opposite of x4, y4
Sub fquad (x1, y1, x2, y2, x3, y3, x4, y4, K As _Unsigned Long)
ftri x1, y1, x2, y2, x3, y3, K
ftri x3, y3, x4, y4, x1, y1, K
End Sub
Funny things might happen with narrow slivers of a triangle but any acute triangle should be fine.
|
|
|
|
| Off-Topic Dropbox sharing |
|
Posted by: Richard - 05-04-2022, 10:44 PM - Forum: General Discussion
- Replies (5)
|
 |
@Steve
@Admin
A long time ago you mentioned about with dropbox that by having a "1" at the end of a link (instead of a "0"), made it easier for people to directly download a file in my free (for now) limited dropbox account. This technique had been working successfully for quite some time.
Recently, you and someone else now, has reported back to me that an error message occurs -... "You don't belong here...".
Any ideas how for me to share from dropbox a FOLDER to a particular person, with the minimum number of "hoops" to jump through to share - since what I did in the past (i.e. the "1" at end of link) does not now appear to work?
Note I am using the "free" version of dropbox with its known limitations - as I have been doing for some years now.
|
|
|
|
| Max font size printing to any screen size. |
|
Posted by: Pete - 05-04-2022, 09:55 PM - Forum: Utilities
- Replies (1)
|
 |
This was just for fun, in response to another forum member looking for a way to wrap a long string around a screen so it nearly fills up the entire screen. In other words, if it is very long, it is printed in a smaller font. Small, it gets printed in a larger font.
It isn't totally goof-proof, so I'm happy to take any comments as to improvements. This isn't my typical SCREEN 0 stuff, but it's close. It uses _NEWIMAGE.
Code: (Select All) 'handle& = _NEWIMAGE(800, 600, 256)
'SCREEN handle&
handle& = _NEWIMAGE(_DESKTOPWIDTH, _DESKTOPHEIGHT, 256)
SCREEN handle&
_SCREENMOVE 0, 0
_DELAY .1
sw = _WIDTH
sh = _HEIGHT
x$ = "Fourscore and seven years ago our fathers brought forth, on this continent, a new nation, conceived in liberty, and dedicated to the proposition that all men are created equal. Now we are engaged in a great civil war, testing whether that nation, or any nation so conceived, and so dedicated, can long endure. We are met on a great battle-field of that war. We have come to dedicate a portion of that field, as a final resting-place for those who here gave their lives, that that nation might live."
fs = 16
GOSUB getfonts
GOSUB getmaxchrs
seed = 1
DO
x1$ = MID$(x$, seed, noc)
chop = INSTR(MID$(x$ + " ", seed, noc), " ")
IF MID$(x$ + " ", seed + noc, 1) = " " OR chop = 0 THEN
PRINT MID$(x$, seed, noc);
IF chop = 0 THEN seed = seed + noc ELSE seed = seed + noc + 1
ELSE
wrap = _INSTRREV(MID$(x$ + " ", seed, noc), " ")
PRINT MID$(x$, seed, wrap - 1);
seed = seed + wrap
END IF
IF seed >= LEN(x$) THEN EXIT DO ELSE yy = yy + 1: LOCATE yy + 1, 1
LOOP
b$ = INKEY$: SLEEP
SYSTEM
getfonts:
DO
fontpath$ = ENVIRON$("SYSTEMROOT") + "\fonts\lucon.ttf" 'Find Windows Folder Path.
font& = _LOADFONT(fontpath$, fs, "monospace")
_FONT font&
w1 = _FONTWIDTH
h1 = _FONTHEIGHT
nor = sh \ h1
noc = sw \ w1
maxchr = nor * noc
IF flag THEN EXIT DO
IF LEN(x$) >= maxchr - noc THEN fs = fs - 1: EXIT DO
fs = fs + 1
LOOP
fontpath$ = ENVIRON$("SYSTEMROOT") + "\fonts\lucon.ttf" 'Find Windows Folder Path.
font& = _LOADFONT(fontpath$, fs, "monospace")
_FONT font&
RETURN
getmaxchrs:
DO
seed = 1: prow = 0
DO
x1$ = MID$(x$, seed, noc)
chop = INSTR(MID$(x$ + " ", seed, noc), " ")
IF MID$(x$ + " ", seed + noc, 1) = " " OR chop = 0 THEN
prow = prow + 1
IF chop = 0 THEN seed = seed + noc ELSE seed = seed + noc + 1
ELSE
wrap = _INSTRREV(MID$(x$ + " ", seed, noc), " ")
seed = seed + wrap
prow = prow + 1
END IF
LOOP UNTIL seed >= LEN(x$)
IF prow <= nor THEN EXIT DO
prow = 0
fs = fs - 1
IF fs = 0 THEN BEEP: END ' ERROR.
flag = 1: GOSUB getfonts: flag = 0
LOOP
RETURN
Pete
|
|
|
|
| Simpler Datenum |
|
Posted by: doppler - 05-04-2022, 04:43 PM - Forum: Programs
- Replies (9)
|
 |
Code: (Select All) a$ = Date$
month$ = Left$(Date$, 2)
day$ = Mid$(Date$, 4, 2)
Select Case month$
Case "01": datenum = 0 ' jan 31
Case "02": datenum = 31 ' feb 29+ F leap years
Case "03": datenum = 60 ' mar 31+
Case "04": datenum = 91 ' apr 30+
Case "05": datenum = 121 ' may 31+
Case "06": datenum = 152 ' jun 30+
Case "07": datenum = 182 ' jul 31+
Case "08": datenum = 213 ' aug 31+
Case "09": datenum = 244 ' sep 30+
Case "10": datenum = 274 ' oct 31+
Case "11": datenum = 305 ' nov 30+
Case "12": datenum = 335 ' dec 31+
End Select
datenum = datenum + Val(day$)
datenum$ = Right$("00" + _Trim$(Str$(datenum)), 3)
Print a$
Print month$
Print day$
Print datenum$
End
I wanted to simplify the code with a edit. Messaged up the message big time. So I deleted and retried. If you remember my previous post. You will notice the change after the end select and in each case. This will result in faster and smaller code, with no difference in performance.
|
|
|
|
| Huge Matrices Library [Updated] |
|
Posted by: TarotRedhand - 05-04-2022, 07:57 AM - Forum: One Hit Wonders
- Replies (8)
|
 |
I initially created this library in the late 1990s. Having found QB64, I have now updated and expanded this library to work with it. At 2622 lines (including comments) it is obviously too large to post in a single code box. So the actual code is split into the six posts after this one. Also the sheer size and number of edits I made means that you should really treat this being a beta/release candidate version.
This library is all to do with matrices. There are six sections to it. Each section deals with matrix operations for arrays that contain a particular TYPE of data - Integer, Long Integer, _INTEGER64, Single precision floating point, Double precision floating point and _FLOAT. Overall this gives us 1 private routine and 114 public routines.
Having split it into 6 parts, I have made it so that each part should be able to be used independently of any other. The consequence of this is that if you want to use two (or more) parts you may well need to do minor editing on one (or more) parts.
Bug reports - either in here or pm me.
[Edit]
Now with a ridiculously small BI file that works all varieties of the library. '$INCLUDE: 'MATRIX.BI' at the top of the program that uses any of the library parts.
MATRIX.BI
Code: (Select All) '$DYNAMIC
Option Base 1
Note all parts of this library have been updated to reflect this.
Next post Integer Matrices -
TR
|
|
|
|
Possible bug: Word-wrap oddity |
|
Posted by: hanness - 05-04-2022, 06:41 AM - Forum: General Discussion
- Replies (11)
|
|
I'm in the very early stages of writing a program that emulates one of my favorite screensavers of all time. The program simply displays a series of words on the screen, highlighting the appropriate words to spell out the time.
Below is a screenshot showing some sample output. Note that in every case, where a word would be cut off if printed on the current line, QB64 instead drops the word onto the next line. This is perfect and is exactly the behavior that I want, to avoid words being split across two lines. However, notice the second to last line of text in the screenshot below. For some reason, on only this one line, the word "fifty-six" is split across two lines.
Am I encountering some sort of bug here? Maybe something like the letter "x" at the end of the word is falling precisely on the 800 pixel width boundry and it's not being calculated precisely correctly?
Following the screenshot is the entire code, just in case this helps at all.
NOTE: I've done some testing and if I shift words around a bit I can get the error on other lines as well, where I have words that are not hyphenated. In other words, the hyphen in the word "fifty-six" has nothing to do with the problem.
It may also be worth noting that if I change the screen width from 800 to 799 the problem goes away.
![[Image: Image1.jpg]](https://i.ibb.co/qymQVZM/Image1.jpg)
Code: (Select All) Option _Explicit
Option Base 1
Dim AM_PM As String ' This flag will be set to either "AM" or "PM"
Dim CurrentDate As String ' Hold the entire date (Month / Day / Year) as a string
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 font As Long
Dim fontpath As String
Dim handle As Long
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 LeapYear As Integer ' To to indicate if current year is a leap year. 1 = Leap Year, 0 = No Leap Year
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 OldSecond As Integer ' A variable that is used to determine if the seconds have changed from the last time we checked
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 Temp As Integer ' A temporary variable
Dim Temp2 As Integer ' A temporary variable
Dim x As Integer
Dim Year As Integer
handle& = _NewImage(800, 600, 256)
Screen handle&
'handle& = _NewImage(_DesktopWidth, _DesktopHeight, 256)
'Screen handle&
'_FullScreen
fontpath$ = Environ$("SYSTEMROOT") + "\fonts\lucon.ttf" 'Find Windows Folder Path.
font& = _LoadFont(fontpath$, 16)
_Font font&
' 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
' This is the main loop that retries 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
CurrentDate$ = Date$
CurrentTime$ = Time$
Month = Val(Left$(CurrentDate$, 2))
Day = Val(Mid$(CurrentDate$, 4, 3))
Year = Val(Right$(CurrentDate$, 4))
Decade = Val(Right$(CurrentDate$, 2))
Hour = Val(Left$(CurrentTime$, 2))
Minute = Val(Mid$(CurrentTime$, 4, 2))
Second = Val(Right$(CurrentTime$, 2))
' 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.
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: Print " ";
Else
Print DayOfWeekString$(x); " ";
End If
Next x
' Always print the word "the" in the highlight color
Color 15, 4: Print "the";: Color 8, 0: Print " ";
' Print the day of the month
For x = 1 To 31
If x = Day Then
Color 15, 4: Print DayString$(x);: Color 8, 0: Print " ";
Else
Print DayString$(x); " ";
End If
Next x
' Always print the word "of" in the highlight color
Color 15, 4: Print "of";: Color 8, 0: Print " ";
' Print the month
For x = 1 To 12
If x = Month Then
Color 15, 4: Print MonthString$(x);: Color 8, 0: Print " ";
Else
Print MonthString$(x); " ";
End If
Next x
' Always print a comma (,) in the highlight color
Color 15, 4: Print ",";: Color 8, 0: Print " ";
' 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: Print " ";
Else
Print HourString$(x); " ";
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: Print " ";
Else
Print "o'clock ";
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: Print " ";
Else
Print MinuteString$(x); " ";
End If
Next x
' Print the AM and PM indicators.
Select Case AM_PM$
Case "AM"
Color 15, 4: Print "AM";: Color 8, 0: Print " "; "PM"; " ";
Case "PM"
Print "AM";: Print " ";: Color 15, 4: Print "PM";: Color 8, 0: Print " ";
End Select
' If seconds are 0, then highlight the word "precisely", otherwise, highlight the word "and".
Select Case Second
Case 0
Print "and ";
Color 15, 4: Print "precisely";: Color 8, 0: Print " ";
Case Else
Color 15, 4: Print "and";: Color 8, 0: Print " ";
Print "precisely ";
End Select
' Print the second. Seconds are numbered from 0 to 59.
For x = 1 To 59
Select Case x
Case 1
If Second = 1 Then
Color 15, 4: Print SecondString$(x);: Color 8, 0: Print " ";: Color 15, 4: Print "second";: Color 8, 0: Print " ";
Else
Print SecondString$(x);: Print " ";: Print "second"; " ";
End If
Case Else
If Second = x Then
Color 15, 4: Print SecondString$(x);: Color 8, 0: Print " ";
Else
Print SecondString$(x); " ";
End If
End Select
Next x
' Highlight the word "seconds" if Second > 1.
Select Case Second
Case 0, 1
Print "seconds ";
Case Else
Color 15, 4: Print "seconds";: Color 8, 0: Print " ";
End Select
OldSecond = Second
DisplayFinished:
Loop
End
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
|
|
|
|
|
