| Welcome, Guest |
You have to register before you can post on our site.
|
|
|
| Time - Not a Library |
|
Posted by: TarotRedhand - 05-18-2022, 03:31 PM - Forum: Utilities
- Replies (1)
|
 |
If it wasn't for the fact that of the 26 routines contained in this only 2 of them are public, this would have gone in the libraries section. This is a reworking of something I made years ago. Originally it made use of DOS calls in order to get the information that it uses. Fortunately, after considering what is available in QB64 I was able to get this information via a different method. In the end I only had to change 2 SUBs but there was a single piece of information that I got from the DOS calls that wasn't easily available in QB64. In the end it meant an additional function using an algorithm I found online. So what is it?
What I am posting this time is just a pair of public functions and all that one of the pair does is to get the current date and time from the system. The second function is I hope worthy of your attention. What it does is similar to one of the functions that comes as standard with ANSI C - I've just extended it a little. Basically, what this second function does is to take a string that contains codes embedded in it and it uses this string to produce a second string with dates/times expanded at the point where the codes were in the template string. With this routine you can have the dates/times in whatever format you wish (this includes the year being in Roman numerals. It is at this point that I realise that actions definitely speak louder than words and so suggest you look at the comments contained in the original TIME.BI for an explanation of what these routines do and to run TIMETEST.BAS.
For additional information, read the comments in the original BI file (but don't use it, it won't work!)
TIMid.BI (obsolete)
Code: (Select All) REM ******************************************************
REM * Filespec : time.bas time.bi testtime.bas *
REM * Date : August 8 1997 *
REM * Time : 19:01 *
REM * Revision : 1.00B *
REM * Update : *
REM ******************************************************
REM * Released to the Public Domain *
REM ******************************************************
CONST FALSE% = 0, TRUE% = -1
TYPE When
Second AS INTEGER '| 0..59
Minute AS INTEGER '| 0..59
Hour AS INTEGER '| 0..23
WeekDay AS INTEGER '| 1..7
MonthDay AS INTEGER '| 1..[28 or 29 or 30 or 31]
YearDay AS INTEGER '| 1..[365 or 366]
YearWeek AS INTEGER '| 1..52
Month AS INTEGER '| 1..12
Year AS INTEGER
IsLeapYear AS INTEGER '| TRUE% or FALSE%
END TYPE
REM ******************************************************************
REM * The following 2 routines rely upon the accuracy of the PC's *
REM * internal clock and calendar. i.e. if your PC's clock or *
REM * calendar are inaccurate then the output from these routines *
REM * will be inaccurate to the same degree. *
REM ******************************************************************
DECLARE SUB ThisInstant(Now AS When)
REM ******************************************************************
REM * This routine produces a snapshot of the time and date at the *
REM * instant that it is called and fills the variable Now with the *
REM * information obtained. It uses DOS routines to gather the *
REM * information and so works from 1/1/80 to 31st December 2099. *
REM ******************************************************************
DECLARE SUB FTString(FormatString$, OutputString$, Now AS When)
REM ******************************************************************
REM * This routine produces a string (OutputString$) with time and *
REM * date information embedded within it, as specified by the *
REM * information encoded within FormatString$. The variable Now *
REM * may be used to specify a specific time and date or Now may be *
REM * updated as part of this routine so that the current time and *
REM * date are used instead. *
REM * *
REM * If FormatString$ contains no temporal codes it will simply be *
REM * copied to OutputString$. If during processing of *
REM * FormatString$ an invalid code is encountered, processing will *
REM * cease and an immediate return to SYSTEM occurs with an *
REM * appropriate error message displayed. *
REM * *
REM * There are 29 different temporal codes in all, each of which *
REM * starts with the tilde (CHR$(126), '~') character. The action *
REM * of this routine is to copy everything contained in *
REM * FormatString, except the codes, to OutputString. When a code *
REM * is encountered, it is replaced in OutputString by the *
REM * sub-string that corresponds to that code. In the following *
REM * explanation of the codes and their meanings I have, for *
REM * reasons of brevity, used the word output to signify the *
REM * replacement of a particular code by the sub-string that is *
REM * described immediately following the usage of the word output. *
REM * The codes and their meanings follow hereafter. *
REM * *
REM *----------------------------------------------------------------*
REM * *
REM * ~1 - Set all time output after this to be in 12 hour *
REM * format. *
REM * *
REM * ~2 - Set all time output after this to be in 24 hour *
REM * format. *
REM * *
REM * ~A - Output either am or pm depending on the time. *
REM * *
REM * ~B - Output the month in abbreviated form *
REM * (Jan, Feb etc.). *
REM * *
REM * ~C - Output the full month name *
REM * (January, February etc.). *
REM * *
REM * ~D - Output full date as January 1 1996 etc. *
REM * *
REM * ~E - Output numeric date in dd/mm/yy form. *
REM * *
REM * ~F - Output full date as 1 January 1996 etc. *
REM * *
REM * ~G - Output numeric date in mm/dd/yy form. *
REM * *
REM * ~H - Output the Hour. *
REM * *
REM * ~I - Output the day of the week in abbreviated form. *
REM * (Mon, Tue etc.) *
REM * *
REM * ~J - Output the full name of the day of the week. *
REM * (Monday, Tuesday etc.) *
REM * *
REM * ~K - Output the time in short form HH:MM. *
REM * *
REM * ~L - Output the time in long form HH:MM:SS. *
REM * *
REM * ~M - Output the Minute. *
REM * *
REM * ~N - Output the Numeric day of week (1 = Sunday). *
REM * *
REM * ~O - Output the Numeric day of the month (1, 2, 3 etc.).*
REM * *
REM * ~P - Output the Numeric Month (1 = January). *
REM * *
REM * ~Q - Output the Numeric day of the month with the *
REM * appropriate suffix (1st, 2nd, 3rd, 4th etc.). *
REM * *
REM * ~R - Output the year in ROMAN numerals - MCMXCVI. *
REM * *
REM * ~S - Output the Second. *
REM * *
REM * ~T - Output the total date in the form - *
REM * Sunday 18th February 1996. *
REM * *
REM * ~U - Update (or get new) the information in the *
REM * variable 'Now'. *
REM * *
REM * ~V - Output the date in the form - 18th Feb 96. *
REM * *
REM * ~W - Output the week of the year - 1 to 52. *
REM * *
REM * ~X - Output the day of the year - *
REM * 1 to 365 or 366 in leap year. *
REM * *
REM * ~Y - Output the year in the form 1996. *
REM * *
REM * ~Z - Output the year in the form 96. *
REM * *
REM * ~r - Output the total date in the form - *
REM * Sun 18th Feb 96. *
REM * *
REM * ~~ - Output the character ~ (CHR$(126), '~'). *
REM * *
REM *----------------------------------------------------------------*
REM * *
REM * An example of the usage of this routine is as follows:- *
REM * *
REM * FT$ = "~U~1Today, ~T, at precisely ~L~A, I resigned." *
REM * FTString FT$, Out$, Now *
REM * *
REM * Which should result in Out$ containing the following (assuming *
REM * the dates and times contained) :- *
REM * *
REM * Today, Sunday 18th February 1996, at precisely 12:40pm, I *
REM * resigned. *
REM ******************************************************************
Here is the actual working BI file -
TIME.BI
Code: (Select All) REM ******************************************************
REM * Filespec : time.bas time.bi testtime.bas *
REM * Date : August 8 1997 *
REM * Time : 19:01 *
REM * Revision : 1.00B *
REM * Update : *
REM ******************************************************
REM * Released to the Public Domain *
REM ******************************************************
CONST FALSE% = 0, TRUE% = -1
COMMON SHARED Hours24%
Hours24% = FALSE%
TYPE When
Second AS INTEGER '| 0..59
Minute AS INTEGER '| 0..59
Hour AS INTEGER '| 0..23
WeekDay AS INTEGER '| 1..7
MonthDay AS INTEGER '| 1..[28 or 29 or 30 or 31]
YearDay AS INTEGER '| 1..[365 or 366]
YearWeek AS INTEGER '| 1..52
Month AS INTEGER '| 1..12
Year AS INTEGER
IsLeapYear AS INTEGER '| TRUE% or FALSE%
END TYPE
Now the BM file
TIME.BM
Code: (Select All) REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
FUNCTION DayOfWeek(Year$, Month%, Day%)
DIM Year%, Code%
Year% = VAL(Year$)
Code% = VAL(RIGHT$(YEAR$, 2))
Code% = (Code% + (Code% \ 4)) Mod 7
Code% = Code% + VAL(MID$("033614625035", Month%, 1))
IF (YEAR% >= 2000) THEN
Code% = Code% + 6
END IF
IF (((Year% MOD 400) = 0) AND (Month% > 2))THEN
Code% = Code% + 1
ELSEIF (((Year% MOD 4) = 0) AND ((Year% MOD 100) <> 0) AND (Month% > 2)) THEN
Code% = Code% + 1
END IF
Code% = Code% + Day%
DayOfWeek = 1 + (Code% MOD 7)
END FUNCTION
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetDate(Year%, Month%, Day%, WeekDay%)
DIM TempDate$
TempDate$ = DATE$
Year% = VAL(RIGHT$(TempDate$, 4))
Month% = VAL(LEFT$(TempDate$, 2))
Day% = VAL(MID$(TempDate$, 4, 2))
WeekDay% = DayOfWeek(LTRIM$(STR$(Year%)), Month%, Day%)
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetTime(Hours%, Minutes%, Seconds%)
DIM AllSeconds AS LONG
AllSeconds = TIMER
Hours% = AllSeconds \ 3600
AllSeconds = AllSeconds MOD 3600
Minutes% = AllSeconds \ 60
Seconds% = AllSeconds MOD 60
END SUB
REM ******************************************************************
REM * This routine produces a snapshot of the time and date at the *
REM * instant that it is called and fills the variable Now with the *
REM * information obtained. It uses DOS routines to gather the *
REM * information and so works from 1/1/80 to 31st December 2099. *
REM ******************************************************************
SUB ThisInstant(Now AS When)
GetDate Now.Year, Now.Month, Now.MonthDay, Now.WeekDay
Now.IsLeapYear = FALSE%
IF (Now.Year MOD 400) = 0 THEN
Now.IsLeapYear = TRUE%
ELSEIF ((Now.Year MOD 4) = 0) AND ((Now.Year MOD 100) <> 0) THEN
Now.IsLeapYear = TRUE%
END IF
DayOfYear Now.Month, Now.MonthDay, Now.IsLeapYear, Now.YearDay
WeekOfYear Now.YearDay, Now.YearWeek
GetTime Now.Hour, Now.Minute, Now.Second
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB DayOfYear(Month%, Day%, LeapYear%, YearDay%)
YearDay% = Day%
IF Month% > 1 THEN
SELECT CASE (Month% - 1)
CASE 1
YearDay% = YearDay% + 31
CASE 2
YearDay% = YearDay% + 59
CASE 3
YearDay% = YearDay% + 90
CASE 4
YearDay% = YearDay% + 120
CASE 5
YearDay% = YearDay% + 151
CASE 6
YearDay% = YearDay% + 181
CASE 7
YearDay% = YearDay% + 212
CASE 8
YearDay% = YearDay% + 243
CASE 9
YearDay% = YearDay% + 273
CASE 10
YearDay% = YearDay% + 304
CASE 11
YearDay% = YearDay% + 334
END SELECT
IF ((Month% > 2) AND LeapYear%) THEN
YearDay% = YearDay% + 1
END IF
END IF
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB WeekOfYear(YearDay%, Week%)
Week% = YearDay% \ 7
IF ((YearDay% MOD 7) <> 0) THEN
Week% = Week% + 1
END IF
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB StringWeekDay(DayCode%, DayString$)
SELECT CASE DayCode%
CASE 1
DayString$ = "Sunday"
CASE 2
DayString$ = "Monday"
CASE 3
DayString$ = "Tuesday"
CASE 4
DayString$ = "Wednesday"
CASE 5
DayString$ = "Thursday"
CASE 6
DayString$ = "Friday"
CASE 7
DayString$ = "Saturday"
END SELECT
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB StringShortDay(DayCode%, DayString$)
SELECT CASE DayCode%
CASE 1
DayString$ = "Sun"
CASE 2
DayString$ = "Mon"
CASE 3
DayString$ = "Tue"
CASE 4
DayString$ = "Wed"
CASE 5
DayString$ = "Thu"
CASE 6
DayString$ = "Fri"
CASE 7
DayString$ = "Sat"
END SELECT
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB StringMonth(MonthCode%, MonthString$)
SELECT CASE MonthCode%
CASE 1
MonthString$ = "January"
CASE 2
MonthString$ = "February"
CASE 3
MonthString$ = "March"
CASE 4
MonthString$ = "April"
CASE 5
MonthString$ = "May"
CASE 6
MonthString$ = "June"
CASE 7
MonthString$ = "July"
CASE 8
MonthString$ = "August"
CASE 9
MonthString$ = "September"
CASE 10
MonthString$ = "October"
CASE 11
MonthString$ = "November"
CASE 12
MonthString$ = "December"
END SELECT
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB StringShortMonth(MonthCode%, MonthString$)
SELECT CASE MonthCode%
CASE 1
MonthString$ = "Jan"
CASE 2
MonthString$ = "Feb"
CASE 3
MonthString$ = "Mar"
CASE 4
MonthString$ = "Apr"
CASE 5
MonthString$ = "May"
CASE 6
MonthString$ = "Jun"
CASE 7
MonthString$ = "Jul"
CASE 8
MonthString$ = "Aug"
CASE 9
MonthString$ = "Sep"
CASE 10
MonthString$ = "Oct"
CASE 11
MonthString$ = "Nov"
CASE 12
MonthString$ = "Dec"
END SELECT
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetHour(Hour%, TempString$)
TempString$ = ""
IF NOT Hours24% THEN
IF Hour% = 0 THEN
TempString$ = "12"
ELSE
IF Hour% > 12 THEN
Hour% = Hour% - 12
END IF
END IF
END IF
IF TempString$ = "" THEN
TempString$ = LTRIM$(RTRIM$(STR$(Hour%)))
DO WHILE LEN(TempString$) < 2
TempString$ = "0" + TempString$
LOOP
END IF
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB ShortYear(Year%, TempString$)
TempYear% = (Year% MOD 100)
TempString$ = LTRIM$(RTRIM$(STR$(TempYear%)))
DO WHILE LEN(TempString$) < 2
TempString$ = "0" + TempString$
LOOP
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetSuffix(MonthDay%, TempString$)
IF ((MonthDay% > 3) AND (MonthDay% < 21))THEN
TempString$ = "th"
ELSE
TempMonthDay% = MonthDay% MOD 10
SELECT CASE TempMonthDay%
CASE 0
TempString$ = "th"
CASE 1
TempString$ = "st"
CASE 2
TempString$ = "nd"
CASE 3
TempString$ = "rd"
CASE ELSE
TempString$ = "th"
END SELECT
END IF
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetTwoDigits(Number%, TempString$)
TempString$ = LTRIM$(RTRIM$(STR$(Number% MOD 100)))
DO WHILE LEN(TempString$) < 2
TempString$ = "0" + TempString$
LOOP
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetShortTime(Now AS When, TempString$)
GetHour Now.Hour, TempString$
GetTwoDigits Now.Minute, Minute$
TempString$ = TempString$ + ":" + Minute$
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetLongTime(Now AS When, TempString$)
GetShortTime Now, TempString$
GetTwoDigits Now.Second, Second$
TempString$ = TempString$ + ":" + Second$
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetNumericDateUK(Now AS When, TempString$)
GetTwoDigits Now.MonthDay, MonthDay$
GetTwoDigits Now.Month, Month$
ShortYear Now.Year, Year$
TempString$ = MonthDay$ + "/" + Month$ + "/" + Year$
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetNumericDateUSA(Now AS When, TempString$)
GetTwoDigits Now.MonthDay, MonthDay$
GetTwoDigits Now.Month, Month$
ShortYear Now.Year, Year$
TempString$ = Month$ + "/" + MonthDay$ + "/" + Year$
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetFullDateUK(Now AS When, TempString$)
MonthDay$ = LTRIM$(RTRIM$(STR$(Now.MonthDay MOD 100)))
StringMonth Now.Month, Month$
Year$ = LTRIM$(RTRIM$(STR$(Now.Year MOD 10000)))
TempString$ = MonthDay$ + " " + Month$ + " " + Year$
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetFullDateUSA(Now AS When, TempString$)
MonthDay$ = LTRIM$(RTRIM$(STR$(Now.MonthDay MOD 100)))
StringMonth Now.Month, Month$
Year$ = LTRIM$(RTRIM$(STR$(Now.Year MOD 10000)))
TempString$ = Month$ + " " + MonthDay$ + " " + Year$
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetTotalDateUK(Now AS When, TempString$)
StringWeekDay Now.WeekDay, WeekDay$
MonthDay$ = LTRIM$(RTRIM$(STR$(Now.MonthDay MOD 100)))
GetSuffix Now.MonthDay, Suffix$
StringMonth Now.Month, Month$
Year$ = LTRIM$(RTRIM$(STR$(Now.Year MOD 10000)))
TempString$ = WeekDay$ + " " + MonthDay$ + Suffix$ + " " + Month$ + " " + Year$
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetShortDateUK(Now AS When, TempString$)
MonthDay$ = LTRIM$(RTRIM$(STR$(Now.MonthDay MOD 100)))
GetSuffix Now.MonthDay, Suffix$
StringShortMonth Now.Month, Month$
ShortYear Now.Year, Year$
TempString$ = MonthDay$ + Suffix$ + " " + Month$ + " '" + Year$
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetTotalShortDateUK(Now AS When, TempString$)
StringShortDay Now.WeekDay, WeekDay$
MonthDay$ = LTRIM$(RTRIM$(STR$(Now.MonthDay MOD 100)))
GetSuffix Now.MonthDay, Suffix$
StringShortMonth Now.Month, Month$
ShortYear Now.Year, Year$
TempString$ = WeekDay$ + " " + MonthDay$ + Suffix$ + " " + Month$ + " '" + Year$
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetRomanYear(TheYear%, TempString$)
IF TheYear% <> 0 THEN
TempString$ = ""
TempYear% = TheYear%
DO WHILE TempYear% >= 1000
TempString$ = TempString$ + "M"
TempYear% = TempYear% - 1000
LOOP
IF TempYear% >= 900 THEN
TempString$ = TempString$ + "CM"
TempYear% = TempYear% - 900
END IF
DO WHILE TempYear% >= 500
TempString$ = TempString$ + "D"
TempYear% = TempYear% - 500
LOOP
IF TempYear% >= 400 THEN
TempString$ = TempString$ + "CD"
TempYear% = TempYear% - 400
END IF
DO WHILE TempYear% >= 100
TempString$ = TempString$ + "C"
TempYear% = TempYear% - 100
LOOP
IF TempYear% >= 90 THEN
TempString$ = TempString$ + "XC"
TempYear% = TempYear% - 90
END IF
DO WHILE TempYear% >= 50
TempString$ = TempString$ + "L"
TempYear% = TempYear% - 50
LOOP
IF TeYear% >= 40 THEN
TempString$ = TempString$ + "XL"
TempYear% = TempYear% - 40
END IF
DO WHILE TempYear% >= 10
TempString$ = TempString$ + "X"
TempYear% = TempYear% - 10
LOOP
IF TempYear% >= 9 THEN
TempString$ = TempString$ + "IX"
TempYear% = TempYear% - 9
END IF
DO WHILE TempYear% >= 5
TempString$ = TempString$ + "V"
TempYear% = TempYear% - 5
LOOP
IF TempYear% >= 4 THEN
TempString$ = TempString$ + "IV"
TempYear% = TempYear% - 4
END IF
DO WHILE TempYear% > 0
TempString$ = TempString$ + "I"
TempYear% = TempYear% - 1
LOOP
END IF
END SUB
REM ******************************************************
REM * Private SUB - Do not call directly *
REM ******************************************************
SUB GetTemporalString(FormatChar$, Now AS When, TempString$)
SELECT CASE LEFT$(FormatChar$, 1)
CASE "1"
Hours24% = FALSE
CASE "2"
Hours24% = TRUE
CASE "A"
IF Now.Hour > 11 THEN
TempString$ = "pm"
ELSE
TempString$ = "am"
END IF
CASE "B"
StringShortMonth Now.Month, TempString$
CASE "C"
StringMonth Now.Month, TempString$
CASE "D"
GetFullDateUSA Now, TempString$
CASE "E"
GetNumericDateUK Now, TempString$
CASE "F"
GetFullDateUK Now, TempString$
CASE "G"
GetNumericDateUSA Now, TempString$
CASE "H"
GetHour Now.Hour, TempString$
CASE "I"
StringShortDay Now.WeekDay, TempString$
CASE "J"
StringWeekDay Now.WeekDay, TempString$
CASE "K"
GetShortTime Now, TempString$
CASE "L"
GetLongTime Now, TempString$
CASE "M"
GetTwoDigits Now.Minute, TempString$
CASE "N"
TempString$ = LTRIM$(RTRIM$(STR$(Now.WeekDay MOD 10)))
CASE "O"
TempString$ = LTRIM$(RTRIM$(STR$(Now.MonthDay MOD 100)))
CASE "P"
TempString$ = LTRIM$(RTRIM$(STR$(Now.Month MOD 100)))
CASE "Q"
TempString$ = LTRIM$(RTRIM$(STR$(Now.MonthDay MOD 100)))
GetSuffix Now.MonthDay, Suffix$
TempString$ = TempString$ + Suffix$
CASE "R"
GetRomanYear Now.Year, TempString$
CASE "S"
GetTwoDigits Now.Second, TempString$
CASE "T"
GetTotalDateUK Now, TempString$
CASE "U"
ThisInstant Now
CASE "V"
GetShortDateUK Now, TempString$
CASE "W"
TempString$ = LTRIM$(RTRIM$(STR$(Now.YearWeek MOD 100)))
CASE "X"
TempString$ = LTRIM$(RTRIM$(STR$(Now.YearDay MOD 1000)))
CASE "Y"
TempString$ = LTRIM$(RTRIM$(STR$(Now.Year MOD 10000)))
CASE "Z"
ShortYear Now.Year, TempString$
CASE "r"
GetTotalShortDateUK Now, TempString$
CASE "~"
TempString$ = "~"
END SELECT
END SUB
REM ******************************************************************
REM * This routine produces a string (OutputString$) with time and *
REM * date information embedded within it, as specified by the *
REM * information encoded within FormatString$. The variable Now *
REM * may be used to specify a specific time and date or Now may be *
REM * updated as part of this routine so that the current time and *
REM * date are used instead. *
REM * *
REM * If FormatString$ contains no temporal codes it will simply be *
REM * copied to OutputString$. If during processing of *
REM * FormatString$ an invalid code is encountered, processing will *
REM * cease and an immediate return to SYSTEM occurs with an *
REM * appropriate error message displayed. *
REM * *
REM * There are 29 different temporal codes in all, each of which *
REM * starts with the tilde (CHR$(126), '~') character. The action *
REM * of this routine is to copy everything contained in *
REM * FormatString, except the codes, to OutputString. When a code *
REM * is encountered, it is replaced in OutputString by the *
REM * sub-string that corresponds to that code. In the following *
REM * explanation of the codes and their meanings I have, for *
REM * reasons of brevity, used the word output to signify the *
REM * replacement of a particular code by the substring that is *
REM * described immediately following the usage of the word output. *
REM * The codes and their meanings follow hereafter. *
REM * *
REM *----------------------------------------------------------------*
REM * *
REM * ~1 - Set all time output after this to be in 12 hour *
REM * format. *
REM * *
REM * ~2 - Set all time output after this to be in 24 hour *
REM * format. *
REM * *
REM * ~A - Output either am or pm depending on the time. *
REM * *
REM * ~B - Output the month in abbreviated form *
REM * (Jan, Feb etc.). *
REM * *
REM * ~C - Output the full month name *
REM * (January, February etc.). *
REM * *
REM * ~D - Output full date as January 1 1996 etc. *
REM * *
REM * ~E - Output numeric date in dd/mm/yy form. *
REM * *
REM * ~F - Output full date as 1 January 1996 etc. *
REM * *
REM * ~G - Output numeric date in mm/dd/yy form. *
REM * *
REM * ~H - Output the Hour. *
REM * *
REM * ~I - Output the day of the week in abbreviated form. *
REM * (Mon, Tue etc.) *
REM * *
REM * ~J - Output the full name of the day of the week. *
REM * (Monday, Tuesday etc.) *
REM * *
REM * ~K - Output the time in short form HH:MM. *
REM * *
REM * ~L - Output the time in long form HH:MM:SS. *
REM * *
REM * ~M - Output the Minute. *
REM * *
REM * ~N - Output the Numeric day of week (1 = Sunday). *
REM * *
REM * ~O - Output the Numeric day of the month (1, 2, 3 etc). *
REM * *
REM * ~P - Output the Numeric Month (1 = January). *
REM * *
REM * ~Q - Output the Numeric day of the month with the *
REM * appropriate suffix (1st, 2nd, 3rd, 4th etc.). *
REM * *
REM * ~R - Output the year in ROMAN numerals - MCMXCVI. *
REM * *
REM * ~S - Output the Second. *
REM * *
REM * ~T - Output the total date in the form - *
REM * Sunday 18th February 1996. *
REM * *
REM * ~U - Update (or get new) the information in the *
REM * variable 'Now'. *
REM * *
REM * ~V - Output the date in the form - 18th Feb 96. *
REM * *
REM * ~W - Output the week of the year - 1 to 52. *
REM * *
REM * ~X - Output the day of the year - *
REM * 1 to 365 or 366 in leap year. *
REM * *
REM * ~Y - Output the year in the form 1996. *
REM * *
REM * ~Z - Output the year in the form 96. *
REM * *
REM * ~r - Output the total date in the form - *
REM * Sun 18th Feb 96. *
REM * *
REM * ~~ - Output the character ~ (CHR$(126), '~'). *
REM * *
REM *----------------------------------------------------------------*
REM * *
REM * An example of the usage of this routine is as follows:- *
REM * *
REM * FT$ = "~U~1Today, ~T, at precisely ~L~A, I resigned." *
REM * FTString FT$, Out$, Now *
REM * *
REM * Which should result in Out$ containing the following (assuming *
REM * the dates and times contained) :- *
REM * *
REM * Today, Sunday 18th February 1996, at precisely 12:40pm, I *
REM * resigned. *
REM ******************************************************************
SUB FTString(FormatString$, OutputString$, Now AS When)
ValidChars$ = "12ABCDEFGHIJKLMNOPQRSTUVWXYZr~"
IF INSTR(FormatString$, "~") THEN
OutputString$ = ""
FOR Index% = 1 TO LEN(FormatString$)
ch$ = MID$(FormatString$, Index%, 1)
IF ch$ <> "~" THEN
OutputString$ = OutputString$ + ch$
ELSE
Index% = Index% + 1
ch$ = MID$(FormatString$, Index%, 1)
IF INSTR(ValidChars$, ch$) THEN
GetTemporalString ch$, Now, TempString$
IF ch$ <> "U" THEN
OutputString$ = OutputString$ + TempString$
END IF
ELSE
PRINT "Fatal Error in SUB FTString -"
PRINT "Invalid Format character ";ch$;" in "+"";FormatString$
PRINT "Terminating program now!
SYSTEM
END IF
END IF
NEXT
ELSE
OutputString$ = FormatString$
END IF
END SUB
Note - the FUNCTION DayOfWeek() is only valid from the year 1900 onwards.
Finally the test BAS file -
TESTTIME.BAS
Code: (Select All) '$INCLUDE: 'TIME.BI'
DIM Now AS When
ThisInstant Now
CLS
PRINT "Testing ThisInstant"
PRINT
PRINT "It is ";Now.Hour;":";Now.Minute;":";Now.Second
PRINT "On day ";Now.WeekDay;" of week ";Now.YearWeek;" of year ";Now.Year
PRINT "On day ";Now.MonthDay;" of month ";Now.Month", day ";Now.YearDay;
PRINT " of the year"
PRINT Now.Year;" is ";
IF Now.IsLeapYear THEN
PRINT"a leapyear"
ELSE
PRINT"not a leapyear"
END IF
AnyKey
CLS
A$ = "Testing option A - ~A"
B$ = "Testing option B - ~B"
C$ = "Testing option C - ~C"
D$ = "Testing option D - ~D"
E$ = "Testing option E - ~E"
F$ = "Testing option F - ~F"
G$ = "Testing option G - ~G"
H$ = "Testing option H - ~H"
I$ = "Testing option I - ~I"
J$ = "Testing option J - ~J"
K$ = "Testing option K - ~K"
L$ = "Testing option L - ~L"
M$ = "Testing option M - ~M"
N$ = "Testing option N - ~N"
O$ = "Testing option O - ~O"
P$ = "Testing option P - ~P"
Q$ = "Testing option Q - ~Q"
R$ = "Testing option R - ~R"
R2$ = "Testing option r - ~r"
S$ = "Testing option S - ~S"
T$ = "Testing option T - ~T"
V$ = "Testing option V - ~V"
W$ = "Testing option W - ~W"
X$ = "Testing option X - ~X"
Y$ = "Testing option Y - ~Y"
Z$ = "Testing option Z - ~Z"
T1$ = "~1"
T2$ = "~2"
UP$ = "~U"
Start1$ = UP$ + T1$
Start2$ = UP$ + T2$
FTString T2$, Out1$, Now
CLS
FTString A$, Out1$, Now
PRINT Out1$
FTString B$, Out1$, Now
PRINT Out1$
FTString C$, Out1$, Now
PRINT Out1$
FTString D$, Out1$, Now
PRINT Out1$
FTString E$, Out1$, Now
PRINT Out1$
FTString F$, Out1$, Now
PRINT Out1$
FTString G$, Out1$, Now
PRINT Out1$
FTString H$, Out1$, Now
PRINT Out1$
FTString I$, Out1$, Now
PRINT Out1$
FTString J$, Out1$, Now
PRINT Out1$
FTString K$, Out1$, Now
PRINT Out1$
FTString L$, Out1$, Now
PRINT Out1$
FTString M$, Out1$, Now
PRINT Out1$
AnyKey
CLS
FTString N$, Out1$, Now
PRINT Out1$
FTString O$, Out1$, Now
PRINT Out1$
FTString P$, Out1$, Now
PRINT Out1$
FTString Q$, Out1$, Now
PRINT Out1$
FTString R$, Out1$, Now
PRINT Out1$
FTString R2$, Out1$, Now
PRINT Out1$
FTString S$, Out1$, Now
PRINT Out1$
FTString T$, Out1$, Now
PRINT Out1$
FTString V$, Out1$, Now
PRINT Out1$
FTString W$, Out1$, Now
PRINT Out1$
FTString X$, Out1$, Now
PRINT Out1$
FTString Y$, Out1$, Now
PRINT Out1$
FTString Z$, Out1$, Now
PRINT Out1$
AnyKey
CLS
FTString T1$, Out1$, Now
FTString A$, Out1$, Now
PRINT Out1$
FTString B$, Out1$, Now
PRINT Out1$
FTString C$, Out1$, Now
PRINT Out1$
FTString D$, Out1$, Now
PRINT Out1$
FTString E$, Out1$, Now
PRINT Out1$
FTString F$, Out1$, Now
PRINT Out1$
FTString G$, Out1$, Now
PRINT Out1$
FTString H$, Out1$, Now
PRINT Out1$
FTString I$, Out1$, Now
PRINT Out1$
FTString J$, Out1$, Now
PRINT Out1$
FTString K$, Out1$, Now
PRINT Out1$
FTString L$, Out1$, Now
PRINT Out1$
FTString M$, Out1$, Now
PRINT Out1$
AnyKey
CLS
FTString N$, Out1$, Now
PRINT Out1$
FTString O$, Out1$, Now
PRINT Out1$
FTString P$, Out1$, Now
PRINT Out1$
FTString Q$, Out1$, Now
PRINT Out1$
FTString R$, Out1$, Now
PRINT Out1$
FTString R2$, Out1$, Now
PRINT Out1$
FTString S$, Out1$, Now
PRINT Out1$
FTString T$, Out1$, Now
PRINT Out1$
FTString V$, Out1$, Now
PRINT Out1$
FTString W$, Out1$, Now
PRINT Out1$
FTString X$, Out1$, Now
PRINT Out1$
FTString Y$, Out1$, Now
PRINT Out1$
FTString Z$, Out1$, Now
PRINT Out1$
AnyKey
CLS
FTString Start2$, Out1$, Now
FTString A$, Out1$, Now
PRINT Out1$
FTString B$, Out1$, Now
PRINT Out1$
FTString C$, Out1$, Now
PRINT Out1$
FTString D$, Out1$, Now
PRINT Out1$
FTString E$, Out1$, Now
PRINT Out1$
FTString F$, Out1$, Now
PRINT Out1$
FTString G$, Out1$, Now
PRINT Out1$
FTString H$, Out1$, Now
PRINT Out1$
FTString I$, Out1$, Now
PRINT Out1$
FTString J$, Out1$, Now
PRINT Out1$
FTString K$, Out1$, Now
PRINT Out1$
FTString L$, Out1$, Now
PRINT Out1$
FTString M$, Out1$, Now
PRINT Out1$
AnyKey
CLS
FTString N$, Out1$, Now
PRINT Out1$
FTString O$, Out1$, Now
PRINT Out1$
FTString P$, Out1$, Now
PRINT Out1$
FTString Q$, Out1$, Now
PRINT Out1$
FTString R$, Out1$, Now
PRINT Out1$
FTString R2$, Out1$, Now
PRINT Out1$
FTString S$, Out1$, Now
PRINT Out1$
FTString T$, Out1$, Now
PRINT Out1$
FTString V$, Out1$, Now
PRINT Out1$
FTString W$, Out1$, Now
PRINT Out1$
FTString X$, Out1$, Now
PRINT Out1$
FTString Y$, Out1$, Now
PRINT Out1$
FTString Z$, Out1$, Now
PRINT Out1$
AnyKey
CLS
FTString Start1$, Out1$, Now
FTString A$, Out1$, Now
PRINT Out1$
FTString B$, Out1$, Now
PRINT Out1$
FTString C$, Out1$, Now
PRINT Out1$
FTString D$, Out1$, Now
PRINT Out1$
FTString E$, Out1$, Now
PRINT Out1$
FTString F$, Out1$, Now
PRINT Out1$
FTString G$, Out1$, Now
PRINT Out1$
FTString H$, Out1$, Now
PRINT Out1$
FTString I$, Out1$, Now
PRINT Out1$
FTString J$, Out1$, Now
PRINT Out1$
FTString K$, Out1$, Now
PRINT Out1$
FTString L$, Out1$, Now
PRINT Out1$
FTString M$, Out1$, Now
PRINT Out1$
AnyKey
CLS
FTString N$, Out1$, Now
PRINT Out1$
FTString O$, Out1$, Now
PRINT Out1$
FTString P$, Out1$, Now
PRINT Out1$
FTString Q$, Out1$, Now
PRINT Out1$
FTString R$, Out1$, Now
PRINT Out1$
FTString R2$, Out1$, Now
PRINT Out1$
FTString S$, Out1$, Now
PRINT Out1$
FTString T$, Out1$, Now
PRINT Out1$
FTString V$, Out1$, Now
PRINT Out1$
FTString W$, Out1$, Now
PRINT Out1$
FTString X$, Out1$, Now
PRINT Out1$
FTString Y$, Out1$, Now
PRINT Out1$
FTString Z$, Out1$, Now
PRINT Out1$
AnyKey
END
SUB AnyKey
DO
QQ$ = INKEY$
LOOP UNTIL QQ$ <> ""
END SUB
'$INCLUDE: 'TIME.BM'
TR
|
|
|
| Redirect old-forum and wiki search results to Pheonix as appropriate. |
|
Posted by: mpgcan - 05-18-2022, 02:37 PM - Forum: General Discussion
- Replies (4)
|
 |
You know how it goes. Searching for a QB64 solution, search engines return results to the old-forum or old-wiki. Clicking the link only to be informed the server is not found.
With the link returned, you can use part of it to search in either the new-wiki or old-backup forum. This has become very tedious. I thought there must be a better way.
A simple solution is to use Einar Egilsson's Redirector for this. It is a browser add-on for Firefox, Chrome, Edge and Opera. The Redirector allows you to search for a specific URL, substitute it for another URL and force the browser to redirect to this new URL.
How to install redirector on Firefox:
1) Use the following link to get the add-on
https://addons.mozilla.org/en-GB/firefox...edirector/
2) Note: This add-on is not actively monitored for security by Mozilla.
Check out the "Learn more" link. After reading your choice if you wish to continue.
3) Click the Add to Firefox button.
4) Add Redirector? This extension will have permission to:
Click Add button
5) Redirector was added.
Click the check box. Allow this extension to run in Private Windows
Click Okay button.
6) A redirector symbol is displayed at the top right of the browser confirming it is successfully installed.
Configuring redirector:
Redirect from the old QB64 forum to Phoenix's old-archived read only working forum.
1) Click on the redirector symbol in the drop down click "Edit Redirects" button.
2) On the new browser page that opens, click "Create New Redirect"
3) Fill in the form with the following information:
Configuration information:
Description: QB64_forum_old_to_archive
Example URL: https://forum.qb64.org/
Include pattern: https://forum.qb64.org/*
Redirect to: https://qb64forum.alephc.xyz/$1
Pattern type: Wildcard click radio buttom
Pattern Description: Leave blank
Example result: https://qb64forum.alephc.xyz/
To complete it, click the "Save" button.
4) Click "Create New Redirect"
5) Fill in the form with the following information:
Configuration information:
Redirect from the old QB64 Wiki to Pheonix's new QB64 Wiki.
Description: QB64_Wiki_old_to_new
Example URL: https://wiki.qb64.org/wiki/
Include pattern: https://wiki.qb64.org/wiki/*
Redirect to: https://qb64phoenix.com/qb64wiki/index.php/$1
Pattern type: Wildcard click radio buttom
Pattern Description: Leave blank
Example result: https://qb64phoenix.com/qb64wiki/index.php/
To complete it, click the "Save" button.
6) Finally disable the first configuration
"Example redirect, try going to http://example.com/anywordhere"
By clicking the "Disable" button.
Test:
Try the following two links in your browser:
https://forum.qb64.org/index.php?topic=456.0
https://wiki.qb64.org/wiki/$IF
All the best
MPGCAN
|
|
|
|
| Image falls to pieces, revealing another one. |
|
Posted by: Dav - 05-17-2022, 12:21 PM - Forum: Programs
- Replies (3)
|
 |
I've been trying to come up with some interesting transitions for an image slideshow (family album thing). I have the regular fades and slides and swaps worked out, trying to get something fancier. Here's something I thought of using rotozoom - break image up to pieces and drop them off the screen, revealing the other one.
It's a mess. Seems to work but thought I'd share it now to get some feedback/help with making it better. Perhaps there's a better way to do this? (There's 2 rotozoom subs in the code to compare them)
- Dav
Code: (Select All) '===============
'IMAGEPIECES.BAS
'===============
'Coded by Dav, MAY/2022
RANDOMIZE TIMER
'=== make 1st image to use (background one)
image1& = _NEWIMAGE(1000, 650, 32)
_DEST image1&
FOR y = 0 TO _HEIGHT
LINE (0, y)-(_WIDTH, y), _RGB(RND * 255, RND * 255, RND * 255), B
NEXT
'=== make 2nd image to use (will fall to pieces)
image2& = _NEWIMAGE(1000, 650, 32)
_DEST image2&
FOR y = 0 TO _HEIGHT
LINE (0, y)-(_WIDTH, y), _RGB(0, 0, RND * 196), B
NEXT
row = 15: col = 10 '15x10 grid of pieces
xsize = _WIDTH / row: ysize = _HEIGHT / col
DIM SHARED piece&(row * col), piecex(row * col), piecey(row * col)
DIM dropspeed(row * col), rotatespeed(row * col)
DIM xwobble(row * col), xwobblespeed(row * col)
'====
main:
'====
bc = 1
FOR c = 1 TO col
FOR r = 1 TO row
'int x/y values for each piece
x1 = (r * xsize) - xsize: x2 = x1 + xsize
y1 = (c * ysize) - ysize: y2 = y1 + ysize
piecex(bc) = x1: piecey(bc) = y1
'make pieces images from image2& screen
piece&(bc) = _NEWIMAGE(ABS(x2 - x1) + 1, ABS(y2 - y1) + 1, 32)
_PUTIMAGE (0, 0), image2&, piece&(bc), (x1, y1)-(x2, y2)
'int random values for each piece
dropspeed(bc) = RND * 2 + 1
rotatespeed(bc) = RND * 2 + 1
xwobble(bc) = INT(RND * 3) + 1 'x move piece (1=none,2=left,3=right)
xwobblespeed(bc) = INT(RND * 2) + .5 'how fast to wobble it
bc = bc + 1
NEXT
NEXT
'make main screen
_DEST 0
SCREEN _NEWIMAGE(1000, 650, 32)
CLS
'=== show 1st image on screen that will fall to pieces
FOR t = 1 TO row * col
RotoZoom piecex(t) + (xsize / 2), piecey(t) + (ysize / 2), piece&(t), 1, 0
NEXT
PRINT "Press enter to break up screen and reveal image behind...";
_DISPLAY
SLEEP
drop = 0: wob = 0
DO
_PUTIMAGE (0, 0), image1& 'background image
'show 1st image breaking up
FOR t = 1 TO row * col
tx = piecex(t): tx2 = piecex(t) + xsize
ty = piecey(t): ty2 = piecey(t) + ysize
SELECT CASE xwobble(t)
CASE 1
'RotoZoom piecex(t) + (xsize / 2), piecey(t) + (ysize / 2) + (drop * dropspeed(t)), piece&(t), 1, (ang * rotatespeed(t))
RotoZoom3 piecex(t) + (xsize / 2), piecey(t) + (ysize / 2) + (drop * dropspeed(t)), piece&(t), 1, 1, (ang * rotatespeed(t))
CASE 2
'RotoZoom piecex(t) + (xsize / 2) - wob, piecey(t) + (ysize / 2) + (drop * dropspeed(t)), piece&(t), 1, (ang * rotatespeed(t))
RotoZoom3 piecex(t) + (xsize / 2) - wob, piecey(t) + (ysize / 2) + (drop * dropspeed(t)), piece&(t), 1, 1, (ang * rotatespeed(t))
wob = wob - xwobblespeed(t)
CASE 3
'RotoZoom piecex(t) + (xsize / 2) + wob, piecey(t) + (ysize / 2) + (drop * dropspeed(t)), piece&(t), 1, (ang * rotatespeed(t))
RotoZoom3 piecex(t) + (xsize / 2) + wob, piecey(t) + (ysize / 2) + (drop * dropspeed(t)), piece&(t), 1, 1, (ang * rotatespeed(t))
wob = wob + xwobblespeed(t)
END SELECT
drop = drop + .1: ang = ang + .1
_LIMIT 3500
NEXT
_DISPLAY
'see if all pieces off screen
done = 1
FOR d = 1 TO row * col
IF piecey(d) + drop < _HEIGHT THEN done = 0
NEXT
IF done = 1 THEN EXIT DO
LOOP
'release pieces from memory
FOR p = 1 TO row * col
_FREEIMAGE piece&(p)
NEXT
GOTO main
SUB RotoZoom (X AS LONG, Y AS LONG, Image AS LONG, Scale AS SINGLE, Rotation AS SINGLE)
DIM px(3) AS SINGLE: DIM py(3) AS SINGLE
W& = _WIDTH(Image&): H& = _HEIGHT(Image&)
px(0) = -W& / 2: py(0) = -H& / 2: px(1) = -W& / 2: py(1) = H& / 2
px(2) = W& / 2: py(2) = H& / 2: px(3) = W& / 2: py(3) = -H& / 2
sinr! = SIN(-Rotation / 57.2957795131): cosr! = COS(-Rotation / 57.2957795131)
FOR i& = 0 TO 3
x2& = (px(i&) * cosr! + sinr! * py(i&)) * Scale + X: y2& = (py(i&) * cosr! - px(i&) * sinr!) * Scale + 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
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
|
|
|
|
| Unhandled Error Bug Fixed |
|
Posted by: TarotRedhand - 05-17-2022, 11:22 AM - Forum: General Discussion
- Replies (9)
|
|
Bug Report.
At the top of my code I have the '$DYNAMIC switch.
I have a sub that takes an array as a parameter.
In that sub I REDIM that array.
The code compiles fine.
When run the compiled code I receive an Unhandled Error message for a Duplicate Definition on the line where I REDIM the array. It asks if I want to continue Yes/No. This shouldn't happen. It is a bug with the current version of QB64. It didn't happen in QB4.5.
TR
|
|
|
|
| artificial net attractors |
|
Posted by: BSpinoza - 05-16-2022, 10:12 AM - Forum: Programs
- Replies (2)
|
 |
This program generates an endless succession of artificial net attractors,
by a program of J.C.Sprott from 1989.
A description you will find in the following paper:
https://sprott.physics.wisc.edu/pubs/paper232.pdf
I made small changes to adapt it into QB64.
Code: (Select All) ' program: neutal_net_attractors.bas
' by J. C. Sprott
'
' adapted to QB64 by BSpinoza
'
' This program produces neural net attractors,
' it generates endless succession of artificial neural net attractors
' Copyright (c) 1997 by J. C. Sprott
SCREEN _NEWIMAGE(880, 650, 256)
WINDOW (-5, -5)-(680, 410)
N% = 4 'Number of neurons
D% = 16 'Number of inputs (dimension)
s = .5 'Scaling factor (network gain)
tmax& = 80000 'Number of iterations
sw% = 638 '319 'Screen width - 1
sh% = 399 '199 'Screen height - 1
nc% = 254 'Number of colors - 2
DIM w(N%, D%), B(N%, D%), x(N%), y(D%), PAL&(nc% + 1)
PAL&(0) = 65536 * 63 + 256 * 63 + 63 'PAL&(0) IS WHITE
PAL&(1) = 65536 * 55 + 256 * 55 + 55 'PAL&(1) IS GRAY
FOR i% = 2 TO nc% + 1
B% = INT(32 + 32 * COS(.02464 * i%))
G% = INT(32 + 32 * COS(.02464 * i% + 4.1888))
R% = INT(32 + 32 * COS(.02464 * i% + 2.0944))
PAL&(i%) = 65536 * B% + 256 * G% + R%
NEXT i%
RANDOMIZE TIMER
WHILE INKEY$ <> CHR$(27)
_DELAY 0.2
CLS
PALETTE USING PAL&(0)
p& = 0
FOR i% = 1 TO N%
FOR j% = 1 TO D%
w(i%, j%) = 1 - 2 * RND
NEXT j%
B(i%, 1) = s * RND
x(i%) = .5
NEXT i%
FOR t& = 1 TO tmax&
y(0) = 0
FOR i% = 1 TO N%
y(0) = y(0) + B(i%, 1) * x(i%)
NEXT i%
FOR j% = D% TO 1 STEP -1
y(j%) = y(j% - 1)
NEXT j%
FOR i% = 1 TO N%
u = 0
FOR j% = 1 TO D%
u = u + w(i%, j%) * y(j%)
NEXT j%
x(i%) = 1 - 2 / (EXP(2 * u) + 1)
NEXT i%
IF t& > tmax& / 50 THEN
IF 10 * p& + 50 < t& - tmax& / 50 THEN t& = tmax&
x% = .5 * (sw% + sw% * x(1))
y% = .5 * (sh% - sh% * x(2))
z% = .025 * (sw% + sw% * x(3))
c% = 2 + INT(nc% * (.5 * x(4) + .5))
IF POINT(x%, y%) < 2 THEN p& = p& + 1
IF c% > POINT(x%, y%) THEN PSET (x%, y%), c%
x% = x% + z%: y% = y% + z%
IF POINT(x%, y%) = 0 THEN PSET (x%, y%), 1
END IF
NEXT t&
WEND
END
|
|
|
|
| Large 2D Graphics Library |
|
Posted by: TarotRedhand - 05-16-2022, 09:10 AM - Forum: One Hit Wonders
- Replies (6)
|
|
This is a 2D graphics library. The routines in this library are mainly (but not entirely) based on algorithms found in the book Computer Graphics (Teach Yourself) by John Landsdown (Amazingly a newer version (1997) than mine (1987) is available at Amazon UK).
There are 2 common types of graphics used with computers - tile graphics and coordinate graphics. This library deals entirely with the latter. The library is accompanied by a demo. The library consists of a BI file, a BM file and a DAT data file. The demo consists of a BAS file and it's own dedicated DAT data file.
This library uses the following conventions. The coordinate pairs are stored in a 2 dimensional array of the form CoordinateArray#(0 TO N, QX% TO QY%). CoordinateArray#(0,QX%) and CoordinateArray#(0, QY%) are used to hold the coordinates of the centre of the graphics object. The following three types are used extensively throughout this library. The type Box2D is used both for storing the coordinates of an imaginary box surrounding each graphics object and also for the storage of the coordinates for graphics windows. AView2D is used to store the device coordinates for viewports. Type Vision combines both a graphics window and a viewport as well as additional information needed for the mapping of the world coordinates (stored in the arrays) to device coordinates (so you can display them).
If the above is all Ancient Greek to you don't panic, Just compile and run the demo to get a flavour of what's here.
Before I post the library in the next post, here is the original BI file (DO NOT USE- Just read) as documentation of the public routines in the library -
Code: (Select All) REM ******************************************************
REM * Filespec : g2.bm g2.bi g2.dat *
REM * : g2demo.bas g2demo.dat *
REM * Date : September 15 1998 *
REM * Time : 12:25 *
REM * Revision : 1.00B *
REM * Update : *
REM ******************************************************
REM * Released to the Public Domain *
REM ******************************************************
'$DYNAMIC
TYPE Box2D
Left AS DOUBLE
Right AS DOUBLE
Top AS DOUBLE
Bottom AS DOUBLE
END TYPE
TYPE AView2D
Left AS INTEGER
Right AS INTEGER
Top AS INTEGER
Bottom AS INTEGER
END TYPE
TYPE Vision
MyWindow AS Box2D
MyView AS AView2D
XMove AS DOUBLE
YMove AS DOUBLE
XBound AS DOUBLE
YBound AS DOUBLE
XFactor AS DOUBLE
YFactor AS DOUBLE
END TYPE
CONST FALSE% = 0
CONST TRUE% = NOT FALSE%
CONST QX% = 1, QY% = 2
CONST PI# = 3.141592653589793#
CONST PIDividedBy2# = 1.57079632679489661923 'PI / 2
CONST PITimes2# = 6.28318530717959 'PI * 2
CONST PITimes3# = 9.42477796076938 'PI * 3
CONST XScale% = 1, YScale% = 2, Scale% = 3
CONST OneSeventeenth# = .05882352941176471#
REM ******************************************************************
REM * The following routines are for the general management of the *
REM * arrays used to hold the coordinates that we are working with. *
REM * All of the following routines return TRUE% if they are *
REM * successful and FALSE% if an error condition was detected. The *
REM * output arrays are automatically resized to exactly the size *
REM * necessary to hold the output data. *
REM ******************************************************************
DECLARE FUNCTION CopyShape2D%(InShape#(), OutShape#())
REM ******************************************************************
REM * Copies InShape#() to OutShape#(). *
REM ******************************************************************
DECLARE FUNCTION AppendShape2D%(This#(), OntoThis#())
REM ******************************************************************
REM * Appends the contents of This#() onto the end of OntoThis#(). *
REM ******************************************************************
DECLARE FUNCTION MakePolygon%(This#(), OntoThis#())
REM ******************************************************************
REM * Identical to the preceding routine with additional action of *
REM * copying the first coordinate pair of OntoThis#() to its end *
REM * after appending This#(). *
REM ******************************************************************
DECLARE FUNCTION InsertShape2D%(This#(), IntoThis#(), AfterThisPoint%)
REM ******************************************************************
REM * Inserts the contents of This#() into IntoThis#() after the *
REM * coordinate pair specified by AfterThis%. *
REM ******************************************************************
DECLARE FUNCTION DeletePoint2D%(This#(), PointNumber%)
REM ******************************************************************
REM * Deletes the coordinate pair specified by PointNumber%, From *
REM * This#(). *
REM ******************************************************************
DECLARE FUNCTION OuterLimits2D%(This#(), MyBounds AS Box2D)
REM ******************************************************************
REM * This routine determines the values for an imaginary box *
REM * surrounding the graphics object held in This#(). These values *
REM * are placed in MyBounds. The exact centre of the object is *
REM * also determined by this routine and the coordinate pair of *
REM * this centre are placed in This#(0, QX%) and This#(0, QY%). *
REM ******************************************************************
REM ******************************************************************
REM * The following routines manipulate the coordinate pairs held in *
REM * the arrays in the manner specified in the individual *
REM * descriptions. Once all calculations are complete the new *
REM * exact centre and boundary values are determined by an *
REM * automatic call to OuterLimits2D%. All of the following *
REM * routines return TRUE% to indicate successful completion or *
REM * FALSE% if an error condition was detected. *
REM ******************************************************************
DECLARE FUNCTION Translate2D%(This#(), MyBounds AS Box2D, ByX#, ByY#)
REM ******************************************************************
REM * Relative movement. Moves the whole object by the amounts *
REM * specified in ByX# and ByY#. *
REM ******************************************************************
DECLARE FUNCTION MoveTo2D%(This#(), MyBounds AS Box2D, ToX#, ToY#)
REM ******************************************************************
REM * Absolute movement. Moves the whole object so that the centre *
REM * of the object is positioned at ToX#, ToY#. *
REM ******************************************************************
DECLARE FUNCTION InflateX2D%(This#(), MyBounds AS Box2D, By#)
REM ******************************************************************
REM * Make the object wider by the amount specified in By#, without *
REM * disturbing the position of it's centre. *
REM ******************************************************************
DECLARE FUNCTION InflateY2D%(This#(), MyBounds AS Box2D, By#)
REM ******************************************************************
REM * Make the object taller by the amount specified in By#, without *
REM * disturbing the position of it's centre. *
REM ******************************************************************
DECLARE FUNCTION Inflate2D%(This#(), MyBounds AS Box2D, By#)
REM ******************************************************************
REM * Make the object larger in both dimensions by the amount *
REM * specified in By#, without disturbing the position of it's *
REM * centre. *
REM ******************************************************************
DECLARE FUNCTION ScaleX2D%(This#(), MyBounds AS Box2D, By#)
REM ******************************************************************
REM * Make the object wider by the amount specified in By#. *
REM ******************************************************************
DECLARE FUNCTION ScaleY2D%(This#(), MyBounds AS Box2D, By#)
REM ******************************************************************
REM * Make the object taller by the amount specified in By#. *
REM ******************************************************************
DECLARE FUNCTION ScaleXY2D%(This#(), MyBounds AS Box2D, ByX#, ByY#)
REM ******************************************************************
REM * Make the object taller (ByY#) and wider (ByX~) by the amount *
REM * specified. *
REM ******************************************************************
DECLARE FUNCTION Scale2D%(This#(), MyBounds AS Box2D, By#)
REM ******************************************************************
REM * Make the object larger by the amount specified in By#. *
REM ******************************************************************
DECLARE FUNCTION ShearX2D%(This#(), MyBounds AS Box2D, By#)
REM ******************************************************************
REM * Shearing in the X plane distorts the figure in a manner that *
REM * relates the amount specified in By# and Y coordinate for each *
REM * point. *
REM ******************************************************************
DECLARE FUNCTION ShearY2D%(This#(), MyBounds AS Box2D, By#)
REM ******************************************************************
REM * Shearing in the Y plane distorts the figure in a manner that *
REM * relates the amount specified in By# and X coordinate for each *
REM * point. *
REM ******************************************************************
DECLARE FUNCTION Shear2D%(This#(), MyBounds AS Box2D, ByX#, ByY#)
REM ******************************************************************
REM * This merely combines shearing in both planes into a single *
REM * procedure. *
REM ******************************************************************
DECLARE FUNCTION Rotation2D%(This#(), MyBounds AS Box2D, Angle#)
REM ******************************************************************
REM * Rotates the figure about the origin (that is the point at 0,0) *
REM * by Angle#. The direction of the rotation is controlled by the *
REM * sign of Angle#. A positive Angle# gives rotation in an *
REM * anti-clockwise direction and a negative one gives a clockwise *
REM * rotation. *
REM ******************************************************************
DECLARE FUNCTION Spin2D%(This#(), MyBounds AS Box2D, Angle#)
REM ******************************************************************
REM * Identical to Rotation2D except that the rotation is about the *
REM * centre of the figure being rotated. *
REM ******************************************************************
DECLARE FUNCTION Orbit2D%(This#(), MyBounds AS Box2D, OrbitX#, OrbitY#, Angle#)
REM ******************************************************************
REM * Identical to Rotation2D except that the rotation is about *
REM * OrbitX#, OrbitY#. *
REM ******************************************************************
REM ******************************************************************
REM * The next 3 routines are for the management of the data types *
REM * used to control which part(s) of the graphical objects we are *
REM * dealing with are visible and where they will be displayed. *
REM * While it is true that QB already has such mechanisms built-in, *
REM * you can only have one graphical window and one view-port at a *
REM * time with these. The graphical system presented here allows *
REM * for multiple such windows and viewports at once. *
REM ******************************************************************
DECLARE FUNCTION SetNewWindow2D%(ThisWindow AS Box2D, Left#, Right#, Top#, Bottom#)
REM ******************************************************************
REM * Stores the values held in Left#, Right#, Top# and Bottom# in *
REM * ThisWindow. *
REM ******************************************************************
DECLARE FUNCTION SetNewViewPort%(ViewPort AS AView2D, Left%, Right%, Top%, Bottom%)
REM ******************************************************************
REM * Stores the values held in Left%, Right%, Top% and Bottom% in *
REM * ViewPort. *
REM ******************************************************************
DECLARE SUB SetNewVision(Vew AS Vision, ThisWindow AS Box2D, ViewPort AS AView2D)
REM ******************************************************************
REM * Copies the contents of ThisWindow and ViewPort to Vew and then *
REM * makes certain calculations, storing the results in Vew. This *
REM * way all of the information necessary for mapping the world *
REM * coordinates (i.e. those stored in the coordinate arrays) to *
REM * the device coordinates (i.e. those of the monitor's screen). *
REM * *
REM * NOTE - if you do not want your graphics to have uncontrolled *
REM * distortion it is essential that the aspect ratio *
REM * (i.e. (Right - Left) / (Top - Bottom)) of ThisWindow and *
REM * ViewPort are identical. *
REM ******************************************************************
DECLARE SUB ClipLine2D(X1Old#, Y1Old#, X2Old#, Y2Old#, X1New#, Y1New#, X2New#, Y2New#, Vew AS Vision, Visible%)
REM ******************************************************************
REM * If a line is within the Box2D held in Vew, it will be trimmed *
REM * to fit if necessary. Visible% flags the obvious. *
REM ******************************************************************
DECLARE FUNCTION ClipDots2D%(Shape2D#(), MyBounds AS Box2D, Vew AS Vision, Dots#())
REM ******************************************************************
REM * Those dots in Shape2D# that are within the Box2D held in Vew *
REM * are returned in dots. *
REM ******************************************************************
REM ******************************************************************
REM * In the context of the following routines a polygon is simply a *
REM * list of coordinates that will be drawn as lines. The way that *
REM * these lines are drawn is as follows. The first line to be *
REM * drawn uses the first pair of coordinates to produce the line. *
REM * The next and subsequent lines use the last coordinates from *
REM * the previous line as their first coordinate and the next *
REM * coordinate as their last coordinate. If a closed figure is *
REM * desired, it is necessary for the last pair of coordinates to *
REM * be identical to the first pair. *
REM * *
REM * A shape, on the other hand is more complex and therefore uses *
REM * an INTEGER array to hold a list of points to be connected in *
REM * the order in which they are to be connected. The format of *
REM * the data held in this array is as follows:- *
REM * *
REM * The first 2 coordinate pairs (i.e. A#(1, QX%), A#(1,QY%) and *
REM * A#(2,QX%), A#(2,QY%)) ALWAYS specify the start and end points *
REM * of the first line of the figure. After that, the last point *
REM * of the preceding pair of points is the start point for the *
REM * next line and the next item specifies the end point of that *
REM * line unless the next A#(N, QX%) is -1. If it is -1 it means *
REM * drop the data already read and treat the next 2 coordinate *
REM * pairs as the start and end points of the next line. As an *
REM * example of this, the snippet of code below is the actual *
REM * connection list for the StarOfDavid which is defined later. *
REM * *
REM * Connections%(0) = 1 *
REM * Connections%(1) = 3 *
REM * Connections%(2) = 5 *
REM * Connections%(3) = 7 *
REM * Connections%(4) = -1 *
REM * Connections%(5) = 2 *
REM * Connections%(6) = 4 *
REM * Connections%(7) = 6 *
REM * Connections%(8) = 2 *
REM * *
REM ******************************************************************
DECLARE FUNCTION DisplayDotsDirect%(Dots#(), MyBounds AS Box2D, ScreenMode%, Colour%)
REM ******************************************************************
REM * Tries to display the points held in Dots on the current *
REM * graphics screen without any clipping or mapping. *
REM ******************************************************************
DECLARE FUNCTION DisplayPolygonDirect%(Polygon#(), MyBounds AS Box2D, ScreenMode%, Colour%)
REM ******************************************************************
REM * Tries to display the lines described in Polygon on the current *
REM * graphics screen without any clipping or mapping. *
REM ******************************************************************
DECLARE FUNCTION DisplayShapeDirect%(Shape2D#(), MyBounds AS Box2D, ConnectionList%(), ScreenMode%, Colour%)
REM ******************************************************************
REM * Tries to display the lines described in Shape2D and List, on *
REM * the current graphics screen without any clipping or mapping. *
REM ******************************************************************
DECLARE FUNCTION DisplayDots%(Dots#(), MyBounds AS Box2D, Colour%, Vew AS Vision)
REM ******************************************************************
REM * Those points held in Dots that are within the Box2D that is *
REM * part of Vew will be clipped, mapped and displayed by this *
REM * routine. *
REM ******************************************************************
DECLARE SUB DisplayLine(X1#, Y1#, X2#, Y2#, Colour%, Vew AS Vision)
REM ******************************************************************
REM * Any portion of the line described by point (X1,Y1) to point *
REM * (X2,Y2), that is within the Box2D that is part of Vew it will *
REM * be clipped, mapped and displayed by this routine. *
REM ******************************************************************
DECLARE FUNCTION DisplayPolygon%(Polygon#(), Colour%, Vew AS Vision)
REM ******************************************************************
REM * Those lines described in Polygon that are within the Box2D *
REM * that is part of Vew will be clipped, mapped and displayed by *
REM * this routine. *
REM ******************************************************************
DECLARE FUNCTION DisplayShape2D%(Shape2D#(), Colour%, ConnectionList%(), Vew AS Vision)
REM ******************************************************************
REM * Those lines described in Shape2D and List that are within the *
REM * Box2D that is part of Vew will be clipped, mapped and *
REM * displayed by this routine. *
REM ******************************************************************
REM ******************************************************************
REM * The graphical objects dealt with in this part of the library *
REM * are of 2 kinds, pre-calculated straight line objects (mostly *
REM * polygons) and curved objects that mostly have to be calculated *
REM * "on the fly" (the exception being circles which are *
REM * pre-calculated). In the context of this library, all curved *
REM * objects are simulated by a number of (comparatively) short *
REM * straight lines. This is done to enable the use of the simple *
REM * transformation routines already described. *
REM * *
REM * For those who don't know the names of regular polygons and the *
REM * number of sides each posses, I enclose the following list. *
REM * *
REM * Sides Name *
REM * *
REM * 3 Triangle *
REM * 4 Square *
REM * 5 Pentagon *
REM * 6 Hexagon *
REM * 7 Heptagon *
REM * 8 Octagon *
REM * 9 Nonagon *
REM * 10 Decagon *
REM * 11 Undecagon *
REM * 12 Dodecagon *
REM * *
REM ******************************************************************
REM ******************************************************************
REM * The following routines all resize and load the array with the *
REM * coordinates for the appropriate shape. All the shapes that *
REM * have the prefix Unit have dimensions that are in the range *
REM * from -1 to +1 and are centred at 0,0. The data for these *
REM * shapes is held in the file SHAPES2D.DAT. *
REM ******************************************************************
DECLARE SUB UnitTriangle(ATriangle#())
DECLARE SUB UnitSquare(ASquare#())
DECLARE SUB UnitPentagon(APentagon#())
DECLARE SUB UnitHexagon(AHexagon#())
DECLARE SUB UnitHeptagon(AHeptagon#())
DECLARE SUB UnitOctagon(AnOctagon#())
DECLARE SUB UnitNonagon(ANonagon#())
DECLARE SUB UnitDecagon(ADecagon#())
DECLARE SUB UnitUndecagon(AnUndecagon#())
DECLARE SUB UnitDodecagon(ADodecagon#())
DECLARE SUB UnitCircle(ThisCircle#())
DECLARE SUB UnitArrow(AnArrow#())
DECLARE SUB UnitParralellogram(AParralellogram#())
DECLARE SUB UnitDiamond(ADiamond#())
REM ******************************************************************
REM * The next set of routines also load the output variable with *
REM * the coordinates of the given shape. The way they work is to *
REM * first get a copy of the appropriate Unit shape, expand them in *
REM * such a way as to produce a figure with sides that are SideSize *
REM * long and then to move the whole figure so that it is centred *
REM * at CenterX, CenterY. *
REM ******************************************************************
DECLARE SUB Triangle(SideSize#, CenterX#, CenterY#, ATriangle#(), MyBounds AS Box2D)
DECLARE SUB Square(SideSize#, CenterX#, CenterY#, ASquare#(), MyBounds AS Box2D)
DECLARE SUB Pentagon(SideSize#, CenterX#, CenterY#, APentagon#(), MyBounds AS Box2D)
DECLARE SUB Hexagon(SideSize#, CenterX#, CenterY#, AHexagon#(), MyBounds AS Box2D)
DECLARE SUB Heptagon(SideSize#, CenterX#, CenterY#, AHeptagon#(), MyBounds AS Box2D)
DECLARE SUB Octagon(SideSize#, CenterX#, CenterY#, AnOctagon#(), MyBounds AS Box2D)
DECLARE SUB Nonagon(SideSize#, CenterX#, CenterY#, ANonagon#(), MyBounds AS Box2D)
DECLARE SUB Decagon(SideSize#, CenterX#, CenterY#, ADecagon#(), MyBounds AS Box2D)
DECLARE SUB Undecagon(SideSize#, CenterX#, CenterY#, AnUndecagon#(), MyBounds AS Box2D)
DECLARE SUB Dodecagon(SideSize#, CenterX#, CenterY#, ADodecagon#(), MyBounds AS Box2D)
DECLARE SUB Arrow(LongSideSize#, CenterX#, CenterY#, AnArrow#(), MyBounds AS Box2D)
DECLARE SUB Diamond(Height#, CenterX#, CenterY#, ADiamond#(), MyBounds AS Box2D)
REM ******************************************************************
REM * The next 2 shapes are slightly more complicated than those *
REM * that have preceded them. They are based around points that *
REM * have already been calculated, but these points are connected *
REM * in a different order to the simple polygons that proceeded *
REM * them and therefore use an INTEGER array to hold a list of *
REM * points to be connected in the order in which they are to be *
REM * connected. In other words these are shapes as described *
REM * earlier. *
REM ******************************************************************
DECLARE SUB Pentagram(Span#, CenterX#, CenterY#, ThisPentagram#(), MyBounds AS Box2D, Connections%())
DECLARE SUB StarOfDavid(Span#, CenterX#, CenterY#, ThisStar#(), MyBounds AS Box2D, Connections%())
REM ******************************************************************
REM * This final set of routines is concerned with the generation of *
REM * curved shapes. Most of the routines in this section actually *
REM * involve calculation as distinct from the preceding routines *
REM * which did not. NOTE - all angles used in this section are *
REM * in degrees. *
REM ******************************************************************
DECLARE FUNCTION CircleInformation%(X1#, Y1#, X2#, Y2#, X3#, Y3#, CenterX#, CenterY#, Radius#)
REM ******************************************************************
REM * Given the three points described by the coordinate pairs *
REM * (X1,Y1), (X2,Y2) and (X3,Y3) this routine calculates the *
REM * centre (CenterX,CenterY) and Radius of a circle. The rules *
REM * for the usage of this routine are that the three points lie on *
REM * the circumference of the circle and are encountered, in order, *
REM * by travelling along the upper hemisphere of the circle in a *
REM * clockwise direction. Further it is an error if all three *
REM * points lie upon a straight line (known as collinearity) and *
REM * FALSE will be returned if this occurs. *
REM ******************************************************************
DECLARE SUB TwinCircleTangent(CenterX1#, CenterY1#, Radius1#, CenterX2#, CenterY2#, Radius2#, Point1X#, Point1Y#, Point2X#, Point2Y#)
REM ******************************************************************
REM * This routine follows a specialised need namely to connect 2 *
REM * arcs with a straight line that flows smoothly into the arcs. *
REM * The way this is done is to take the centres and radii of two *
REM * circles and to calculate the points where an appropriate line *
REM * would be tangential to both. The coordinates of Point1 *
REM * correspond with the details of circle 1 and Point2 with circle *
REM * 2. As for any given pair of circles there are 4 possible *
REM * tangential lines that could connect them a mechanism is needed *
REM * to enable distinction of which line should be calculated. The *
REM * mechanism used is directionality of rotation of the circles *
REM * expressed as the sign of the individual radius's. By this I *
REM * mean that if a radius is negative the corresponding circle is *
REM * assumed to be drawn in a clockwise direction and a positive *
REM * radius, anti-clockwise. Now if you consider the line to be *
REM * drawn as a continuation of the 2 circles it becomes a simple *
REM * matter to determine the signs of the radii to be passed to *
REM * this routine. *
REM ******************************************************************
DECLARE SUB ACircle(Radius#, CenterX#, CenterY#, ThisCircle#(), MyBounds AS Box2D)
REM ******************************************************************
REM * Loads ThisCircle#() with the coordinates of a 72 sided figure *
REM * which simulates a circle of Radius at CenterX, CenterY. *
REM ******************************************************************
DECLARE SUB Ellipse(XRadius#, YRadius#, CenterX#, CenterY#, AnEllipse#(), MyBounds AS Box2D)
REM ******************************************************************
REM * Loads Ellipse#() with the coordinates of a 72 sided figure *
REM * which simulates an ellipse of XRadius, YRadius at CenterX, *
REM * CenterY. The way this works is that a UnitCircle is expanded *
REM * by differing X and Y amounts. *
REM ******************************************************************
DECLARE SUB CalculateAngle(CenterX#, CenterY#, PointX#, PointY#, Angle#)
REM ******************************************************************
REM * Calculates the angle that a line (running from CenterX, *
REM * CenterY to PointX,PointY) makes in relation to the horizontal *
REM * axis. Positive angles indicate that the line is above the *
REM * horizontal axis and negative below. *
REM ******************************************************************
DECLARE FUNCTION GetAngle#(StartAngle#, EndAngle#)
REM ******************************************************************
REM * Calculates the length of an arc, in degrees, of an arc running *
REM * in an anti-clockwise direction from StartAngle to EndAngle. *
REM ******************************************************************
DECLARE FUNCTION ArcInformation%(X1#, Y1#, X2#, Y2#, X3#, Y3#, CenterX#, CenterY#, Radius#, StartAngle#, Degrees#)
REM ******************************************************************
REM * Given 3 points on the circumference of an arc, this routine *
REM * calculates all the information needed to create an arc. Point *
REM * (X1,Y1) is the starting point for the arc, point (X2,Y2) the *
REM * mid-point and point (X3,Y3) the end point of the arc. The *
REM * rules for the usage of this routine are the same as for *
REM * CircleInformation. *
REM ******************************************************************
DECLARE SUB CreateArc(CenterX#, CenterY#, Radius#, StartAngle#, Degrees#, Arc#(), MyBounds AS Box2D)
REM ******************************************************************
REM * Loads Arc#() with the coordinates of an arc described by the *
REM * arguments CenterX#, CenterY#, Radius#, StartAngle# and *
REM * Degrees#. The argument Degrees holds the length of the arc in *
REM * degrees. *
REM ******************************************************************
DECLARE SUB CreateParametricCubicCurve(X1#, Y1#, X2#, Y2#, X3#, Y3#, X4#, Y4#, CubicCurve#(), MyBounds AS Box2D)
REM ******************************************************************
REM * As not all curved shapes are based on conic sections this *
REM * routine and the next offer 2 ways of describing those other *
REM * shapes, based on control points which are external to the *
REM * desired curved shape. In this routine point (X1,Y1) is the *
REM * start point, point (X4,Y4) is the end point. Points (X2,Y2) *
REM * and (X3,Y3) in conjunction with the points already mentioned *
REM * are used to determine the final shape of the curve. This *
REM * routine is based on the algorithm devised by Harry Timmer of *
REM * the Douglas Aircraft Company. This routine (in common with *
REM * many others) uses four blending functions to describe the *
REM * curve parametrically. The characteristic that sets this *
REM * algorithm apart from the others is that if an imaginary line *
REM * is drawn from X2#,Y2# to X3#,Y3# and the curve is then *
REM * calculated and drawn it will be noted that the apex of the *
REM * curve either touches or crosses this line at its centre. *
REM ******************************************************************
DECLARE FUNCTION CreateComplexCurve%(ControlPoints#(), Curve#(), MyBounds AS Box2D)
REM ******************************************************************
REM * This is an extension to the preceding routine. The array *
REM * ControlPoints#() contains a series of control points, the *
REM * number of which must be divisible by 2 and greater than or *
REM * equal to 4 (ideally greater than 4 e.g. at least 6). *
REM ******************************************************************
REM ******************************************************************
REM * The final three routines are here to enable programs to *
REM * interact with the routines presented here. *
REM ******************************************************************
DECLARE FUNCTION DeviceToWorldCoordinates%(InX%, InY%, Vew AS Vision, OutX#, OutY#)
REM ******************************************************************
REM * If a point on the screen (InX%,InY%) is within the viewport in *
REM * Vew the coordinates will be converted to the corresponding *
REM * point in world coordinates and TRUE% returned. Otherwise *
REM * FALSE% is returned. *
REM ******************************************************************
DECLARE FUNCTION InBox%(TX#, TY#, Bounds AS Box2D)
REM ******************************************************************
REM * If the point TX#,TY# is within Bounds TRUE% is returned, *
REM * otherwise FALSE%. *
REM ******************************************************************
DECLARE FUNCTION ClosestPoint%(TX#, TY#, Shape#())
REM ******************************************************************
REM * Returns the number of the coordinate pair in shape#() which is *
REM * closest to TX#, TY#. *
REM ******************************************************************
Library in next post.
TR
|
|
|
|
| Small Collection of Angle Conversion Functions |
|
Posted by: TarotRedhand - 05-16-2022, 08:26 AM - Forum: Utilities
- Replies (4)
|
|
Back in the day I wrote a whole trigonometry library. Looking on the wiki I see that most of what is in that library are incorporated into QB64. Most...
So what we have here are 2 constants, 3 ordinary functions and 4 conversion functions. The conversation functions deal with converting to and from another standard angle measurement type - Gradians (aka Grade). Conversions between radians and degrees are already covered in QB64. The other 3 functions just make sure that angles lie within specified bounds.
Code: (Select All) CONST PI = 3.141592653589793#
CONST PITimes2 = 6.283185307179586#
FUNCTION NormaliseRadians#(Radians AS DOUBLE)
DO WHILE Radians > PI
Radians = Radians - PITimes2
LOOP
DO WHILE Radians < -PI
Radians = Radians + PITimes2
LOOP
NormaliseRadians# = Radians
END FUNCTION
FUNCTION NormaliseDegrees#(Degrees AS DOUBLE)
DO WHILE Degrees > 180
Degrees = Degrees - 360
LOOP
DO WHILE Degrees < -180
Degrees = Degrees + 360
LOOP
NormaliseDegrees# = Degrees
END FUNCTION
FUNCTION NormaliseGrade#(Grade AS DOUBLE)
DO WHILE Grade > 200
Grade = Grade - 400
LOOP
DO WHILE Grade < -200
Grade = Grade + 400
LOOP
NormaliseGrade# = Grade
END FUNCTION
FUNCTION RadiansToGrade#(Radians AS DOUBLE)
RadiansToGrade# = (NormaliseRadians#(Radians) * (200 / PI))
END FUNCTION
FUNCTION DegreesToGrade#(Degrees AS DOUBLE)
DegreesToGrade# = (NormaliseDegrees#(Degrees) * 1.111111111111111)
END FUNCTION
FUNCTION GradeToRadians#(Grade AS DOUBLE)
GradeToRadians# = (NormaliseGrade#(Grade) * (PI / 200))
END FUNCTION
FUNCTION GradeToDegrees#(Grade AS DOUBLE)
GradeToDegrees# = (NormaliseGrade#(Grade) * .9)
END FUNCTION
TR
|
|
|
|
|
