| Welcome, Guest |
You have to register before you can post on our site.
|
|
|
| Pete's handy dandy compare tool... |
|
Posted by: Pete - 10-25-2024, 01:20 AM - Forum: Utilities
- No Replies
|
 |
Maybe Steve already posted one of these, and he codes more efficiently, so I'm sure my tool is bigger than his tool, but...
Code: (Select All)
_Title "File Compare"
' Copy to the clipboard for each of the (4) prompts that appear one at a time.
' Note for .bas files you do not need to copy the .bas extension.
' The routine will inform you of any copy errors and let you retry.
' Esc Quit
' Backspace Redo previous prompt
' Enter Inputs the current directory.
' Tab Can be used when directory or file names are the same, instead of doing another copy.
' Spacebar Change to a type-in input line.
' Input complete...
' If the files are identical, it will instantly inform you.
' If the files are different, it will display both codes, line by line and pause with a "No Match!" alert were the code is different.
' When paused you can...
' F1 Copy to the clipboard the no match line (last line shown) of the 1st file.
' F2 Copy to the clipboard the no match line (last line shown) of the 2nd file.
' Note: Copying the line and paste it into an IDE search to find the code in your program.
' 1 Scroll to the next line of the 1st file.
' 2 Scroll to the next line of the 2nd file.
' Spacebar Toggle to pause/resume code while it is scrolling.
' Enter Auto continue (scroll both) to the next no match.
' Esc Quit
Width 70, 20
_Font 16
_ScreenMove 20, 0
v1top = 2: v1btm = 20
v2top = 22: v2btm = 40
View Print
Cls
If Len(_Clipboard$) > 100 Then
Print "Warning: This application will erase your current clipboard contents."
Print: Print "Press Enter to continue or Esc to quit..."
Do
b$ = InKey$
If Len(b$) Then
If b$ = Chr$(27) Then System
If b$ = Chr$(13) Then Exit Do
End If
_Limit 60
Loop
_Clipboard$ = Chr$(0)
Else
hold$ = _Clipboard$
_Clipboard$ = Chr$(0)
End If
Cls
Do
redo1:
While -1
Locate 1, 1: View Print CsrLin To _Height - 1: Cls 2: View Print
Locate 1, 1: Print "Paste first directory name: ": Locate 3, 1, 1, 7, 30
Do
_Limit 60
b$ = InKey$
If Len(b$) Then
_Limit 10
Select Case b$
Case Chr$(27): System
Case Chr$(13): dir1$ = _CWD$: Exit Do
Case Chr$(32): GoSub manual: If x$ = "" Then redo = 1: b$ = Chr$(8): Exit While
End Select
End If
If Len(_Clipboard$) Then GoSub clip: dir1$ = x$: Exit Do
Loop
_Clipboard$ = Chr$(0)
If Right$(dir1$, 1) <> "\" Then dir1$ = dir1$ + "\"
Locate 3, 1: Print dir1$
If _DirExists(dir1$) Then Exit While Else Print "Directory not found: "; dir1$; " Any key to redo...";: Sleep
Wend
If b$ = Chr$(8) Then Exit Do
redo2:
While -1
Locate 5, 1: View Print CsrLin To _Height - 1: Cls 2: View Print
Locate 5, 1: Print "Paste first file name: ": Locate 7, 1
If Len(filehold$) Then
file1$ = filehold$: filehold$ = ""
Else
Do
_Limit 60
b$ = InKey$
If Len(b$) Then
Select Case b$
Case Chr$(27): System
Case Chr$(8): redo = 1: Exit While
Case Chr$(32): GoSub manual: If x$ = "" Then redo = 2: b$ = Chr$(8): Exit While
End Select
End If
If Len(_Clipboard$) Then GoSub clip: file1$ = x$: Exit Do
Loop
End If
_Clipboard$ = Chr$(0)
If InStr(file1$, ".") = 0 Then file1$ = file1$ + ".bas"
Print file1$
If _FileExists(dir1$ + file1$) Then Exit While Else Print "File not found: "; dir1$ + file1$; " Any key to redo...";: Sleep
Wend
If b$ = Chr$(8) Then Exit Do
redo3:
While -1
Locate 9, 1: View Print CsrLin To _Height - 1: Cls 2: View Print
Locate 9, 1: Print "Paste second directory name: ": Locate 11, 1
Do
_Limit 60
b$ = InKey$
If Len(b$) Then
Select Case b$
Case Chr$(27): System
Case Chr$(8): redo = 2: Exit While
Case Chr$(13): dir2$ = _CWD$: Exit Do
Case Chr$(9): dir2$ = dir1$: Exit Do
Case Chr$(32): GoSub manual: If x$ = "" Then redo = 3: b$ = Chr$(8): Exit While
End Select
End If
If Len(_Clipboard$) Then GoSub clip: dir2$ = x$: Exit Do
Loop
_Clipboard$ = Chr$(0)
If Right$(dir2$, 1) <> "\" Then dir2$ = dir2$ + "\"
Print dir2$
If _DirExists(dir2$) Then Exit While Else Print "Directory not found: "; dir2$; " Any key to redo...";: Sleep
Wend
If b$ = Chr$(8) Then Exit Do
redo4:
While -1
Locate 13, 1: View Print CsrLin To _Height - 1: Cls 2: View Print
Locate 13, 1: Print "Paste second file name: ": Locate 15, 1
If Len(filehold$) Then
file2$ = filehold$: filehold$ = ""
Else
Do
_Limit 60
b$ = InKey$
If Len(b$) Then
Select Case b$
Case Chr$(27): System
Case Chr$(8): redo = 3: Exit While
Case Chr$(9): file2$ = file1$: Exit Do
Case Chr$(32): GoSub manual: If x$ = "" Then redo = 4: b$ = Chr$(8): Exit While
End Select
End If
If Len(_Clipboard$) Then GoSub clip: file2$ = x$: Exit Do
Loop
End If
_Clipboard$ = Chr$(0)
If InStr(file2$, ".") = 0 Then file2$ = file2$ + ".bas"
Print file2$
If _FileExists(dir2$ + file2$) Then Exit Do Else Print "File not found: "; dir2$ + file2$; " Any key to redo...";: Sleep
Wend
If b$ = Chr$(8) Then Exit Do
Loop
If b$ = Chr$(8) Then
On redo GOTO redo1, redo2, redo3, redo4
End If
If dir1$ + file1$ = dir2$ + file2$ Then
Beep
Print "Error: Both directory and file names are the same. Cannot compare the same file. Any key to redo": Sleep
If InKey$ = Chr$(27) Then System Else Run
End If
Print: Print "Ready. Press any key to begin comparison...": Sleep
Width 150, 41
_Font 16
_ScreenMove 20, 0
start:
Cls
Locate 1, 1: Color 15, 1: Print Space$(_Width);
Locate 21, 1: Print Space$(_Width);
Locate 1, 2: Color 15, 1: Print dir1$;: Color 14, 1: Print file1$;
Locate 21, 2: Color 15, 1: Print dir2$;: Color 14, 1: Print file2$;
Color 7, 0
ReDim c1$(10000), c2$(10000): c1 = 0: p1 = 0: c2 = 0: p2 = 0
' Quick compare...
If Not _FileExists(dir1$ + file1$) Then
Print: Print "Cannot find file: " + dir1$ + file1$ + ". Any key to retry.": _Delay 1: Sleep
End If
If Not _FileExists(dir2$ + file2$) Then
Print: Print "Cannot find file: " + dir2$ + file2$ + ". Any key to retry.": _Delay 1: Sleep
End If
Open dir1$ + file1$ For Binary As #1
Open dir2$ + file2$ For Binary As #2
x1$ = Space$(LOF(1))
x2$ = Space$(LOF(2))
Get #1, , x1$
Get #2, , x2$
Close #1, 2
If x1$ = x2$ Then
Locate 41, 2: Print "Both files are identical. Press Enter to rerun or Esc to quit...";
Do
_Limit 30
b$ = InKey$
If Len(b$) Then
Select Case b$
Case Chr$(27)
System
Case Chr$(13): Cls: _Delay 1: Run
End Select
End If
Loop
End If
Open dir1$ + file1$ For Input As #1
Open dir2$ + file2$ For Input As #2
Do Until EOF(1)
Line Input #1, a$
a$ = RTrim$(LTrim$(a$))
If Mid$(a$, 1, 1) > " " Then
c1 = c1 + 1
c1$(c1) = a$
End If
Loop
Close #1
Do Until EOF(2)
Line Input #2, a$
a$ = RTrim$(LTrim$(a$))
If Mid$(a$, 1, 1) > " " Then
c2 = c2 + 1
c2$(c2) = a$
End If
Loop
Close #2
Locate 2, 1
onscr1$ = c1$(1)
onscr2$ = c1$(1)
yy1 = v1top: yy2 = v2top
p1 = 0: p2 = 0: auto = -1
Do
_Limit 300 ' Controls speed of screen display.
If auto = -1 And b$ <> Chr$(13) Then
If onscr1$ <> onscr2$ Then
Locate 41, 2, 1, 7, 30
Color 14, 0
Print "No Match! ";
auto = 0
Color 7, 0
End If
End If
If auto Then
p$ = InKey$
Select Case p$
Case Chr$(27): System
Case Chr$(32)
y = CsrLin: x = Pos(0): Locate 41, 2: Color 14, 0: Print " Paused...";: Color 7, 0
Do: _Limit 30: p$ = InKey$: Loop Until p$ = Chr$(32)
Locate 41, 2: Print " ";
Locate y, x
End Select
If auto < 0 Then b$ = "1": auto = 1 Else b$ = "2": auto = -1
Else
b$ = InKey$
End If
If Len(b$) Then
Select Case b$
Case Chr$(27): System
Case Chr$(0) + Chr$(59): _Clipboard$ = c1$(p1)
Case Chr$(0) + Chr$(60): _Clipboard$ = c2$(p2)
Case Chr$(13), Chr$(0) + "P": b$ = Chr$(13): auto = -1: Locate 41, 2, 1, 7, 0: Print " ";
Case "1", "2"
Locate 41, 2, 1, 7, 0: Print " ";
If b$ = "1" And Len(c1$(p1 + 1)) Then
View Print v1top To v1btm
p1 = p1 + 1
Locate yy1, 1: Print p1; c1$(p1): yy1 = CsrLin
onscr1$ = c1$(p1)
End If
If b$ = "2" And Len(c2$(p2 + 1)) Then
View Print v2top To v2btm
p2 = p2 + 1
Locate yy2, 1: Print p2; c2$(p2): yy2 = CsrLin
onscr2$ = c2$(p2)
End If
End Select
End If
If p1 = c1 And p2 = c2 Then Exit Do
Loop
Close
Locate _Height, 2: Color 14, 0: Print "Finished. [R]un [V]iew Again [Q]uit: ";: Locate , , 1, 7, 30
Color 7, 0
Do
_Limit 30
b$ = InKey$
If Len(b$) Then
If UCase$(b$) = "Q" Or b$ = Chr$(27) Then System
If UCase$(b$) = "R" Then _Clipboard$ = hold$: Cls: Run
If UCase$(b$) = "V" Then View Print: GoTo start
End If
Loop
Locate _Height, 1: Print Space$(_Width - 1);
Locate _Height, 1: Print " Restore prior clipboard contents to clipboard? Y/N";
Do
b$ = InKey$
_Limit 30
If Len(b$) Then
If b$ = Chr$(27) Then System
If UCase$(b$) = "Y" Then Print "Y";: _Delay 2: _Clipboard$ = hold$: Exit Do
If UCase$(b$) = "N" Then Exit Do
End If
Loop
System
clip:
Sound 1000, .3
x$ = _Trim$(_Clipboard$)
If InStr(x$, Chr$(13)) Then x$ = Mid$(x$, 1, InStr(x$, Chr$(13)) - 1)
If InStr(x$, ".") And InStr(x$, "\") <> 0 Then
If dir1$ = "" Then
filehold$ = Mid$(x$, _InStrRev(x$, "\") + 1)
x$ = Mid$(x$, 1, _InStrRev(x$, "\"))
ElseIf dir2$ = "" Then
filehold$ = Mid$(x$, _InStrRev(x$, "\") + 1)
x$ = Mid$(x$, 1, _InStrRev(x$, "\"))
End If
End If
Return
manual:
y = CsrLin: x = 12
Line Input "Type name: ", x$: Locate y, x
If Len(x$) Then _Clipboard$ = x$ Else _Clipboard$ = Chr$(0)
Return
Oh, and if you're a REAL lazy SOB like me, you'll want to compile this as an exe and make a desktop shortcut.
Code: (Select All)
count = _CommandCount
For i = 1 To count
cmd$ = Command$(i)
Print cmd$
_Clipboard$ = Command$(i) ' Dragged files from File Explorer provide the path and file name, here.
Next
System
1) Compile as an exe and make a desktop shortcut (Send to Desktop). Don't run this program. Run the FIRST program and instead of 4 times copying to the clipboard, you can just DRAG each of the two files you want compared from File Explorer into that desktop shortcut, one at a time. So just two input operations. The program does the rest, and shows you the results on the screen.
I would recommend trying it out on a couple of files you already have backed up, just for your own piece of mind.
THE ROUTINE DOES USE ONE INSTANCE OF OPEN FOR BINARY. Note it does not use PUT, so it won't change your files. Also, it checks for file and directory existence, so it won't make any 0 byte files, either. Honestly, in 25 years of online forums, I've only encountered one 'person' who would intentionally try to mess others up. Still, I think it is always wise to check code, before you run it, for keywords like KILL, BINARY, OUTPUT, etc. to see how they are used.
Let me know if you have any questions. The keys are listed at the top of the code.
Pete
|
|
|
| QBJS Cauchy integral |
|
Posted by: vince - 10-24-2024, 07:46 PM - Forum: QBJS, BAM, and Other BASICs
- Replies (2)
|
 |
using the GPU to evaluate and contour cauchy's integral formula for f(z)=1 evaluated along an arbitrary open bezier curve with draggable control points. this is also known as the 'canonical logarithm' because, for a straight line segment, it analytically evaluates to a log function.
|
|
|
|
| program that stitches together a bunch of image files into one giant poster? |
|
Posted by: madscijr - 10-23-2024, 07:55 PM - Forum: Help Me!
- Replies (15)
|
 |
Before I go and reinvent the wheel, I'm wondering if this or something similar already exists...?
I'm thinking a program that - looks in a directory like "c:\Users\MyUser\Pictures"
(extra points if it can handle environment variables like "%USERPROFILE%\Pictures")
- finds all images (extra points if it lets you specify 1 or more wildcards to match like "*.jpg;*.png;*.gif")
- gets the size of all of them and figures out (based on layout chosen) how big the final image will be & initialize it
(I'm not sure what kind of limitations QB64PE has for image size, I am thinking this prog would limit the size only based on the computer memory & hard drive space)
- for each pic:
loads it into memory,
resize/scale/rotate (depending on options)
copies to a new giant image (depending on the layout you choose,
e.g., if we have 16 pictures, maybe 4 columns x 4 rows, or 8 columns x 2 rows)
- outputs a new image file in the selected format.
I'm thinking of some fancy features like if the pictures are different sizes, it can resize them / rotate them / stretch them, depending on what you can choose, to whatever the largest common dimension is, or maybe it can detect a picture's orientation, and auto rotate so they are all landscape or portrait, or figure out how to lay them out so there is minimal blank space.
Maybe an option to not rotate but fill in the blank space with a given background color, or if there are not enough pics for an even # of rows/columns, fill in empty areas with some default color or pattern.
Some of the things I'm going to have to figure out how to do for this include - list files from a folder
- match based on *? wildcards
- load an image file into a _NewImage
- detect image height/width
- rotate image
- scale/resize image
- stretch/skew image
- display an image bigger than the screen shrunk down to fit the screen (to preview on screen)
- save image from memory to a file
Simple use cases: - make a pic collage for your PC's desktop
- take a bunch of pictures and turn them into a poster you can have printed at somewhere like CVS (the web site says 24"x36" is $15.99 ?!)
- make a background for a game
Has anyone seen or done anything like that?
|
|
|
|
| WPF Message Boxes |
|
Posted by: SpriggsySpriggs - 10-23-2024, 05:36 PM - Forum: General Discussion
- Replies (8)
|
 |
This is not something new. This is something I made a long time ago that I may or may not be trying to work on again. I like message boxes. Always have. Especially customizable ones. These are highly customizable and can replace the built-in error message boxes in QB64.
|
|
|
|
| Zeller's congruence pass 3: test day-of-week calculation algorythms for accuracy |
|
Posted by: TDarcos - 10-23-2024, 05:04 PM - Forum: Utilities
- No Replies
|
 |
After my recent debacles with getting a Zeller's congruence (determine day of week from date) formula, I repeated my foray into software archeology, by searching my collection of 90,142 files (many being zip files) and more than 12 gb of Basic source and basic-related files, I found an old file that purports to return day of week from date. It was old enough to be from the days when Basic programs had to have line numbers:
Code: (Select All)
_Title "Possibly_accurate_zellers_congruence"
10 ' DAYOPFWK = Calculates the day of the week given date
20 '
30 Cls: Print
40 Print " This routine calculates the day of the week given the date"
50 Dim DAYS$(6): For I = 0 To 6: Read DAY$(I): Next
60 Data Saturday,Sunday,Monday,Tuesday,Wednesday,Thursday,Friday
70 Line Input "Enter date as mm/dd/yyyy "; EDATE$: S$ = EDATE$
80 PS = InStr(S$, "/"): MONTH = Val(Left$(S$, PS - 1)): S$ = Mid$(S$, PS + 1)
90 PS = InStr(S$, "/"): DAY = Val(Left$(S$, PS - 1)): S$ = Mid$(S$, PS + 1)
100 YEAR = Val(S$)
110 '
120 If MONTH > 2 Then 140
130 MONTH = MONTH + 12: YEAR = YEAR - 1
140 N = DAY + 2 * MONTH + Int(.6 * (MONTH + 1)) + YEAR + Int(YEAR / 4) - Int(YEAR / 100) + Int(YEAR / 400) + 2
150 N = Int((N / 7 - Int(N / 7)) * 7 + .5)
160 Print DAY$(N)
A few tests seem to confirm it is accurate, but let's really put it to the test. Rerun it thousands, or hundreds of thousands of times, and see if it's right. I have my Zeller's Congruence test harness; let's "strap it in, fire up the motor and see if it lights, or explodes on the test site."
The operative part of the above program is lines numbered 120-150. So, I have this:
Code: (Select All)
' Date_testbed.bas - load every date and test a Zeller's congrence algorithm for correctness
' Paul Robinson October 23, 2024
Option _Explicit
_Title "Zeller_testbed"
' The system time function can be used from QB64, I was mistaken it could not
Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Declare Dynamic Library "kernel32"
Function GetLocalTime& (lpSystemTime As SYSTEMTIME)
Function GetLastError& ()
Function FormatMessageA& (ByVal f As Long, f$, Byval e As Long, Byval d As Long, g$, Byval s As Long, h$)
End Declare
Dim As SYSTEMTIME StartTime, EndTime
Dim TimeString As String
Color 15
Cls
Const Saturday = 0
Const Sunday = Saturday + 1
Const Monday = Sunday + 1
Const Tuesday = Monday + 1
Const Wednesday = Tuesday + 1
Const Thursday = Wednesday + 1
Const Friday = Thursday + 1
Const January = 1, February = 2, March = 3, April = 4, May = 5, June = 6
Const July = 7, August = 8, September = 9, October = 10, November = 11, December = 12
Const LimitYear = 9999
Dim Shared YD(1800 To LimitYear, December, 31) As Integer
' Dim As Integer Month
Dim Shared As Integer Year, Month, Day, Hour, Minute, Second, Leap
'Dim Shared Year$, Month$, Day$, WeekDay$, Minute$, Second$, AmPm$
'Dim Shared As String DateString
Dim As Integer DayStart, I, WindowsOffset, ZellersOffset
Dim As Long RecCount
' these use 1-12 for convenience
Dim Shared MonthDays(1, December) As Integer, MonthNames(December) As String
' This one uses 0
Dim Shared DayNames(12) As String
Data "January",31,"February",28,"March",31,"April",30,"May",31
Data "June",30,"July",31,"August",31,"September",30
Data "October",31,"November",30,"December",31
Data "Saturday","Sunday","Monday","Tuesday","Wednesday","Thursday","Friday","Saturday","Sunday","Monday","Tuesday","Wednesday","Thursday"
For Month = January To December: Read MonthNames(Month), MonthDays(0, Month): Next
For Month = January To December: MonthDays(1, Month) = MonthDays(0, Month): Next ' Leap years
For Day = 0 To 12: Read DayNames(Day): Next
' We start Saturday =0 as most Zeller's congruence algorhythms do
' If either the test routine or Windows starts any other day, add the offset
WindowsOffset = 1 ' Windows starts Sunday
ZellersOffset = 0 ' The Zeller's Congruence starts Saturday
MonthDays(1, February) = 29 'Adjust for leap year
' Start the clock
I = GetLocalTime(StartTime)
TimeString = DayNames(StartTime.wDayOfWeek + WindowsOffset) + ", "
TimeString = TimeString + " " + MonthNames(StartTime.wMonth)
TimeString = TimeString + Str$(StartTime.wDay) + "," + Str$(StartTime.wYear) + " at"
TimeString = TimeString + Str$(StartTime.wHour) + ":"
TimeString = TimeString + Right$("0" + LTrim$(Str$(StartTime.wMinute)), 2) + ":"
TimeString = TimeString + Right$("0" + LTrim$(Str$(StartTime.wSecond)), 2)
Open "L:\ZteatResults.txt" For Output As #1
DPrint "Program begins, " + TimeString
DPrint "Initialization: Collecting dates from 1-1-1800 to 12-31-" + LTrim$(Str$(LimitYear))
DPrint "Please wait while initialization is completed"
Dim As _Byte ok, PP, Sc, InitialDay
ok = -1
InitialDay = Wednesday ' January 1, 1800
DayStart = InitialDay
RecCount = 0
PP = 0
For Year = 1800 To LimitYear
' Leap Year Calcultions
GoSub GetLeap
' Now count the days
For Month = January To December
For Day = 1 To MonthDays(Leap, Month) ' if leap year, uses alternate
YD(Year, Month, Day) = DayStart
DayStart = DayStart + 1
RecCount = RecCount + 1
If DayStart = 7 Then DayStart = 0
Next
Next
Next
I = GetLocalTime(EndTime) ' Stop the clock
' Compute elapsed time
Hour = EndTime.wHour
If StartTime.wHour < EndTime.wHour Then Hour = Hour + 24
Hour = Hour - StartTime.wHour
Minute = EndTime.wMinute
If StartTime.wMinute < EndTime.wMinute Then Minute = Minute + 60: Hour = Hour - 1
Minute = Minute - StartTime.wMinute
Second = EndTime.wSecond
If StartTime.wSecond < EndTime.wSecond Then Minute = Minute - 1: Second = Second + 60
Second = Second - StartTime.wSecond
Dim As Single St, Et
Et = EndTime.wMilliseconds / 1000
St = StartTime.wMilliseconds / 1000
If Et < St Then Second = Second - 1: Et = Et + 1
Et = (Et - St)
TimeString = ""
If Hour > 0 Then
TimeString = Str$(Hour) + "hour"
If Hour <> 1 Then TimeString = TimeString + "s"
TimeString = TimeString + " "
End If
If Minute > 0 Then
TimeString = TimeString + Str$(Minute) + "minute"
If Minute <> 1 Then TimeString = TimeString + "s"
TimeString = TimeString + " "
End If
If TimeString <> "" Then TimeString = TimeString + "and "
If Second < 0 Then Second = 0
TimeString = TimeString + LTrim$(Str$(Second + Et)) + " seconds."
DPrint "Initialization completed;" + Str$(RecCount) + " records initialized. "
DPrint "Initialization took " + TimeString
Second = Hour * 3600 + Minute * 60 + Second
Dim As Integer ProcessCount
If Second + Et > 3 Then
ProcessCount = RecCount / (Second + Et)
DPrint "Initilization rate was approx. " + Str$(ProcessCount) + "records per second."
End If
DPrint ""
DPrint "A check will be made to see how accurate the Zeller's congruence algorhythm is."
' Insert code to test here
Dim DOW As Single
Month = 1
Day = 1
Year = 1800
I = 0
GoSub Zeller
DPrint "January 1, 1800 was a " + DayNames(YD(Year, Month, Day)) + ", the algorhythm says it was " + DayNames(DOW) + "."
If YD(Year, Month, Day) <> DOW Then DPrint "": DPrint "Algorhythm fails.": Close: End
Locate 10, 1
DPrint "Now let's see how accurate it is:"
Locate 12, 1
Print "Year"
RecCount = 0
For Year = 1800 To LimitYear
Locate 12, 5
Print Year
Leap = 0
GoSub GetLeap
For Month = January To December
For Day = 1 To MonthDays(Leap, Month)
GoSub Zeller
If DOW <> YD(Year, Month, Day) + ZellersOffset Then
Locate 15, 1
Color 4
DPrint "Mismatch on " + MonthNames(Month) + Str$(Day) + ", " + Str$(Year)
DPrint "Precalc is :" + DayNames(YD(Year, Month, Day) + ZellersOffset) + " but Zeller says " + DayNames(DOW + ZellersOffset)
Color 15
I = I + 1
End If
Next
Next
Next
Locate 17, 1
Dim ERCMsg$
If I = 0 Then ERCMsg$ = "NO " Else ERCMsg$ = Str$(I)
DPrint "Completed with " + ERCMsg$ + "errors."
DPrint "There were " + Str$(RecCount) + " date computations."
DPrint ""
If I = 0 Then
DPrint ""
DPrint "I believe this certifies the algorhythm is accurate."
Else
DPrint "Algorhythm fails."
End If
Close
End
GetLeap:
' Leap Year Calcultions
Leap = 0
' Year mod 4 = 0 for a leap year (in most cases)
If Year Mod 4 = 0 Then ' It is virtually certain it is a leap year with one exception
' If it is a century year (year where last two digits are 00)
If Year Mod 100 <> 0 Then ' Not a century year
Leap = 1 ' regular leap year
Else ' It is a century year, it must also be divisible by 400
If Year Mod 400 = 0 Then Leap = 1 ' Century leap year
End If
End If
Return
Dim As Integer Zmonth, ZYear
Zeller:
If Month < 3 Then
Zmonth = Month + 12
ZYear = Year - 1
Else
Zmonth = Month
ZYear = Year
End If
DOW = Day + 2 * Zmonth + Int(.6 * (Zmonth + 1)) + ZYear + Int(ZYear / 4) - Int(ZYear / 100) + Int(ZYear / 400) + 2
DOW = Int((DOW / 7 - Int(DOW / 7)) * 7 + .5)
RecCount = RecCount + 1
Return
' Text output can't be captured off screen through
' mouse or hilighting, so we also print to a file
Sub DPrint (P$)
Print P$
Print #1, P$
End Sub
Note I did not change the original algorhythm even if there might be more succinct ways of doing it, for one simple reason: i believe it works, and I can always come back later and "modernize" it
Let's run it and see how accurate it is:
Program begins, Wednesday, October 23, 2024 at 12:55:05
Initialization: Collecting dates from 1-1-1800 to 12-31-9999
Please wait while initialization is completed
Initialization completed; 2994988 records initialized.
Initialization took .09 seconds.
A check will be made to see how accurate the Zeller's congruence algorhythm is.
January 1, 1800 was a Wednesday, the algorhythm says it was Wednesday.
Now let's see how accurate it is:
Completed with NO errors.
There were 2994988 date computations.
I believe this certifies the algorhythm is accurate.
|
|
|
|
| suggestion - show search string in search results |
|
Posted by: madscijr - 10-23-2024, 04:36 PM - Forum: Site Suggestions
- Replies (2)
|
|
I noticed that when I use the search bar to find something in the forums,
for example, "read image file into memory",
that after you click Search and the results are displayed, the search string is nowhere to be seen.
The URL is no help either, because instead of the search terms, just it contains some ID, for example
Code: (Select All) https://qb64phoenix.com/forum/search.php?action=results&sid=87e359e46ab483cc3b0f10a8e9f25f0b&sortby=&order=desc
So to remember what it was you were searching for, you have to click Back in the browser, and see what's in the Search box.
Would it be possible to show the original search string on the search results page?
Because when I'm researching how to do things for a project, I might have 5 or more searches open in the browser, and it would be helpful to be able to, at a glance, see what I was looking for in each tab.
|
|
|
|
|
![[Image: Screenshot-2024-10-24-203042.png]](https://i.ibb.co/ZSZMbfm/Screenshot-2024-10-24-203042.png)
