*** SPECIAL NOTICE *** I am editing this post on 9/16 to warn people reading this later that the Zeller's congruence formula I use below has an error. Whether that is because the formula was posted incorrectly or I copied it wrong, some dates it gets wrong, e.g. 12/31/2029, the program returns Tuesday, when the correct date is Monday. In any case, I accept sole responsibility for this error. Which means I did not change anything below, as owning one's mistakes means you don't hide them either.
I think this one is easier to understand than some of the others
Code: (Select All)
' Show-Date_and_Time.bas - Day of week computed using Zeller's congruence
' by Paul Robinson <paul@paul-robinson.us>
' September 15, 2024
' Dedicated to the Public Domain
Dim As String CheckDate, CheckTime, AmPm
Dim As Integer Month, Day, Year, Hour, Minute, Second, WD
CheckDate = Date$
CheckTime = Time$
If CheckDate <> Date$ Then ' Midnight rolled over
CheckDate = Date$
CheckTime = Time$
End If
Month = Val(Left$(CheckDate, 2)): Day = Val(Mid$(CheckDate, 4, 2)): Year = Val(Right$(CheckDate, 4)):
Hour = Val(Left$(CheckDate, 2)): Minute = Val(Mid$(CheckDate, 4, 2)): Second = Val(Right$(CheckDate, 2))
WD = DayOfWeek(Month, Day, Year)
' Display date and time, formatted
Print "It is "; WeekDays(WD); " "; Months(Month); Str$(Day); ","; Year; " at";
$If MILITARYTIME Then
print checktime
$Else
AmPm = " AM"
If Hour > 12 Then
AmPm = " PM"
Hour = Hour - 12
End If
Print Str$(Hour); ":"; Right$("0" + LTrim$(Str$(Minute)), 2); ":"; Right$("0" + LTrim$(Str$(Second)), 2); AmPm
$End If
End
' Returns 0=Saturday, etc.
Function DayOfWeek% (Month%, Day%, Year%)
Dim As Integer I, J, K, D, M, Y
D = Day%: M = Month%: Y = Year%
If M < 3 Then
M = M + 12
Y = Y - 1
End If
K = Y Mod 100
J = Y / 100
DayOfWeek = (D + 13 * (M + 1) / 5 + K + K / 4 + J / 4 + 5 * J) Mod 7
End Function
A copy is attached to this message.
Some points
Line 5 indicates I waive copyright on this file.
Line 43 allows you to select military time format by having a line earlier in the program with "$LET MILITARY=-1". or drop the $IF block and keep the one you want (or make it a regular IF statement if the user gets to choose).
The string functions around day and hour/minute/second are to make sure that day and hour don't have a trailing space, and so that minute and second have no leading or trailing spaces, but do have leading 0 if <10.
Needed a SUB to draw boxes with rounded corners, filled or unfilled. Here's what came out of it. You can control the amount of corner rounded-ness by giving a radius value. I made a smaller one using the filled circle routine (circle for each corner), but it only could do filled boxes, so used arc routines to draw them. Probably someone has a better method to do this, just thought I'd throw mine into the mix.
- Dav
EDIT: Code fixed!
Code: (Select All)
'========
'RBOX.BAS
'========
'Draws a box with rounded corners, filled or unfilled.
'Coded by Dav, SEP/2024
Randomize Timer
Screen _NewImage(1000, 700, 32)
'this demo draws random boxes with round corners...
Sub Rbox (x1, y1, x2, y2, r, clr&, fill)
'x1/y1, y1/y2 = placement of box
'r = radius of rounded corner
'clr& = color of box
'fill = 1 for filled, 0 for just an edge
If fill = 1 Then
Line (x1, y1 + r)-(x2, y2 - r), clr&, BF 'middle
Line (x1 + r, y1)-(x2 - r, y2), clr&, BF '(ditto)
Else
Line (x1 + r, y1)-(x2 - r, y1), clr& 'top
Line (x1 + r, y2)-(x2 - r, y2), clr& 'bottom
Line (x1, y1 + r)-(x1, y2 - r), clr& 'left
Line (x2, y1 + r)-(x2, y2 - r), clr& 'right
End If
'top left corner arc
For angle = 180 To 270
x3 = (x1 + r) + r * Cos(_D2R(angle))
y3 = (y1 + r) + r * Sin(_D2R(angle))
If fill = 1 Then
Line (x3 + r, y3 + r)-(x3, y3), clr&, BF
Else
PSet (x3, y3), clr&
End If
Next
'top right corner arc
For angle = 270 To 360
x3 = (x2 - r) + r * Cos(_D2R(angle))
y3 = (y1 + r) + r * Sin(_D2R(angle))
If fill = 1 Then
Line (x2 - r, y1 + r)-(x3, y3), clr&, BF
Else
PSet (x3, y3), clr&
End If
Next
'bottom left corner arc
For angle = 90 To 180
x3 = (x1 + r) + r * Cos(_D2R(angle))
y3 = (y2 - r) + r * Sin(_D2R(angle))
If fill = 1 Then
Line (x1 + r, y2 - r)-(x3, y3), clr&, BF
Else
PSet (x3, y3), clr&
End If
Next
'bottom right corner
For angle = 0 To 90
x3 = (x2 - r) + r * Cos(_D2R(angle))
y3 = (y2 - r) + r * Sin(_D2R(angle))
If fill = 1 Then
Line (x2 - r, y2 - r)-(x3, y3), clr&, BF
Else
PSet (x3, y3), clr&
End If
Next
End Sub
I came up with the little program below while investigating a method of proceduraly creating landscapes. However, it is slow as heck. Setting TOTAL to anything above 25 is just painful.
I tried using a memory buffer for the Points() array ( _MEMNEW) but it made absolutely no difference in speed.
Does anyone have any ideas on how to speed this routine up?
Code: (Select All)
' Moving stained glass
OPTION _EXPLICIT ' declare those variables!
CONST TOTAL = 25 ' total pieces of glass
TYPE IPOINT ' PANE CENTER POINT PROPERTIES
x AS SINGLE ' x location
y AS SINGLE ' y location
c AS _UNSIGNED LONG ' color
xv AS SINGLE ' x vector
yv AS SINGLE ' y vector
END TYPE
DIM Points(TOTAL) AS IPOINT ' center of each glass pane
DIM sWidth AS INTEGER ' width of screen
DIM sHeight AS INTEGER ' height of screen
DIM Image AS LONG ' stained glass output image
DIM ScreenImage AS LONG ' view screen
DIM x AS INTEGER ' horizontal counter
DIM y AS INTEGER ' vertical counter
DIM p AS INTEGER ' point counter
DIM NearestDist AS _UNSIGNED LONG ' nearest distance to another point
DIM Nearest AS INTEGER ' final nearest point
DIM dx AS LONG ' x distance
DIM dy AS LONG ' y distance
DIM Dist AS LONG ' x,y to dx,dy distance
DIM mScreen AS _MEM ' screen memory
DIM mImage AS _MEM ' output image memory
DIM MaxDist AS _UNSIGNED LONG ' max distance possible
sWidth = 640 ' set screen width
sHeight = 480 ' set screen height
MaxDist = sWidth * sWidth + sHeight * sHeight ' maximum possible distance
Image = _NEWIMAGE(sWidth, sHeight, 32) ' output image
mImage = _MEMIMAGE(Image) ' output image memory
ScreenImage = _COPYIMAGE(Image, 32) ' view screen
mScreen = _MEMIMAGE(ScreenImage) ' view screen memory
SCREEN ScreenImage ' create view screen
RANDOMIZE TIMER ' seed RND generator
FOR p = 0 TO TOTAL - 1 ' cycle through pane center points
Points(p).x = RND * sWidth ' random x location
Points(p).y = RND * sHeight ' random y location
Points(p).c = _RGB32(RND * 128 + 128, RND * 128 + 128, RND * 128 + 128) ' random color above 128, 128, 128
Points(p).xv = (RND - RND) * 3 ' random x velocity
Points(p).yv = (RND - RND) * 3 ' random y velocity
NEXT p
DO ' begin animation loop
$CHECKING:OFF
y = 0 ' reset vertical counter
DO ' begin vertical loop
x = 0 ' reset horizontal counter
DO ' begin horizontal loop
NearestDist = MaxDist ' reset nearest distance seen
p = 0 ' reset point counter
DO ' begin point loop
dx = Points(p).x - x ' calculate distance from x to point x
dy = Points(p).y - y ' calculate distance from y to point y
Dist = dx * dx + dy * dy ' calculate hypotenuse distance
IF Dist < NearestDist THEN ' is this the nearest distance seen?
Nearest = p ' yes, mark this point as nearest
NearestDist = Dist ' set new nearest distance seen
END IF
p = p + 1 ' increment point counter
LOOP UNTIL p = TOTAL ' leave when all points checked
_MEMPUT mImage, mImage.OFFSET + (y * sWidth + x) * 4, Points(Nearest).c ' draw pixel on output image
x = x + 1 ' increment horizontal counter
LOOP UNTIL x = sWidth ' leave when width of image reached
y = y + 1 ' increment vertical counter
LOOP UNTIL y = sHeight ' leave when height of image reached
_MEMCOPY mImage, mImage.OFFSET, mImage.SIZE TO mScreen, mScreen.OFFSET ' copy image to view screen
p = 0 ' reset point counter
DO ' begin point update loop
dx = Points(p).x + Points(p).xv ' calculate new look ahead point x location
dy = Points(p).y + Points(p).yv ' calculate new look ahead point y location
IF dx < 0 OR dx > sWidth - 1 THEN Points(p).xv = -Points(p).xv ' reverse vector if left/right side of image reached
IF dy < 0 OR dy > sHeight - 1 THEN Points(p).yv = -Points(p).yv ' reverse vector if top/bottom side of image reached
Points(p).x = Points(p).x + Points(p).xv ' calculate new point x location
Points(p).y = Points(p).y + Points(p).yv ' calculate new point y location
p = p + 1 ' increment point counter
LOOP UNTIL p = TOTAL ' leave when all points updated
$CHECKING:ON
LOOP UNTIL _KEYDOWN(27) ' leave when ESC key pressed
SYSTEM ' return to operating system
Posted by: Petr - 09-13-2024, 04:18 PM - Forum: Petr
- Replies (3)
Let me introduce the longest program with absolutely minimal output.
I would call it Cursor$ or InputString$. The program is about cursor control. The entire output of the program is just the cursor. You only need to draw forms and with this function you can insert texts and numbers there (based on Inkey$), it is the first version, so maybe unnecessarily complicated in places in the source.
Function input parameters:
The first two are the graphic coordinates X and Y where the cursor will be displayed, the third parameter is the length of the string to be inserted (calculated here in characters), the fourth parameter is 1 or 0, if there is a 1, the area where the input is expected is highlighted with a rectangle around this area, if there is zero, the area is not visible, the fifth parameter is the color of the box around the area of the expected input (so zero if the previous parameter rectangle is off) and finally the mode. Mode is just cursor style. If it is 1, the cursor flashes as a horizontal line at the bottom, if it is 2, the cursor flashes as a vertical line. I was also thinking about mode 0, where the text would be hidden and replaced by a single character (like when entering a password), but this has not been done yet.
What it can do is described in the program right at the beginning.
Code: (Select All)
'Done:
'Supported doubleclick for end function
'Supported Insert key
'Supported BackSpace key
'Supported bordering with LINE
'Supported Home and End keys
'Supported Delete key
'Support deleting selected area using BackSpace
'repaired text lenght (now is as LENGHT paramater (in characters))
'repaired delete and backspace string deleting if part of the text is selected (add condition above)
'Supported copying selected text to clipboard
'Supported for inserting text from clipboard (3 methods):
' -insert clipboard string to middle the string if cursor is in middle and nothing is slected
' -insert clipboard string to the end the string if cursor is at the end
' -delete selected area and insert clipboard string to this area in string
'Supported cursor position set in text with mouse
'Supported Shift + Home and Shift + End text selecting
'Supported text selecting with mouse
'can be used for 8 bit and 32 bit screens (both tested)
Dim Shared INSERT
Screen _NewImage(1024, 768, 32)
Cls
InputString$ = Cursor$(500, 400, 25, 1, _RGB32(255), 1) '32 bit - try set box (4th) parameter to zero. Then is possible using this to blank form.
'InputString$ = Cursor$(50, 100, 25, 1, 7, 1) '8 bit - before test this, do not forgot change SCREEN to 256 colors
Print "InputString$ value: "; InputString$
End
'function create cursor on selected position with expected behavior
'Xs - left upper x corner
'Ys - left upper y corner
'Lenght - how lenght string is expected (in characters)
'Box - draw box (Line, B) around? 0 = No, 1 = Yes
'BoxColor~& - if Box is allowed, so Box color
'Mode - print characters to screen (1, 2) or not (0) - then it print CHR$(249). 1 Print cursor as "_", 2 Print it as "ł"
Bck~& = _CopyImage(0)
GLen = Lenght * _FontWidth 'maximal text lenght in pixels
If Gpos = 0 Then Gpos = Xs 'cursor graphics position (X axis)
Dim As _Unsigned Long OnCursorColor, OffCursorColor, SelectColor
Select Case _PixelSize
Case 1
If Box Then Line (Xs - 2, Ys - 2)-(Xs + GLen, Ys + _FontHeight + 2), BoxColor~&, B
OnCursorColor = 15
OffCursorColor = 0
SelectColor = 1
Case 4
If Box Then Line (Xs - 2, Ys - 2)-(Xs + GLen, Ys + _FontHeight + 2), BoxColor~&, B
OnCursorColor = _RGB32(255)
OffCursorColor = _RGB32(0)
SelectColor = _RGBA32(255, 255, 0, 150)
End Select
Do Until Done
While _MouseInput
Wend
MX = _MouseX
MY = _MouseY
LB = _MouseButton(1)
'click to the cursor's area and activate it until you press enter or escape
If MX >= Xs And MX <= Xs + GLen Then
If MY >= Ys - 20 And MY <= Ys + _FontHeight + 20 Then
_MouseShow "text"
'click twice and function return output and end
If LB = -1 Then
If Active Then
If OmPos = 0 Then 'function can not exit when mouse select text
If Timer - t < .3 Then
Cursor$ = C$
Exit Function
End If
End If
End If
Active = 1
'calculate graphic cursor position
If Gpos = 0 Then Gpos = Xs + Len(C$) * _FontWidth 'default
If OmPos = 0 Then
'can not use cursor GPOS value here, because mouse use own coordinate
chars = (MX - Xs) \ _FontWidth
OmPos = chars * _FontWidth + Xs
If OmPos < Xs Then OmPos = Xs
If OmPos > Xs + _PrintWidth(C$) Then OmPos = Xs + _PrintWidth(C$)
'lock default cursor position for mouse selecting
End If
'zde posledni vklad: oznacit text mysi
If Abs(OmPos - Gpos) > _FontWidth \ 2 Then 'if track with mouse is minimal 1 character, select this area
mSelected = 1
SelectStart = OmPos
chars = (MX - Xs) \ _FontWidth
SelectEnd = chars * _FontWidth + Xs
If SelectEnd < Xs Then SelectEnd = Xs
If SelectEnd > Xs + _PrintWidth(C$) Then SelectEnd = Xs + _PrintWidth(C$)
Selected = mSelected
End If
'here - calculate the position for the possibility to set the position of the cursor by clicking in the text
If Len(C$) Then
If MX > Xs + _PrintWidth(C$) Then Gpos = Xs + _PrintWidth(C$)
If MX < Xs Then Gpos = Xs
If MX > Xs And MX < Xs + _PrintWidth(C$) Then
'calculate pixels from Xs
chars = (MX - Xs) \ _FontWidth
Gpos = Xs + chars * _FontWidth
End If
End If
t = Timer
If OmPos = 0 Then ResetLB
Else
OmPos = 0 'reset mouse graphic cursor position used for text selecting
If mSelected = 1 Then
mSelected = 0
End If
End If
End If
End If
'move to other area and deactivate cursor without function output
If MX >= Xs And MX <= Xs + GLen and_
MY >= Ys - 20 And MY <= Ys + _FontHeight + 20 Then_
_mouseshow "text" else _mouseshow "default"
'text insert is possible until is not clicked to other location
If MX < Xs or MX > Xs + GLen and_
MY < Ys - 20 or MY > Ys + _FontHeight + 20 and_
LB = -1 then Active = 0
Select Case Active
Case 0
_PrintMode _FillBackground
Case 1
_PrintMode _KeepBackground
K$ = InKey$
If Len(K$) Then
Select Case Asc(K$)
Case 31 To 127 ' string is created with text
If Gpos - Xs = _PrintWidth(C$) Then 'add character this way if cursor is on the end of the string only
If Len(C$) < Lenght Then C$ = C$ + K$
Selected = 0
Else ' ' add character inside string if cursor is inside
If INSERT Then 'ok
T1$ = Left$(C$, (Gpos - Xs) \ _FontWidth) ' the left part of the string
T2$ = Right$(C$, Len(C$) - Len(T1$) - 1) ' right part of the string
C$ = T1$ + K$ + T2$
Else
T1$ = Left$(C$, (Gpos - Xs) \ _FontWidth) 'the left part of the string
T2$ = Right$(C$, Len(C$) - Len(T1$)) ' right part of the string
If Len(C$) < Lenght - 1 Then C$ = T1$ + K$ + T2$
End If
End If
If Gpos < Xs + (Lenght - 2) * _FontWidth Then Gpos = Gpos + _FontWidth
Case 13 ' enter end function and return string
Cursor$ = C$
Selected = 0
Gpos = 0
Exit Function
Case 27 ' escape end function and return empty string
Cursor$ = ""
Selected = 0
Gpos = 0
Exit Function
Case 8 ' backspace
If Len(C$) > 0 And Selected = 0 Then
If Gpos = Xs Then _Continue
T1$ = Left$(C$, (Gpos - Xs) \ _FontWidth - 1) 'the left part of the string
T2$ = Right$(C$, Len(C$) - Len(T1$) - 1) 'right part of the string
C$ = T1$ + T2$
Gpos = Gpos - _FontWidth
If Gpos < Xs Then Gpos = Xs
End If
'condition for text select
If Selected Then
StringStart = (SelectStart - Xs) \ _FontWidth
StringEnd = (SelectEnd - Xs) \ _FontWidth
If StringStart > StringEnd Then Swap StringStart, StringEnd
'delete selected area in string
T1$ = Mid$(C$, 1, StringStart)
T2$ = Mid$(C$, StringEnd + 1, Len(C$))
C$ = T1$ + T2$
If Gpos > Xs + _PrintWidth(C$) Then Gpos = Xs + _PrintWidth(C$)
End If
Case 22 'Ctrl + V
' if none text is marked and the cursor is at the end, the input is added to the end of the string
' if the text is not marked and the cursor is in the middle of the text, the insert is inserted between
' if the text is marked, the marked part is deleted and overwritten with an insert (inserted between)
If Selected = 0 Then
If Gpos = Xs + _PrintWidth(C$) Then
C$ = C$ + _Clipboard$
If Len(C$) > Lenght Then C$ = Mid$(C$, 1, Lenght): Gpos = _PrintWidth(C$) 'insert clipboard to end if is cursor at the end
Else
T1$ = Mid$(C$, 1, (Gpos - Xs) \ _FontWidth) 'insert clipboard middle to text (to cursor position)
T2$ = Mid$(C$, 1 + (Gpos - Xs) \ _FontWidth, Len(C$))
C$ = T1$ + LTrim$(_Clipboard$) + T2$
If Len(C$) > Lenght Then C$ = Mid$(C$, 1, Lenght)
End If
Else 'part in text is selected - delete inserted part and place to this place clipboard
'test ok
StringStart = (SelectStart - Xs) \ _FontWidth
StringEnd = (SelectEnd - Xs) \ _FontWidth
If StringStart > StringEnd Then Swap StringStart, StringEnd
'delete selected area in string
T1$ = Mid$(C$, 1, StringStart)
T2$ = Mid$(C$, StringEnd + 1, Len(C$))
C$ = T1$ + _Clipboard$ + T2$
If Len(C$) > Lenght Then C$ = Mid$(C$, 1, Lenght)
If Gpos > Xs + _PrintWidth(C$) Then Gpos = Xs + _PrintWidth(C$)
End If
Case 3 'Ctrl + C 'this copy selected text to clipboard
StringStart = (SelectStart - Xs) \ _FontWidth
StringEnd = (SelectEnd - Xs) \ _FontWidth
If StringStart > StringEnd Then Swap StringStart, StringEnd
_Clipboard$ = Mid$(C$, StringStart + 1, StringEnd - StringStart) 'bug repaired
End Select
If Len(K$) > 1 Then
Select Case Asc(K$, 2)
Case 75 'left arrow
Gpos = Gpos - _FontWidth
If Gpos < Xs + 1 Then Gpos = Xs + 1
If _KeyDown(100303) = 0 And _KeyDown(100304) = 0 Then
OGPos = 0 'Shift + Home; Shift + End reset (OGpos is previous cursor GPOS graphics variable)
Selected = 0
SelectStart = 0
SelectEnd = 0
Else
Selected = 1
If SelectStart = 0 Then
SelectStart = Gpos + _FontWidth
If SelectStart < Xs + 1 Then SelectStart = Xs + 1
End If
SelectEnd = Gpos
End If
Case 77 'right arrow
Gpos = Gpos + _FontWidth
If Gpos > Xs + _PrintWidth(C$) Then Gpos = Xs + _PrintWidth(C$)
If _KeyDown(100303) = 0 And _KeyDown(100304) = 0 Then
OGPos = 0 'Shift + Home; Shift + End reset
Selected = 0
SelectStart = 0
SelectEnd = 0
Else
Selected = 1
If SelectStart = 0 Then
SelectStart = Gpos - _FontWidth
If SelectStart > Xs + _PrintWidth(C$) Then SelectStart = Xs + _PrintWidth(C$)
End If
SelectEnd = Gpos
End If
Case 82
INSERT = Not INSERT 'text insert switch
Case 83 'Delete
If Len(C$) > 0 And Selected = 0 Then
T1$ = Left$(C$, (Gpos - Xs) \ _FontWidth) 'the left part of the string
T2$ = Right$(C$, Len(C$) - Len(T1$) - 1) 'right part of the string
C$ = T1$ + T2$
End If
If Selected Then
StringStart = (SelectStart - Xs) \ _FontWidth
StringEnd = (SelectEnd - Xs) \ _FontWidth
If StringStart > StringEnd Then Swap StringStart, StringEnd
'delete selected area in string
T1$ = Mid$(C$, 1, StringStart)
T2$ = Mid$(C$, StringEnd + 1, Len(C$))
C$ = T1$ + T2$
Gpos = SelectStart
If Gpos > Xs + _PrintWidth(C$) Then Gpos = Xs + _PrintWidth(C$)
Selected = 0
End If
Case 71 'Home key
If OGPos = 0 Then OGPos = Gpos
Gpos = Xs
Case 79 'End key
If OGPos = 0 Then OGPos = Gpos
Gpos = Xs + _PrintWidth(C$)
If Len(K$) Then OldK$ = K$
If kk& = -1 Or kj& = -1 Then ' one hour, when my hard stupid head try apply _Keyhit here....
If Len(OldK$) = 2 Then
If Asc(OldK$, 2) = 77 Or Asc(OldK$, 2) = 75 Then 'if is arrow and shift pressed
Selected = 1
If SelectStart = 0 Then SelectStart = Gpos 'here its in graphical coordinates
SelectEnd = Gpos
End If
End If
End If
If Len(K$) = 1 Then 'reset selected area to none if is something (CHR$ 31 to 127) pressed
OldK$ = ""
Selected = 0
SelectEnd = 0
SelectStart = 0
ExtraPress = 0
OGPos = 0
End If
'support for Shift + Home
kl& = _KeyDown(18176) 'home
km& = _KeyDown(20224) 'end
If kk& = -1 And kl& = -1 Or kj& = -1 And kl& = -1 Then 'Shift + HOME
If Len(C$) Then
SelectStart = Xs
SelectEnd = OGPos
Selected = 1
Gpos = Xs
End If
End If
If kk& = -1 And km& = -1 Or kj& = -1 And km& = -1 Then 'Shift + END
If Len(C$) Then
SelectStart = OGPos
SelectEnd = Xs + _PrintWidth(C$)
Selected = 1
Gpos = Xs + _PrintWidth(C$)
End If
End If
Select Case INSERT
Case 0 ' standard cursor, insert mode is disabled
Select Case Mode ' cursor in mode 1 is line on bottom _
Case 1
If Timer * 10 Mod 10 < 5 Then
Line (Gpos, Ys + _FontHeight)-(Gpos + _FontWidth, Ys + _FontHeight), OnCursorColor
Else
Line (Gpos, Ys + _FontHeight)-(Gpos + _FontWidth, Ys + _FontHeight), OffCursorColor
End If
Case 2 ' cursor in mode 2 is vertical line |
If Timer * 10 Mod 10 < 5 Then
Line (Gpos - 1, Ys)-(Gpos - 1, Ys + _FontHeight), OnCursorColor
Else
Line (Gpos - 1, Ys)-(Gpos - 1, Ys + _FontHeight), OffCursorColor
End If
End Select
Case -1 ' rectangle cursor, insert mode is enabled
_PrintMode _KeepBackground
If Timer * 10 Mod 10 < 5 Then
Line (Gpos, Ys)-(Gpos + _FontWidth, Ys + _FontHeight), OnCursorColor, BF
Else
Line (Gpos, Ys)-(Gpos + _FontWidth, Ys + _FontHeight), OffCursorColor, BF
End If
End Select
If Mode = 2 Then _PrintMode _KeepBackground
_PrintString (Xs, Ys), C$
_PrintMode _FillBackground
If Selected Then
Line (SelectStart, Ys)-(SelectEnd, Ys + _FontHeight), SelectColor, BF 'for 32 bit screens
If _PixelSize = 1 Then 'solution for 8 bit screens
_PrintMode _KeepBackground
_PrintString (Xs, Ys), C$
_PrintMode _FillBackground
End If
End If
End Select
_Limit 20
Loop
End Function
Sub ResetLB
MB = _MouseButton(1)
Do Until MB = 0
While _MouseInput
Wend
MB = _MouseButton(1)
Loop
End Sub
For ln = 1 To 50
Print ln, SpeedFactor(ln), Speed(ln)
Next
The error line is the For ln = 1 to 50. The error reads "Unsupported variable used in the For statement"
The "l" in the "ln" is a lower case L and not the number 1.
If I change it to For n = 1 to 50, it's fine ... no error
The other curious thing about this is, if the loop was just to Print the value of "ln" (ie For ln = 1 to 50: Print ln: Next) it runs fine, no error. So is the error actually the loop control "ln" or is it balking at the other two .. SpeedFactor(ln) or Speed(ln) both of which are correctly calculated prior to this print routine.
Again, this is not a big deal, all I need to do is change the loop control to just n, just curious why
Posted by: mdijkens - 09-12-2024, 09:47 AM - Forum: Programs
- No Replies
Since we are into globes/spheres and maps, I thought I'd post my 'library' that I use to show a map in my programs and being able to draw on it in Lat/Lon values. The hard work is in the conversion from lat/lon to x/y and vice versa.
Maybe someone can use it or parts of it.
Only the 5 GEO.* functions are needed, the rest is samplecode to use it.
Prereqs:
- Create your own API KEY at geoapify.com and enter in line 32
- have wget utility sourceforge.net on your system and optionally set path to wget in line 33
Code: (Select All)
samplecode: ' How to use
Screen _NewImage(_DesktopWidth, _DesktopHeight, 32): Do: _Delay .01: Loop Until _ScreenExists
_FullScreen _Stretch , _Smooth
Thanks to Petr and Dav for informing that _InputBox has problems, I didn't realize.
So now I will bring my inputBox$ Function out of retirement:
Code: (Select All)
Option _Explicit
_Title "inputBox$ tester.bas started 2018-10-26 need an input box for WS Editor"
' 2019-07-32 assimulate scnState(restoreTF) used to save and restore screen settings
' so sub can do it's thing and restore settings, Thanks Steve McNeill for starter code and idea.
Screen _NewImage(800, 600, 32)
_ScreenMove 100, 20
Dim well$, enter$, k$, kh As Long
Color &HFFFFFF00, &HFF880000
Print "Here is some stuff on screen. Press h or m for inputBox$"
'well$ = inputBox$("Well?", "Test inputBox$", 20)
'Print "inputBox$ returned: "; well$; ". Is this line printing exactly below last stuff sentence?" ' OK now with center fix too!
'Input "OK? enter for next test, use h or m keypress to invoke inputBox$...", enter$
'draw stuff, until h or m press, then show message box
While 1
k$ = InKey$
If k$ = "m" Or k$ = "h" Then
well$ = inputBox$("Well?", "Test call inputBox", 36)
Print "inputBox$() returned: *"; well$; "*"
End If
'kh = 0 'should not need this to stop esc keypress in input box
Line (Rnd * _Width, Rnd * (_Height - 20) + 20)-Step(Rnd * 80, Rnd * 60), _RGB32(Rnd * 255, Rnd * 255, Rnd * 255), BF
kh = _KeyHit
If kh = 27 Then Exit While
'_DISPLAY '<< should not need this
_Limit 5
Wend
Print "OK where is this print line going to end up, hopefully under the last inputBox returned." 'yes! Excellent!
Print "InputBox$() last returned: "; well$; ", Goodbye!"
End
' You can grab this box by title and drag it around screen for full viewing while answering prompt.
' Only one line allowed for prompt$
' boxWidth is 4 more than the allowed length of input, it needs to be longer than title$ and prompt$ also
' Utilities > Input Box > Input Box 1 tester v 2019-07-31
Function inputBox$ (prompt$, title$, boxWidth As _Byte)
Dim ForeColor As _Unsigned Long, BackColor As _Unsigned Long, White As _Unsigned Long
Dim sw As Integer, sh As Integer, curScrn As Long, backScrn As Long, ibx As Long 'some handles
'colors
ForeColor = &HFF000055 '< change as desired prompt text color, back color or type in area
BackColor = &HFF6080CC '< change as desired used fore color in type in area
White = &HFFFFFFFF
'moving box around on screen
Dim bxW As Integer, bxH As Integer
Dim mb As Integer, mx As Integer, my As Integer, mi As Integer, grabx As Integer, graby As Integer
Dim tlx As Integer, tly As Integer 'top left corner of message box
Dim lastx As Integer, lasty As Integer
Dim inp$, kh&
'convert to pixels the top left corner of box at moment
bxW = boxWidth * 8: bxH = 5 * 16
tlx = (sw - bxW) / 2: tly = (sh - bxH) / 2
lastx = tlx: lasty = tly
_KeyClear
'now allow user to move it around or just read it
While 1
Cls
_PutImage , backScrn
_PutImage (tlx, tly), ibx, curScrn
_Display
While _MouseInput: Wend
mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
If mb Then
If mx >= tlx And mx <= tlx + bxW And my >= tly And my <= tly + 16 Then 'mouse down on title bar
If mx >= tlx + bxW - 24 Then Exit While
grabx = mx - tlx: graby = my - tly
Do While mb 'wait for release
mi = _MouseInput: mb = _MouseButton(1)
mx = _MouseX: my = _MouseY
If mx - grabx >= 0 And mx - grabx <= sw - bxW And my - graby >= 0 And my - graby <= sh - bxH Then
'attempt to speed up with less updates
If ((lastx - (mx - grabx)) ^ 2 + (lasty - (my - graby)) ^ 2) ^ .5 > 10 Then
tlx = mx - grabx: tly = my - graby
Cls
_PutImage , backScrn
_PutImage (tlx, tly), ibx, curScrn
lastx = tlx: lasty = tly
_Display
End If
End If
_Limit 400
Loop
End If
End If
kh& = _KeyHit
Select Case kh& 'whew not much for the main event!
Case 13: Exit While
Case 27: inp$ = "": Exit While
Case 32 To 128: If Len(inp$) < boxWidth - 4 Then inp$ = inp$ + Chr$(kh&): GoSub finishBox Else Beep
Case 8: If Len(inp$) Then inp$ = Left$(inp$, Len(inp$) - 1): GoSub finishBox Else Beep
End Select
_Limit 60
Wend
'put things back
scnState 1 'need fg and bg colors set to cls
Cls '? is this needed YES!!
_PutImage , backScrn
_Display
_FreeImage backScrn
_FreeImage ibx
scnState 1 'because we have to call _display, we have to call this again
inputBox$ = inp$
Exit Function
finishBox:
_Dest ibx
Color BackColor, ForeColor
Locate 5, 2: Print Left$(" " + inp$ + Space$(boxWidth - 2), boxWidth - 2)
_Dest curScrn
Return
End Function
'from mBox v 2019-07-31 update
' for saving and restoring screen settins
Sub scnState (restoreTF As Integer) 'Thanks Steve McNeill
Static Font As Long, DefaultColor As _Unsigned Long, BackGroundColor As _Unsigned Long, Dest As Long, Source As Long
Static row As Integer, col As Integer, autodisplay As Integer, mb As Integer
If restoreTF Then
_Font Font
Color DefaultColor, BackGroundColor
_Dest Dest
_Source Source
Locate row, col
If autodisplay Then _AutoDisplay Else _Display
_KeyClear
While _MouseInput: Wend 'clear mouse clicks
mb = _MouseButton(1)
If mb Then
Do
While _MouseInput: Wend
mb = _MouseButton(1)
_Limit 100
Loop Until mb = 0
End If
Else
Font = _Font: DefaultColor = _DefaultColor: BackGroundColor = _BackgroundColor
Dest = _Dest: Source = _Source
row = CsrLin: col = Pos(0): autodisplay = _AutoDisplay
End If
End Sub
This is small one-liner INPUT you can use for getting info from user without ruining the screen.
You can grab the title bar and drag it all over the screen if it happens to be sitting right on top of something you need to see to answer the InputBox inquiry.
At least in windows it would be nice. Since special paths exists in windows which are normally hidden as well
example:
_Title "path test"
'
' test for windows special paths
'
Open "%APPDATA%\HexChat\logs\rizon\test.txt" For Binary As #1
Line Input #1, d$
Close
Print d$
The test file only included a single line to let me know it happened. But didn't get there, failed with path not found on open. There are lot's of other important %paths% that windows has buried in the environment labels.
Since everyone is playing around with balls, globes, coins, circles and tigers and bears -- Oh my!! I decided to share this old Lightning Globe that I'd wrote sometime back in the stone ages of QB64. Maybe Dav, or someone skilled with the SOUND command will go in and add a nice little zappy zappy sizzle for us.
Just click on the screen and watch the lightning globe make lightning!
Code: (Select All)
Screen_NewImage(640, 480, 32) Dim Kolor As_UnsignedLong Const LevelOfVariance = 5'Change this value to have fun with the strength of the "draw" to target. Do _Limit60 Cls Circle (320, 240), 20, &HFFAAAAAA Paint (320, 240), &HFFAAAAAA While_MouseInput: Wend If_MouseButton(1) Then
StartX = 320: StartY = 240: EndX = _MouseX: EndY = _MouseY
Kolor = &HFF000000 + Int(Rnd * &H1000000) Color Kolor Do Until StartX = EndX And StartY = EndY
CoinToss = Rnd * 100'The strength of "draw" which pulls the lightning to the target. If CoinToss < LevelOfVariance Then'Higher values meander less and go directly to the target.
XChange = Sgn(EndX - StartX) '-1,0,1, drawn always towards the mouse
YChange = Sgn(EndY - StartY) Else
XChange = Int(Rnd * 3) - 1'-1, 0, or 1, drawn in a random direction to let the lightning wander
YChange = Int(Rnd * 3) - 1 End If
StartX = StartX + XChange
StartY = StartY + YChange PSet (StartX, StartY), Kolor Loop End If _Display Loop
